Repository: rocq-prover/rocq
Pull request #20655: Monomorphize sort polymorphic code in extraction.
Author: login: ppedrot
Labels: name: part: extraction
description: The extraction mechanism.
name: kind: enhancement
description: Enhancement to an existing user-facing feature, tactic, etc.
Created: 2025-05-19T20:45:30Z | Merged: 2025-05-22T08:20:57Z

For each sort-polymorphic declaration, we generate 2^n extracted declarations where n is the number of quantified sorts. The code relies on global references in extraction being replaced by a globref + a monomorphic instance. Some bits of code are still not extremely clean, and this PR needs testing and polishing but seems to work for simple examples.

TODO:
- ~~Write tests.~~
- ~~Try to write the code in a way that doesn't trigger a gazillion of reserved identifiers when using sort-poly definitions.~~
- ~~Maybe find a better naming scheme? Currently the name of a sort-poly definition is built out of the base name + a suffix. The suffix is empty when all sorts are relevant, and is made of X and O indicating the erasure status for each sort in order otherwise.~~ This was deemed appropriate by @mattam82 and @SkySkimmer .


Diff:
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index 2247fb6a4985..6d326e1cbe0b 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -235,7 +235,6 @@ type t = {
   (* fields below are read-only *)
   modular : bool;
   library : bool;
-  extrcompute : bool;
   (*s Extraction modes: modular or monolithic, library or minimal ?
 
   Nota:
@@ -258,12 +257,11 @@ let make_state kw = {
   mpfiles_content = MPmap.empty;
 }
 
-let make ~modular ~library ~extrcompute ~keywords () = {
+let make ~modular ~library ~keywords () = {
   table = Table.make_table ();
   state = ref (make_state keywords);
   modular;
   library;
-  extrcompute;
   keywords;
   phase = Impl;
   visibility = [];
@@ -275,8 +273,6 @@ let get_modular s = s.modular
 
 let get_library s = s.library
 
-let get_extrcompute s = s.extrcompute
-
 let get_keywords s = s.keywords
 
 let get_phase s = s.phase
@@ -471,12 +467,16 @@ let ref_renaming_fun table (k,r) =
   let l = if lang () != Ocaml && not (State.get_modular table) then [""] else l in
   let s =
     let idg = safe_basename_of_global (State.get_table table) r in
+    let app_suf s = match InfvInst.encode r.inst with
+    | None -> s
+    | Some suf -> s ^ "__" ^ suf
+    in
     match l with
     | [""] -> (* this happens only at toplevel of the monolithic case *)
       let globs = State.get_global_ids table in
       let id = next_ident_away (kindcase_id k idg) globs in
-      Id.to_string id
-    | _ -> modular_rename table k idg
+      app_suf (Id.to_string id)
+    | _ -> app_suf (modular_rename table k idg)
   in
   let () = State.add_global_ids table (Id.of_string s) in
   s::l
@@ -705,7 +705,9 @@ let is_ascii_registered () =
   Rocqlib.has_ref ascii_type_name
   && Rocqlib.has_ref ascii_constructor_name
 
-let ascii_type_ref () = Rocqlib.lib_ref ascii_type_name
+let ascii_type_ref () =
+  (* FIXME: support sort poly? *)
+  { glob = Rocqlib.lib_ref ascii_type_name; inst = InfvInst.empty }
 
 let check_extract_ascii () =
   try
@@ -717,21 +719,27 @@ let check_extract_ascii () =
     String.equal (find_custom @@ ascii_type_ref ()) (char_type)
   with Not_found -> false
 
+let is_constructor r = match r.glob with GlobRef.ConstructRef _ -> true | _ -> false
+
 let is_list_cons l =
- List.for_all (function MLcons (_,GlobRef.ConstructRef(_,_),[]) -> true | _ -> false) l
+ List.for_all (function MLcons (_, r, []) -> is_constructor r | _ -> false) l
 
 let is_native_char = function
   | MLcons(_,gr,l) ->
     is_ascii_registered ()
-    && Rocqlib.check_ref ascii_constructor_name gr
+    && Rocqlib.check_ref ascii_constructor_name gr.glob
     && check_extract_ascii ()
     && is_list_cons l
   | _ -> false
 
+let get_constructor r = match r.glob with
+| GlobRef.ConstructRef(_, j) -> j
+| _ -> assert false
+
 let get_native_char c =
   let rec cumul = function
     | [] -> 0
-    | MLcons(_,GlobRef.ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l)
+    | MLcons(_, r, [])::l -> (2 - get_constructor r) + 2 * (cumul l)
     | _ -> assert false
   in
   let l = match c with MLcons(_,_,l) -> l | _ -> assert false in
@@ -752,7 +760,9 @@ let is_string_registered () =
   && Rocqlib.has_ref empty_string_name
   && Rocqlib.has_ref string_constructor_name
 
-let string_type_ref () = Rocqlib.lib_ref string_type_name
+let string_type_ref () =
+  (* FIXME: support sort poly? *)
+  { glob = Rocqlib.lib_ref string_type_name; inst = InfvInst.empty }
 
 let check_extract_string () =
   try
@@ -770,10 +780,10 @@ let check_extract_string () =
 
 let rec is_native_string_rec empty_string_ref string_constructor_ref = function
   (* "EmptyString" constructor *)
-  | MLcons(_, gr, []) -> Rocqlib.check_ref empty_string_ref gr
+  | MLcons(_, gr, []) -> Rocqlib.check_ref empty_string_ref gr.glob
   (* "String" constructor *)
   | MLcons(_, gr, [hd; tl]) ->
-      Rocqlib.check_ref string_constructor_ref gr
+      Rocqlib.check_ref string_constructor_ref gr.glob
       && is_native_char hd
       && is_native_string_rec empty_string_ref string_constructor_ref tl
   (* others *)
@@ -784,11 +794,15 @@ let rec is_native_string_rec empty_string_ref string_constructor_ref = function
    requested.  Then we check every character via
    [is_native_string_rec]. *)
 
+let is_string_constructor = function
+| GlobRef.ConstructRef (ind, _) -> Rocqlib.check_ref string_type_name (GlobRef.IndRef ind)
+| _ -> false
+
 let is_native_string c =
   match c with
-  | MLcons(_, GlobRef.ConstructRef(ind, j), l) ->
+  | MLcons(_, gr, l) ->
       is_string_registered ()
-      && Rocqlib.check_ref string_type_name (GlobRef.IndRef ind)
+      && is_string_constructor gr.glob
       && check_extract_string ()
       && is_native_string_rec empty_string_name string_constructor_name c
   | _ -> false
@@ -799,10 +813,10 @@ let get_native_string c =
   let buf = Buffer.create 64 in
   let rec get = function
     (* "EmptyString" constructor *)
-    | MLcons(_, gr, []) when Rocqlib.check_ref empty_string_name gr ->
+    | MLcons(_, gr, []) when Rocqlib.check_ref empty_string_name gr.glob ->
         Buffer.contents buf
     (* "String" constructor *)
-    | MLcons(_, gr, [hd; tl]) when Rocqlib.check_ref string_constructor_name gr ->
+    | MLcons(_, gr, [hd; tl]) when Rocqlib.check_ref string_constructor_name gr.glob ->
         Buffer.add_char buf (get_native_char hd);
         get tl
     (* others *)
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
index 68afa6a0df4d..0bd918ee6191 100644
--- a/plugins/extraction/common.mli
+++ b/plugins/extraction/common.mli
@@ -42,14 +42,13 @@ type phase = Pre | Impl | Intf
 module State :
 sig
   type t
-  val make : modular:bool -> library:bool -> extrcompute:bool -> keywords:Id.Set.t -> unit -> t
+  val make : modular:bool -> library:bool -> keywords:Id.Set.t -> unit -> t
 
   (** Getters *)
 
   val get_table : t -> Table.t
   val get_modular : t -> bool
   val get_library : t -> bool
-  val get_extrcompute : t -> bool
   val get_keywords : t -> Id.Set.t
   val get_phase : t -> phase
   val get_duplicate : t -> ModPath.t -> Label.t -> string option
@@ -83,9 +82,9 @@ val opened_libraries : State.t -> ModPath.t list
 
 type kind = Term | Type | Cons | Mod
 
-val pp_global_with_key : State.t -> kind -> KerName.t -> GlobRef.t -> string
-val pp_global : State.t -> kind -> GlobRef.t -> string
-val pp_global_name : State.t -> kind -> GlobRef.t -> string
+val pp_global_with_key : State.t -> kind -> KerName.t -> global -> string
+val pp_global : State.t -> kind -> global -> string
+val pp_global_name : State.t -> kind -> global -> string
 val pp_module : State.t -> ModPath.t -> string
 
 (* val clear_mpfiles_content : unit -> unit *)
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index abf18a195ab6..5c739927433e 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -59,20 +59,29 @@ module type VISIT = sig
 
   (* Add reference / ... in the visit lists.
      These functions silently add the mp of their arg in the mp list *)
-  val add_ref : t -> GlobRef.t -> unit
-  val add_kn : t -> KerName.t -> unit
+  val add_ref : t -> global -> unit
+  val add_kn : t -> KerName.t -> InfvInst.t -> unit
   val add_decl_deps : t -> ml_decl -> unit
   val add_spec_deps : t -> ml_spec -> unit
 
   (* Test functions:
      is a particular object a needed dependency for the current extraction ? *)
-  val needed_ind : t -> MutInd.t -> bool
-  val needed_cst : t -> Constant.t -> bool
+  val needed_ind : t -> MutInd.t -> InfvInst.t -> bool
+  val needed_cst : t -> Constant.t -> InfvInst.t -> bool
   val needed_mp : t -> ModPath.t -> bool
   val needed_mp_all : t -> ModPath.t -> bool
 end
 
 module Visit : VISIT = struct
+  module KNOrd =
+  struct
+    type t = KerName.t * InfvInst.t
+    let compare (kn1, i1) (kn2, i2) =
+      let c = KerName.compare kn1 kn2 in
+      if Int.equal c 0 then InfvInst.compare i1 i2 else c
+  end
+  module KNset = Set.Make(KNOrd)
+
   type t =
       { mutable kn : KNset.t;
         mutable mp : MPset.t;
@@ -84,8 +93,8 @@ module Visit : VISIT = struct
     mp_all = MPset.empty;
   }
   (* the accessor functions *)
-  let needed_ind v i = KNset.mem (MutInd.user i) v.kn
-  let needed_cst v c = KNset.mem (Constant.user c) v.kn
+  let needed_ind v i inst = KNset.mem (MutInd.user i, inst) v.kn
+  let needed_cst v c inst = KNset.mem (Constant.user c, inst) v.kn
   let needed_mp v mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all
   let needed_mp_all v mp = MPset.mem mp v.mp_all
   let add_mp v mp =
@@ -94,10 +103,10 @@ module Visit : VISIT = struct
     check_loaded_modfile mp;
     v.mp <- MPset.union (prefixes_mp mp) v.mp;
     v.mp_all <- MPset.add mp v.mp_all
-  let add_kn v kn = v.kn <- KNset.add kn v.kn; add_mp v (KerName.modpath kn)
-  let add_ref v = let open GlobRef in function
-    | ConstRef c -> add_kn v (Constant.user c)
-    | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn v (MutInd.user ind)
+  let add_kn v kn inst = v.kn <- KNset.add (kn, inst) v.kn; add_mp v (KerName.modpath kn)
+  let add_ref v r = let open GlobRef in match r.glob with
+    | ConstRef c -> add_kn v (Constant.user c) r.inst
+    | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn v (MutInd.user ind) r.inst
     | VarRef _ -> assert false
   let add_decl_deps v decl =
     decl_iter_references (fun kn -> add_ref v kn) (fun r -> add_ref v r) (fun r -> add_ref v r) decl
@@ -105,8 +114,20 @@ module Visit : VISIT = struct
     spec_iter_references (fun r -> add_ref v r) (fun r -> add_ref v r) (fun r -> add_ref v r) spec
 end
 
+let get_mono_inst_univs = function
+| Monomorphic -> [InfvInst.empty]
+| Polymorphic uctx -> InfvInst.generate uctx
+
+let get_mono_inst = function
+| SFBconst cb -> get_mono_inst_univs cb.const_universes
+| SFBmind mib -> get_mono_inst_univs mib.mind_universes
+| SFBrules _ -> [InfvInst.empty]
+| SFBmodule _ | SFBmodtype _ -> assert false
+
 let add_field_label venv mp = function
-  | (lab, (SFBconst _|SFBmind _ | SFBrules _)) -> Visit.add_kn venv (KerName.make mp lab)
+  | (lab, (SFBconst _|SFBmind _ | SFBrules _  as f)) ->
+    let insts = get_mono_inst f in
+    List.iter (fun inst -> Visit.add_kn venv (KerName.make mp lab) inst) insts
   | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all venv (MPdot (mp,lab))
 
 let rec add_labels venv mp = function
@@ -209,18 +230,32 @@ let make_mind resolver mp l =
 
 let rec extract_structure_spec table venv env mp reso = function
   | [] -> []
-  | (l,SFBconst cb) :: msig ->
-      let c = make_cst reso mp l in
-      let s = extract_constant_spec table env c cb in
-      let specs = extract_structure_spec table venv env mp reso msig in
+  | (l, SFBconst cb) :: msig ->
+    let insts = get_mono_inst_univs cb.const_universes in
+    let c = make_cst reso mp l in
+    let map inst = extract_constant_spec table env c inst cb in
+    let consts = List.map map insts in
+    let specs = extract_structure_spec table venv env mp reso msig in
+    let fold s specs =
       if logical_spec s then specs
-      else begin Visit.add_spec_deps venv s; (l,Spec s) :: specs end
-  | (l,SFBmind _) :: msig ->
-      let mind = make_mind reso mp l in
-      let s = Sind (extract_inductive table env mind) in
-      let specs = extract_structure_spec table venv env mp reso msig in
+      else
+        let () = Visit.add_spec_deps venv s in
+        (l, Spec s) :: specs
+    in
+    List.fold_right fold consts specs
+  | (l, SFBmind mib) :: msig ->
+    let insts = get_mono_inst_univs mib.mind_universes in
+    let mind = make_mind reso mp l in
+    let map inst = Sind (extract_inductive table env mind inst) in
+    let minds = List.map map insts in
+    let specs = extract_structure_spec table venv env mp reso msig in
+    let fold s specs =
       if logical_spec s then specs
-      else begin Visit.add_spec_deps venv s; (l,Spec s) :: specs end
+      else
+        let () = Visit.add_spec_deps venv s in
+        (l, Spec s) :: specs
+    in
+    List.fold_right fold minds specs
   | (l, SFBrules _) :: msig ->
       let specs = extract_structure_spec table venv env mp reso msig in
       specs
@@ -246,6 +281,13 @@ and extract_mexpr_spec table venv env mp1 (me_struct_o,me_alg) = match me_alg wi
     let () = Visit.add_mp_all venv mp in
     MTident mp
   | MEwith(me',WithDef(idl,(c,ctx)))->
+      let () = match ctx with
+      | None -> ()
+      | Some auctx ->
+        (* XXX *)
+        if Array.is_empty (UVars.AbstractContext.names auctx).quals then ()
+        else user_err Pp.(str "Extraction of \"with Definition\" clauses not supported for sort polymorphic definitions.")
+      in
       let me_struct,delta = flatten_modtype env mp1 me' me_struct_o in
       let env' = env_for_mtb_with_def env mp1 me_struct delta idl in
       let mt = extract_mexpr_spec table venv env mp1 (None,me') in
@@ -255,7 +297,7 @@ and extract_mexpr_spec table venv env mp1 (me_struct_o,me_alg) = match me_alg wi
          | None -> mt
          | Some (vl,typ) ->
             let () = type_iter_references (fun r -> Visit.add_ref venv r) typ in
-            MTwith(mt,ML_With_type(idl,vl,typ)))
+            MTwith (mt, ML_With_type (InfvInst.empty, idl, vl, typ)))
   | MEwith(me',WithMod(idl,mp))->
       let () = Visit.add_mp_all venv mp in
       MTwith (extract_mexpr_spec table venv env mp1 (None, me'), ML_With_module(idl, mp))
@@ -300,47 +342,60 @@ and extract_mbody_spec : 'a. State.t -> _ -> _ -> _ -> 'a generic_module_body ->
 
 let rec extract_structure table access venv env mp reso ~all = function
   | [] -> []
-  | (l,SFBconst cb) :: struc ->
-      (try
-         let sg = Evd.from_env env in
-         let vl,recd,struc = factor_fix env sg l cb struc in
-         let vc = Array.map (make_cst reso mp) vl in
-         let ms = extract_structure table access venv env mp reso ~all struc in
-         let b = Array.exists (Visit.needed_cst venv) vc in
-         if all || b then
-           let d = extract_fixpoint table env sg vc recd in
-           if (not b) && (logical_decl d) then ms
-           else
-            let () = Visit.add_decl_deps venv d in
-            (l, SEdecl d) :: ms
-         else ms
-       with Impossible ->
-         let ms = extract_structure table access venv env mp reso ~all struc in
-         let c = make_cst reso mp l in
-         let b = Visit.needed_cst venv c in
-         if all || b then
-           let d = extract_constant table access env c cb in
-           if (not b) && (logical_decl d) then ms
-           else
-            let () = Visit.add_decl_deps venv d in
-            (l, SEdecl d) :: ms
-         else ms)
-  | (l,SFBmind mib) :: struc ->
-      let ms = extract_structure table access venv env mp reso ~all struc in
-      let mind = make_mind reso mp l in
-      let b = Visit.needed_ind venv mind in
+  | (l, SFBconst cb) :: struc ->
+    let sg = Evd.from_env env in
+    let fix, struc = match factor_fix env sg l cb struc with
+    | (vl, recd, struc) -> Some (vl, recd), struc
+    | exception Impossible -> None, struc
+    in
+    let ms = extract_structure table access venv env mp reso ~all struc in
+    let insts = get_mono_inst_univs cb.const_universes in
+    let c = make_cst reso mp l in
+    let map inst = match fix with
+    | None ->
+      let b = Visit.needed_cst venv c inst in
       if all || b then
-        let d = Dind (extract_inductive table env mind) in
-        if (not b) && (logical_decl d) then ms
+        let d = extract_constant table access env c inst cb in
+        if (not b) && (logical_decl d) then None
+        else
+        let () = Visit.add_decl_deps venv d in
+        Some (l, SEdecl d)
+      else None
+    | Some (vl, recd) ->
+      let vc = Array.map (make_cst reso mp) vl in
+      let b = Array.exists (fun vf -> Visit.needed_cst venv vf inst) vc in
+      if all || b then
+        let d = extract_fixpoint table env sg vc inst recd in
+        if (not b) && (logical_decl d) then None
         else
           let () = Visit.add_decl_deps venv d in
-          (l, SEdecl d) :: ms
-      else ms
+          Some (l, SEdecl d)
+      else None
+    in
+    let consts = List.map_filter map insts in
+    consts @ ms
+  | (l, SFBmind mib) :: struc ->
+    let ms = extract_structure table access venv env mp reso ~all struc in
+    let insts = get_mono_inst_univs mib.mind_universes in
+    let mind = make_mind reso mp l in
+    let map inst =
+      let b = Visit.needed_ind venv mind inst in
+      if all || b then
+        let d = Dind (extract_inductive table env mind inst) in
+        if (not b) && (logical_decl d) then None
+        else
+          let () = Visit.add_decl_deps venv d in
+          Some (l, SEdecl d)
+      else None
+    in
+    let inds = List.map_filter map insts in
+    inds @ ms
   | (l, SFBrules rrb) :: struc ->
-      let b = List.exists (fun (cst, _) -> Visit.needed_cst venv cst) rrb.rewrules_rules in
+      let inst = InfvInst.empty in (* FIXME ? *)
+      let b = List.exists (fun (cst, _) -> Visit.needed_cst venv cst inst) rrb.rewrules_rules in
       let ms = extract_structure table access venv env mp reso ~all struc in
       if all || b then begin
-        List.iter (fun (cst, _) -> Table.add_symbol_rule (State.get_table table) (ConstRef cst) l) rrb.rewrules_rules;
+        List.iter (fun (cst, _) -> Table.add_symbol_rule (State.get_table table) { glob = ConstRef cst; inst } l) rrb.rewrules_rules;
         ms
       end else ms
   | (l,SFBmodule mb) :: struc ->
@@ -361,7 +416,7 @@ let rec extract_structure table access venv env mp reso ~all = function
 
 and extract_mexpr table access venv env mp = function
   | MEwith _ -> assert false (* no 'with' syntax for modules *)
-  | me when lang () != Ocaml || State.get_extrcompute table ->
+  | me when lang () != Ocaml ->
       (* In Haskell/Scheme, we expand everything.
          For now, we also extract everything, dead code will be removed later
          (see [Modutil.optimize_struct]. *)
@@ -598,10 +653,10 @@ let print_structure_to_file table (fn,si,mo) dry struc =
 (*s Part III: the actual extraction commands *)
 (*********************************************)
 
-let init ?(compute=false) ?(inner=false) modular library =
+let init ?(inner=false) modular library =
   if not inner then check_inside_section ();
   let keywords = (descr ()).keywords in
-  let state = State.make ~modular ~library ~extrcompute:compute ~keywords () in
+  let state = State.make ~modular ~library ~keywords () in
   if modular && lang () == Scheme then error_scheme ();
   state
 
@@ -618,16 +673,20 @@ let rec locate_ref = function
   | qid::l ->
       let mpo = try Some (Nametab.locate_module qid) with Not_found -> None
       and ro =
-        try Some (Smartlocate.global_with_alias qid)
+        try
+          let gr = Smartlocate.global_with_alias qid in
+          let inst = Environ.universes_of_global (Global.env ()) gr in
+          Some (List.map (fun inst -> { glob = gr; inst }) (InfvInst.generate inst))
         with Nametab.GlobalizationError _ | UserError _ -> None
       in
       match mpo, ro with
         | None, None -> Nametab.error_global_not_found ~info:Exninfo.null qid
-        | None, Some r -> let refs,mps = locate_ref l in r::refs,mps
+        | None, Some r ->
+          let refs, mps = locate_ref l in r @ refs,mps
         | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps
         | Some mp, Some r ->
-           warning_ambiguous_name ?loc:qid.CAst.loc (qid,mp,r);
-           let refs,mps = locate_ref l in refs,mp::mps
+          let () = warning_ambiguous_name ?loc:qid.CAst.loc (qid, mp, (List.hd r).glob) in
+          let refs,mps = locate_ref l in refs,mp::mps
 
 (*s Recursive extraction in the Rocq toplevel. The vernacular command is
     \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when
@@ -718,31 +777,6 @@ let extraction_library ~opaque_access is_rec CAst.{loc;v=m} =
   let () = List.iter print struc in
   ()
 
-(** For extraction compute, we flatten all the module structure,
-    getting rid of module types or unapplied functors *)
-
-let flatten_structure struc =
-  let rec flatten_elem (lab,elem) = match elem with
-    |SEdecl d -> [d]
-    |SEmodtype _ -> []
-    |SEmodule m -> match m.ml_mod_expr with
-      |MEfunctor _ -> []
-      |MEident _ | MEapply _ -> assert false (* should be expanded *)
-      |MEstruct (_,elems) -> flatten_elems elems
-  and flatten_elems l = List.flatten (List.map flatten_elem l)
-  in flatten_elems (List.flatten (List.map snd struc))
-
-let structure_for_compute ~opaque_access env sg c =
-  let table = init false false ~compute:true in
-  let ast, mlt = Extraction.extract_constr table env sg c in
-  let ast = Mlutil.normalize ast in
-  let refs = ref GlobRef.Set.empty in
-  let add_ref r = refs := GlobRef.Set.add r !refs in
-  let () = ast_iter_references add_ref add_ref add_ref ast in
-  let refs = GlobRef.Set.elements !refs in
-  let struc = optimize_struct table (refs,[]) (mono_environment table ~opaque_access refs []) in
-  table, (flatten_structure struc), ast, mlt
-
 (* For the test-suite :
    extraction to a temporary file + run ocamlc on it *)
 
@@ -787,10 +821,11 @@ let show_extraction ~pstate =
   let sigma, env = Declare.Proof.get_current_context pstate in
   let trms = Proof.partial_proof prf in
   let extr_term t =
+    (* FIXME: substitute relevances with ground ones *)
     let ast, ty = extract_constr table env sigma t in
     let mp = Lib.current_mp () in
     let l = Label.of_id (Declare.Proof.get_name pstate) in
-    let fake_ref = GlobRef.ConstRef (Constant.make2 mp l) in
+    let fake_ref = { glob = GlobRef.ConstRef (Constant.make2 mp l); inst = InfvInst.empty } in
     let decl = Dterm (fake_ref, ast, ty) in
     print_one_decl table [] mp decl
   in
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 43ac4975a0e8..128a755eb2a7 100644
--- a/plugins/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.mli
@@ -25,19 +25,13 @@ val extract_and_compile : opaque_access:Global.indirect_accessor -> qualid list
 (* For debug / external output via coqtop.byte + Drop : *)
 
 val mono_environment :
- Common.State.t -> opaque_access:Global.indirect_accessor -> GlobRef.t list -> ModPath.t list -> Miniml.ml_structure
+ Common.State.t -> opaque_access:Global.indirect_accessor -> Miniml.global list -> ModPath.t list -> Miniml.ml_structure
 
 (* Used by the Relation Extraction plugin *)
 
 val print_one_decl :
   Common.State.t -> Miniml.ml_structure -> ModPath.t -> Miniml.ml_decl -> Pp.t
 
-(* Used by Extraction Compute *)
-
-val structure_for_compute :
-  opaque_access:Global.indirect_accessor -> Environ.env -> Evd.evar_map -> EConstr.t ->
-    Common.State.t * Miniml.ml_decl list * Miniml.ml_ast * Miniml.ml_type
-
 (* Show the extraction of the current ongoing proof *)
 
 val show_extraction : pstate:Declare.Proof.t -> unit
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 5d0a0f961530..228a639ca36e 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -107,7 +107,12 @@ let push_rel_assum (n, t) env =
 let push_rels_assum assums =
   EConstr.push_rel_context (List.map (fun (x,t) -> LocalAssum (x,t)) assums)
 
-let get_body lconstr = EConstr.of_constr lconstr
+let qmono uctx inst lconstr = match uctx with
+| Monomorphic -> EConstr.of_constr lconstr
+| Polymorphic uctx ->
+  let inst = InfvInst.instantiate uctx inst in
+  let lconstr = Vars.subst_instance_constr inst lconstr in
+  EConstr.of_constr lconstr
 
 let get_opaque access env c =
   EConstr.of_constr
@@ -244,18 +249,6 @@ let parse_ind_args si args relmax =
          | _ -> parse (i+1) (j+1) s)
   in parse 1 1 si
 
-let check_sort_poly sigma gr u =
-  let u = EConstr.EInstance.kind sigma u in
-  let qs, _ = UVars.Instance.to_array u in
-  if Array.exists (function
-      | Sorts.Quality.QConstant (QSProp|QProp) -> true
-      | QConstant QType | QVar _ -> false)
-      qs
-  then CErrors.user_err
-      Pp.(str "Cannot extract nontrivial sort polymorphism" ++ spc()
-          ++ str "(instantiation of " ++ Nametab.pr_global_env Id.Set.empty gr
-          ++ spc() ++ str "using Prop or SProp).")
-
 let relevance_of_projection_repr mib p =
   let _mind,i = Names.Projection.Repr.inductive p in
   match mib.mind_record with
@@ -378,8 +371,8 @@ let rec extract_type (table : Common.State.t) env sg db j c args =
                else let n' = List.nth db (n-1) in
                if Int.equal n' 0 then Tunknown else Tvar n')
     | Const (kn,u) ->
-        let r = GlobRef.ConstRef kn in
-        let () = check_sort_poly sg r u in
+        let inst = InfvInst.ground (EConstr.EInstance.kind sg u) in
+        let r = { glob = GlobRef.ConstRef kn; inst } in
         let typ = type_of env sg (EConstr.mkConstU (kn,u)) in
         (match flag_of_type env sg typ with
            | (Logic,_) -> assert false (* Cf. logical cases above *)
@@ -388,16 +381,18 @@ let rec extract_type (table : Common.State.t) env sg db j c args =
              mlt
            | (Info, Default) ->
                (* Not an ML type, for example [(c:forall X, X->X) Type nat] *)
-               (match (lookup_constant kn env).const_body with
+               let cb = lookup_constant kn env in
+               (match cb.const_body with
                  | Undef _  | OpaqueDef _ | Primitive _ | Symbol _ -> Tunknown (* Brutal approx ... *)
                   | Def lbody ->
                       (* We try to reduce. *)
-                      let newc = applistc (get_body lbody) args in
+                      let newc = applistc (qmono cb.const_universes inst lbody) args in
                       extract_type table env sg db j newc []))
-    | Ind ((kn,i) as ind,u) ->
-        let () = check_sort_poly sg (IndRef ind) u in
-        let s = (extract_ind table env kn).ind_packets.(i).ip_sign in
-        extract_type_app table env sg db (GlobRef.IndRef (kn,i),s) args
+    | Ind ((kn, i), u) ->
+        let inst = InfvInst.ground (EConstr.EInstance.kind sg u) in
+        let r = { glob = GlobRef.IndRef (kn, i); inst } in
+        let s = (extract_ind table env kn inst).ind_packets.(i).ip_sign in
+        extract_type_app table env sg db (r, s) args
     | Proj (p,r,t) ->
        (* Let's try to reduce, if it hasn't already been done. *)
        if Projection.unfolded p then Tunknown
@@ -412,7 +407,7 @@ let rec extract_type (table : Common.State.t) env sg db j c args =
         | LocalDef (_,body,_) ->
            extract_type table env sg db j (EConstr.applist (body,args)) []
         | LocalAssum (_,ty) ->
-           let r = GlobRef.VarRef v in
+           let r = { glob = GlobRef.VarRef v; inst = InfvInst.empty } in
            (match flag_of_type env sg ty with
             | (Logic,_) -> assert false (* Cf. logical cases above *)
             | (Info, TypeScheme) ->
@@ -462,19 +457,19 @@ and extract_type_scheme table env sg db c p =
 
 (* First, a version with cache *)
 
-and extract_ind table env kn = (* kn is supposed to be in long form *)
+and extract_ind table env kn inst = (* kn is supposed to be in long form *)
   let mib = Environ.lookup_mind kn env in
-  match lookup_ind (Common.State.get_table table) kn mib with
+  match lookup_ind (Common.State.get_table table) kn inst mib with
   | Some ml_ind -> ml_ind
   | None ->
      try
-       extract_really_ind table env kn mib
+       extract_really_ind table env kn inst mib
      with SingletonInductiveBecomesProp ind ->
        error_singleton_become_prop ind
 
 (* Then the real function *)
 
-and extract_really_ind table env kn mib =
+and extract_really_ind table env kn inst mib =
     (* First, if this inductive is aliased via a Module,
        we process the original inductive if possible.
        When at toplevel of the monolithic case, we cannot do much
@@ -487,23 +482,28 @@ and extract_really_ind table env kn mib =
         NoEquiv
       else
         begin
-          ignore (extract_ind table env (MutInd.make1 (MutInd.canonical kn)));
+          ignore (extract_ind table env (MutInd.make1 (MutInd.canonical kn)) inst);
           Equiv (MutInd.canonical kn)
         end
     in
+    let env, u = match mib.mind_universes with
+    | Monomorphic -> env, UVars.Instance.empty
+    | Polymorphic uctx ->
+      (* FIXME: we should probably push the levels *)
+      env, InfvInst.instantiate uctx inst
+    in
     (* Everything concerning parameters. *)
     (* We do that first, since they are common to all the [mib]. *)
     let mip0 = mib.mind_packets.(0) in
     let ndecls = List.length mib.mind_params_ctxt in
     let npar = mib.mind_nparams in
-    let epar = push_rel_context mib.mind_params_ctxt env in
+    let epar = push_rel_context (Vars.subst_instance_context u mib.mind_params_ctxt) env in
     let sg = Evd.from_env env in
     (* First pass: we store inductive signatures together with *)
     (* their type var list. *)
     let packets =
       Array.mapi
         (fun i mip ->
-           let (_,u),_ = UnivGen.fresh_inductive_instance env (kn,i) in
            let ar = Inductive.type_of_inductive ((mib,mip),u) in
            let ar = EConstr.of_constr ar in
            let info = (fst (flag_of_type env sg ar) = Info) in
@@ -511,9 +511,9 @@ and extract_really_ind table env kn mib =
            let ncons = Array.length mip.mind_nf_lc in
            let t = Array.make ncons [] in
            { ip_typename = mip.mind_typename;
-             ip_typename_ref = GlobRef.IndRef (kn, i);
+             ip_typename_ref = { glob = GlobRef.IndRef (kn, i); inst };
              ip_consnames = mip.mind_consnames;
-             ip_consnames_ref = Array.init ncons (fun j -> GlobRef.ConstructRef ((kn, i), j + 1));
+             ip_consnames_ref = Array.init ncons (fun j -> { glob = GlobRef.ConstructRef ((kn, i), j + 1); inst });
              ip_logical = not info;
              ip_sign = s;
              ip_vars = v;
@@ -521,7 +521,7 @@ and extract_really_ind table env kn mib =
         mib.mind_packets
     in
 
-    add_ind (Common.State.get_table table) kn mib
+    add_ind (Common.State.get_table table) kn inst mib
       {ind_kind = Standard;
        ind_nparams = npar;
        ind_packets = Array.map fst packets;
@@ -550,7 +550,7 @@ and extract_really_ind table env kn mib =
     let ind_info =
       try
         let ip = (kn, 0) in
-        let r = GlobRef.IndRef ip in
+        let r = { glob = GlobRef.IndRef ip; inst } in
         if is_custom r then raise (I Standard);
         if mib.mind_finite == CoFinite then raise (I Coinductive);
         if not (Int.equal mib.mind_ntypes 1) then raise (I Standard);
@@ -576,7 +576,7 @@ and extract_really_ind table env kn mib =
           List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
         assert (Int.equal (List.length field_names) (List.length typ));
         let mp = MutInd.modpath kn in
-        let implicits = implicits_of_global (GlobRef.ConstructRef (ip,1)) in
+        let implicits = implicits_of_global { glob = (GlobRef.ConstructRef (ip,1)); inst } in
         let ty = Inductive.type_of_inductive ((mib,mip0),u) in
         let nparams = nb_default_params env sg (EConstr.of_constr ty) in
         let rec select_fields i l typs = match l,typs with
@@ -590,7 +590,7 @@ and extract_really_ind table env kn mib =
               (* Is it safe to use [id] for projections [foo.id] ? *)
               if List.for_all ((==) Keep) (type2signature table env typ)
               then (* for OCaml inlining: *) add_projection (Common.State.get_table table) nparams knp ip;
-              Some (GlobRef.ConstRef knp) :: (select_fields (i+1) l typs)
+              Some { glob = GlobRef.ConstRef knp; inst } :: (select_fields (i+1) l typs)
           | _ -> assert false
         in
         let field_glob = select_fields (1+npar) field_names typ in
@@ -604,8 +604,8 @@ and extract_really_ind table env kn mib =
              ind_packets = Array.map fst packets;
              ind_equiv = equiv }
     in
-    add_ind (Common.State.get_table table) kn mib i;
-    add_inductive_kind (Common.State.get_table table) kn i.ind_kind;
+    add_ind (Common.State.get_table table) kn inst mib i;
+    add_inductive_kind (Common.State.get_table table) kn inst i.ind_kind;
     i
 
 (*s [extract_type_cons] extracts the type of an inductive
@@ -627,14 +627,14 @@ and extract_type_cons table env sg db dbmap c i =
 
 (*s Recording the ML type abbreviation of a Rocq type scheme constant. *)
 
-and mlt_env table env r = let open GlobRef in match r with
+and mlt_env table env r = let open GlobRef in match r.glob with
   | IndRef _ | ConstructRef _ | VarRef _ -> None
   | ConstRef kn ->
      let cb = Environ.lookup_constant kn env in
      match cb.const_body with
      | Undef _ | OpaqueDef _ | Primitive _ | Symbol _ -> None
      | Def l_body ->
-        match lookup_typedef (Common.State.get_table table) kn cb with
+        match lookup_typedef (Common.State.get_table table) kn r.inst cb with
         | Some _ as o -> o
         | None ->
            let sg = Evd.from_env env in
@@ -642,11 +642,11 @@ and mlt_env table env r = let open GlobRef in match r with
            (* FIXME not sure if we should instantiate univs here *) in
            match flag_of_type env sg typ with
            | Info,TypeScheme ->
-              let body = get_body l_body in
+              let body = qmono cb.const_universes r.inst l_body in
               let s = type_sign env sg typ in
               let db = db_from_sign s in
               let t = extract_type_scheme table env sg db body (List.length s)
-              in add_typedef (Common.State.get_table table) kn cb t; Some t
+              in add_typedef (Common.State.get_table table) kn r.inst cb t; Some t
            | _ -> None
 
 and expand table env = type_expand (mlt_env table env)
@@ -657,18 +657,18 @@ let type_expunge_from_sign table env = type_expunge_from_sign (mlt_env table env
 
 (*s Extraction of the type of a constant. *)
 
-let record_constant_type table env sg kn opt_typ =
+let record_constant_type table env sg kn inst opt_typ =
   let cb = lookup_constant kn env in
-  match lookup_cst_type (Common.State.get_table table) kn cb with
+  match lookup_cst_type (Common.State.get_table table) kn inst cb with
   | Some schema -> schema
   | None ->
      let typ = match opt_typ with
-       | None -> EConstr.of_constr cb.const_type
+       | None -> qmono cb.const_universes inst cb.const_type
        | Some typ -> typ
      in
      let mlt = extract_type table env sg [] 1 typ [] in
      let schema = (type_maxvar mlt, mlt) in
-     let () = add_cst_type (Common.State.get_table table) kn cb schema in
+     let () = add_cst_type (Common.State.get_table table) kn inst cb schema in
      schema
 
 (*S Extraction of a term. *)
@@ -699,7 +699,7 @@ let rec extract_term table env sg mle mlt c args =
                in
                let b = new_meta () in
                (* If [mlt] cannot be unified with an arrow type, then magic! *)
-               let magic = needs_magic ~compute:(Common.State.get_extrcompute table) (mlt, Tarr (a, b)) in
+               let magic = needs_magic (mlt, Tarr (a, b)) in
                let d' = extract_term table env' sg (Mlenv.push_type mle a) b d [] in
                put_magic_if magic (MLlam (id, d')))
     | LetIn (n, c1, t1, c2) ->
@@ -723,11 +723,9 @@ let rec extract_term table env sg mle mlt c args =
           let mle' = Mlenv.push_std_type mle (Tdummy d) in
           ast_pop (extract_term table env' sg mle' mlt c2 args'))
     | Const (kn,u) ->
-        let () = check_sort_poly sg (ConstRef kn) u in
-        extract_cst_app table env sg mle mlt kn args
+        extract_cst_app table env sg mle mlt (kn, u) args
     | Construct (cp,u) ->
-        let () = check_sort_poly sg (ConstructRef cp) u in
-        extract_cons_app table env sg mle mlt cp args
+        extract_cons_app table env sg mle mlt (cp, u) args
     | Proj (p, _, c) ->
         let p = Projection.repr p in
         let term = fake_match_projection env p in
@@ -738,13 +736,13 @@ let rec extract_term table env sg mle mlt c args =
     | Rel n ->
         (* As soon as the expected [mlt] for the head is known, *)
         (* we unify it with an fresh copy of the stored type of [Rel n]. *)
-        let extract_rel mlt = put_magic ~compute:(Common.State.get_extrcompute table) (mlt, Mlenv.get mle n) (MLrel n)
+        let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
         in extract_app table env sg mle mlt extract_rel args
     | Case (ci, u, pms, r, iv, c0, br) ->
         (* If invert_case then this is a match that will get erased later, but right now we don't care. *)
         let (ip, r, iv, c0, br) = EConstr.expand_case env sg (ci, u, pms, r, iv, c0, br) in
         let ip = ci.ci_ind in
-        extract_app table env sg mle mlt (extract_case table env sg mle (ip,c0,br)) args
+        extract_app table env sg mle mlt (extract_case table env sg mle (ip, u, c0, br)) args
     | Fix ((_,i),recd) ->
         extract_app table env sg mle mlt (extract_fix table env sg mle i recd) args
     | CoFix (i,recd) ->
@@ -759,7 +757,8 @@ let rec extract_term table env sg mle mlt c args =
          | LocalDef (_,_,ty) -> ty
        in
        let vty = extract_type table env sg [] 0 ty [] in
-       let extract_var mlt = put_magic ~compute:(Common.State.get_extrcompute table) (mlt,vty) (MLglob (GlobRef.VarRef v)) in
+       let r = { glob = GlobRef.VarRef v; inst = InfvInst.empty } in
+       let extract_var mlt = put_magic (mlt,vty) (MLglob r) in
        extract_app table env sg mle mlt extract_var args
     | Int i -> assert (args = []); MLuint i
     | Float f -> assert (args = []); MLfloat f
@@ -778,7 +777,7 @@ and extract_maybe_term table env sg mle mlt c =
   try check_default env sg (type_of env sg c);
     extract_term table env sg mle mlt c []
   with NotDefault d ->
-    put_magic ~compute:(Common.State.get_extrcompute table) (mlt, Tdummy d) (MLdummy d)
+    put_magic (mlt, Tdummy d) (MLdummy d)
 
 (*s Generic way to deal with an application. *)
 
@@ -805,14 +804,15 @@ and make_mlargs table env sg e s args typs =
 
 (*s Extraction of a constant applied to arguments. *)
 
-and extract_cst_app table env sg mle mlt kn args =
+and extract_cst_app table env sg mle mlt (kn, u) args =
+  let inst = InfvInst.ground (EConstr.EInstance.kind sg u) in
   (* First, the [ml_schema] of the constant, in expanded version. *)
-  let nb,t = record_constant_type table env sg kn None in
+  let nb, t = record_constant_type table env sg kn inst None in
   let schema = nb, expand table env t in
   (* Can we instantiate types variables for this constant ? *)
   (* In Ocaml, inside the definition of this constant, the answer is no. *)
   let instantiated =
-    if lang () == Ocaml && List.exists (fun c -> QConstant.equal env kn c) !current_fixpoints
+    if lang () == Ocaml && List.exists (fun c -> Constant.UserOrd.equal kn c) !current_fixpoints
     then var2var' (snd schema)
     else instantiation schema
   in
@@ -821,14 +821,15 @@ and extract_cst_app table env sg mle mlt kn args =
   (* We compare stored and expected types in two steps. *)
   (* First, can [kn] be applied to all args ? *)
   let metas = List.map new_meta args in
-  let magic1 = needs_magic ~compute:(Common.State.get_extrcompute table) (type_recomp (metas, a), instantiated) in
+  let magic1 = needs_magic (type_recomp (metas, a), instantiated) in
   (* Second, is the resulting type compatible with the expected type [mlt] ? *)
-  let magic2 = needs_magic ~compute:(Common.State.get_extrcompute table) (a, mlt) in
+  let magic2 = needs_magic (a, mlt) in
   (* The internal head receives a magic if [magic1] *)
-  let head = put_magic_if magic1 (MLglob (GlobRef.ConstRef kn)) in
+  let r = { glob = GlobRef.ConstRef kn; inst } in
+  let head = put_magic_if magic1 (MLglob r) in
   (* Now, the extraction of the arguments. *)
   let s_full = type2signature table env (snd schema) in
-  let s_full = sign_with_implicits (GlobRef.ConstRef kn) s_full 0 in
+  let s_full = sign_with_implicits r s_full 0 in
   let s = sign_no_final_keeps s_full in
   let ls = List.length s in
   let la = List.length args in
@@ -866,19 +867,23 @@ and extract_cst_app table env sg mle mlt kn args =
    they are fixed, and thus are not used for the computation.
    \end{itemize} *)
 
-and extract_cons_app table env sg mle mlt (((kn,i) as ip,j) as cp) args =
+and extract_cons_app table env sg mle mlt (cp, u) args =
+  let ((kn, i) as ip, j) = cp in
   (* First, we build the type of the constructor, stored in small pieces. *)
-  let mi = extract_ind table env kn in
+  let inst = InfvInst.ground (EConstr.EInstance.kind sg u) in
+  let mi = extract_ind table env kn inst in
   let params_nb = mi.ind_nparams in
   let oi = mi.ind_packets.(i) in
   let nb_tvars = List.length oi.ip_vars
   and types = List.map (expand table env) oi.ip_types.(j-1) in
   let list_tvar = List.map (fun i -> Tvar i) (List.interval 1 nb_tvars) in
-  let type_cons = type_recomp (types, Tglob (GlobRef.IndRef ip, list_tvar)) in
+  let gind = { glob = GlobRef.IndRef ip; inst } in
+  let gcstr = { glob = GlobRef.ConstructRef cp; inst } in
+  let type_cons = type_recomp (types, Tglob (gind, list_tvar)) in
   let type_cons = instantiation (nb_tvars, type_cons) in
   (* Then, the usual variables [s], [ls], [la], ... *)
   let s = List.map (type2sign table env) types in
-  let s = sign_with_implicits (GlobRef.ConstructRef cp) s params_nb in
+  let s = sign_with_implicits gcstr s params_nb in
   let ls = List.length s in
   let la = List.length args in
   assert (la <= ls + params_nb);
@@ -888,8 +893,8 @@ and extract_cons_app table env sg mle mlt (((kn,i) as ip,j) as cp) args =
   let metas = List.map new_meta args' in
   (* If stored and expected types differ, then magic! *)
   let a = new_meta () in
-  let magic1 = needs_magic ~compute:(Common.State.get_extrcompute table) (type_cons, type_recomp (metas, a)) in
-  let magic2 = needs_magic ~compute:(Common.State.get_extrcompute table) (a, mlt) in
+  let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
+  let magic2 = needs_magic (a, mlt) in
   let head mla =
     if mi.ind_kind == Singleton then
       put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
@@ -898,8 +903,8 @@ and extract_cons_app table env sg mle mlt (((kn,i) as ip,j) as cp) args =
         | Tglob (_,l) -> List.map type_simpl l
         | _ -> assert false
       in
-      let typ = Tglob(GlobRef.IndRef ip, typeargs) in
-      put_magic_if magic1 (MLcons (typ, GlobRef.ConstructRef cp, mla))
+      let typ = Tglob (gind, typeargs) in
+      put_magic_if magic1 (MLcons (typ, gcstr, mla))
   in
   (* Different situations depending of the number of arguments: *)
   if la < params_nb then
@@ -918,11 +923,13 @@ and extract_cons_app table env sg mle mlt (((kn,i) as ip,j) as cp) args =
 
 (*S Extraction of a case. *)
 
-and extract_case table env sg mle ((kn,i) as ip,c,br) mlt =
+and extract_case table env sg mle ((kn,i) as ip, u, c, br) mlt =
   (* [br]: bodies of each branch (in functional form) *)
   (* [ni]: number of arguments without parameters in each branch *)
   let ni = constructors_nrealargs env ip in
   let br_size = Array.length br in
+  let inst = InfvInst.ground (EConstr.EInstance.kind sg u) in
+  let gind = { glob = GlobRef.IndRef ip; inst } in
   assert (Int.equal (Array.length ni) br_size);
   if Int.equal br_size 0 then begin
     add_recursors (Common.State.get_table table) env kn; (* May have passed unseen if logical ... *)
@@ -943,15 +950,15 @@ and extract_case table env sg mle ((kn,i) as ip,c,br) mlt =
         snd (case_expunge s e)
       end
     else
-      let mi = extract_ind table env kn in
+      let mi = extract_ind table env kn inst in
       let oi = mi.ind_packets.(i) in
       let metas = Array.init (List.length oi.ip_vars) new_meta in
       (* The extraction of the head. *)
-      let type_head = Tglob (GlobRef.IndRef ip, Array.to_list metas) in
+      let type_head = Tglob (gind, Array.to_list metas) in
       let a = extract_term table env sg mle type_head c [] in
       (* The extraction of each branch. *)
       let extract_branch i =
-        let r = GlobRef.ConstructRef (ip,i+1) in
+        let r = { glob = GlobRef.ConstructRef (ip, i + 1); inst } in
         (* The types of the arguments of the corresponding constructor. *)
         let f t = type_subst_vect metas (expand table env t) in
         let l = List.map f oi.ip_types.(i) in
@@ -976,7 +983,7 @@ and extract_case table env sg mle ((kn,i) as ip,c,br) mlt =
       else
         (* Standard case: we apply [extract_branch]. *)
         let typs = List.map type_simpl (Array.to_list metas) in
-        let typ = Tglob (GlobRef.IndRef ip,typs) in
+        let typ = Tglob (gind, typs) in
         MLcase (typ, a, Array.init br_size extract_branch)
 
 (*s Extraction of a (co)-fixpoint. *)
@@ -1017,16 +1024,17 @@ let rec gentypvar_ok sg c = match EConstr.kind sg c with
 
 (*s From a constant to a ML declaration. *)
 
-let extract_std_constant table env sg kn body typ =
+let extract_std_constant table env sg kn inst body typ =
+  (* expects body and typ to be already substituted w.r.t. inst *)
   reset_meta_count ();
   (* The short type [t] (i.e. possibly with abbreviations). *)
-  let t = snd (record_constant_type table env sg kn (Some typ)) in
+  let t = snd (record_constant_type table env sg kn inst (Some typ)) in
   (* The real type [t']: without head products, expanded, *)
   (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
   let l,t' = type_decomp (expand table env (var2var' t)) in
   let s = List.map (type2sign table env) l in
   (* Check for user-declared implicit information *)
-  let s = sign_with_implicits (GlobRef.ConstRef kn) s 0 in
+  let s = sign_with_implicits { glob = GlobRef.ConstRef kn; inst } s 0 in
   (* Decomposing the top level lambdas of [body].
      If there isn't enough, it's ok, as long as remaining args
      aren't to be pruned (and initial lambdas aren't to be all
@@ -1072,19 +1080,19 @@ let extract_std_constant table env sg kn body typ =
   trm, type_expunge_from_sign table env s t
 
 (* Extracts the type of an axiom, honors the Extraction Implicit declaration. *)
-let extract_axiom table env sg kn typ =
+let extract_axiom table env sg kn inst typ =
   reset_meta_count ();
   (* The short type [t] (i.e. possibly with abbreviations). *)
-  let t = snd (record_constant_type table env sg kn (Some typ)) in
+  let t = snd (record_constant_type table env sg kn inst (Some typ)) in
   (* The real type [t']: without head products, expanded, *)
   (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
   let l,_ = type_decomp (expand table env (var2var' t)) in
   let s = List.map (type2sign table env) l in
   (* Check for user-declared implicit information *)
-  let s = sign_with_implicits (GlobRef.ConstRef kn) s 0 in
+  let s = sign_with_implicits { glob = GlobRef.ConstRef kn; inst } s 0 in
   type_expunge_from_sign table env s t
 
-let extract_fixpoint table env sg vkn (fi,ti,ci) =
+let extract_fixpoint table env sg vkn inst (fi,ti,ci) =
   let n = Array.length vkn in
   let types = Array.make n (Tdummy Kprop)
   and terms = Array.make n (MLdummy Kprop) in
@@ -1099,7 +1107,7 @@ let extract_fixpoint table env sg vkn (fi,ti,ci) =
   for i = 0 to n-1 do
     if info_of_quality (sort_of env sg ti.(i)) != Logic then
       try
-        let e,t = extract_std_constant table env sg vkn.(i)
+        let e,t = extract_std_constant table env sg vkn.(i) inst
                    (EConstr.Vars.substl sub ci.(i)) ti.(i) in
         terms.(i) <- e;
         types.(i) <- t;
@@ -1107,12 +1115,12 @@ let extract_fixpoint table env sg vkn (fi,ti,ci) =
         error_singleton_become_prop ind
   done;
   current_fixpoints := [];
-  Dfix (Array.map (fun kn -> GlobRef.ConstRef kn) vkn, terms, types)
+  Dfix (Array.map (fun kn -> { glob = GlobRef.ConstRef kn; inst }) vkn, terms, types)
 
-let extract_constant table access env kn cb =
+let extract_constant table access env kn inst cb =
   let sg = Evd.from_env env in
-  let r = GlobRef.ConstRef kn in
-  let typ = EConstr.of_constr cb.const_type in
+  let r = { glob = GlobRef.ConstRef kn; inst } in
+  let typ = qmono cb.const_universes inst cb.const_type in
   let warn_info () = if not (is_custom r) then add_info_axiom (Common.State.get_table table) r in
   let warn_log () = if not (constant_has_body cb) then add_log_axiom (Common.State.get_table table) r
   in
@@ -1128,11 +1136,11 @@ let extract_constant table access env kn cb =
     in Dtype (r, vl, t)
   in
   let mk_ax () =
-    let t = extract_axiom table env sg kn typ in
+    let t = extract_axiom table env sg kn inst typ in
     Dterm (r, MLaxiom (Constant.to_string kn), t)
   in
   let mk_def c =
-    let e,t = extract_std_constant table env sg kn c typ in
+    let e,t = extract_std_constant table env sg kn inst c typ in
     Dterm (r,e,t)
   in
   try
@@ -1147,10 +1155,11 @@ let extract_constant table access env kn cb =
           | Primitive _ | Undef _ -> warn_info (); mk_typ_ax ()
           | Def c ->
              (match Structures.PrimitiveProjections.find_opt kn with
-              | None -> mk_typ (get_body c)
+              | None -> mk_typ (qmono cb.const_universes inst c)
               | Some p ->
                 let body = fake_match_projection env p in
-                mk_typ (EConstr.of_constr body))
+                let body = qmono cb.const_universes inst body in
+                mk_typ body)
           | OpaqueDef c ->
             add_opaque (Common.State.get_table table) r;
             if access_opaque () then mk_typ (get_opaque access env c)
@@ -1161,10 +1170,10 @@ let extract_constant table access env kn cb =
           | Primitive _ | Undef _ -> warn_info (); mk_ax ()
           | Def c ->
              (match Structures.PrimitiveProjections.find_opt kn with
-              | None -> mk_def (get_body c)
+              | None -> mk_def (qmono cb.const_universes inst c)
               | Some p ->
                 let body = fake_match_projection env p in
-                mk_def (EConstr.of_constr body))
+                mk_def (qmono cb.const_universes inst body))
           | OpaqueDef c ->
             add_opaque (Common.State.get_table table) r;
             if access_opaque () then mk_def (get_opaque access env c)
@@ -1172,10 +1181,10 @@ let extract_constant table access env kn cb =
   with SingletonInductiveBecomesProp ind ->
     error_singleton_become_prop ind
 
-let extract_constant_spec table env kn cb =
+let extract_constant_spec table env kn inst cb =
   let sg = Evd.from_env env in
-  let r = GlobRef.ConstRef kn in
-  let typ = EConstr.of_constr cb.const_type in
+  let r = { glob = GlobRef.ConstRef kn; inst } in
+  let typ = qmono cb.const_universes inst cb.const_type in
   try
     match flag_of_type env sg typ with
     | (Logic, TypeScheme) ->
@@ -1188,11 +1197,11 @@ let extract_constant_spec table env kn cb =
           | Undef _ | OpaqueDef _ | Primitive _ | Symbol _ -> Stype (r, vl, None)
           | Def body ->
               let db = db_from_sign s in
-              let body = get_body body in
+              let body = qmono cb.const_universes inst body in
               let t = extract_type_scheme table env sg db body (List.length s)
               in Stype (r, vl, Some t))
     | (Info, Default) ->
-        let t = snd (record_constant_type table env sg kn (Some typ)) in
+        let t = snd (record_constant_type table env sg kn inst (Some typ)) in
         Sval (r, type_expunge table env t)
   with SingletonInductiveBecomesProp ind ->
     error_singleton_become_prop ind
@@ -1223,11 +1232,12 @@ let extract_constr table env sg c =
   with SingletonInductiveBecomesProp ind ->
     error_singleton_become_prop ind
 
-let extract_inductive table env kn =
-  let ind = extract_ind table env kn in
-  add_recursors (Common.State.get_table table) env kn;
+let extract_inductive table env kn inst =
+  let ind = extract_ind table env kn inst in
+  let () = add_recursors (Common.State.get_table table) env kn in
   let f i j l =
-    let implicits = implicits_of_global (GlobRef.ConstructRef ((kn,i),j+1)) in
+    let r = { glob = GlobRef.ConstructRef ((kn, i), j + 1); inst } in
+    let implicits = implicits_of_global r in
     let rec filter i = function
       | [] -> []
       | t::l ->
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
index ccda21ad10a7..c39bf3dc6686 100644
--- a/plugins/extraction/extraction.mli
+++ b/plugins/extraction/extraction.mli
@@ -16,9 +16,9 @@ open Environ
 open Evd
 open Miniml
 
-val extract_constant : Common.State.t -> Global.indirect_accessor -> env -> Constant.t -> constant_body -> ml_decl
+val extract_constant : Common.State.t -> Global.indirect_accessor -> env -> Constant.t -> InfvInst.t -> constant_body -> ml_decl
 
-val extract_constant_spec : Common.State.t -> env -> Constant.t -> ('a, 'b) pconstant_body -> ml_spec
+val extract_constant_spec : Common.State.t -> env -> Constant.t -> InfvInst.t -> ('a, 'b) pconstant_body -> ml_spec
 
 (** For extracting "module ... with ..." declaration *)
 
@@ -26,9 +26,9 @@ val extract_with_type :
   Common.State.t -> env -> evar_map -> EConstr.t -> ( Id.t list * ml_type ) option
 
 val extract_fixpoint :
-  Common.State.t -> env -> evar_map -> Constant.t array -> EConstr.rec_declaration -> ml_decl
+  Common.State.t -> env -> evar_map -> Constant.t array -> InfvInst.t -> EConstr.rec_declaration -> ml_decl
 
-val extract_inductive : Common.State.t -> env -> MutInd.t -> ml_ind
+val extract_inductive : Common.State.t -> env -> MutInd.t -> InfvInst.t -> ml_ind
 
 (** For Extraction Compute and Show Extraction *)
 
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index 71ad0cafe053..62d3cd3dca6b 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -117,7 +117,7 @@ let rec pp_type table par vl t =
        with Failure _ -> (str "a" ++ int i))
     | Tglob (r,[]) -> pp_global table Type r
     | Tglob (gr,l)
-        when not (keep_singleton ()) && Rocqlib.check_ref sig_type_name gr ->
+        when not (keep_singleton ()) && Rocqlib.check_ref sig_type_name gr.glob ->
           pp_type table true vl (List.hd l)
     | Tglob (r,l) ->
           pp_par par
diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml
index 513960f73c4d..ec25c272f308 100644
--- a/plugins/extraction/miniml.ml
+++ b/plugins/extraction/miniml.ml
@@ -12,6 +12,66 @@
 
 open Names
 
+module InfvInst =
+struct
+  type t = bool array (* true if informative *)
+  let empty = [||]
+  let compare i1 i2 = CArray.compare Bool.compare i1 i2
+  let equal i1 i2 = Int.equal (compare i1 i2) 0
+
+  let generate actx =
+    let names = UVars.AbstractContext.names actx in
+    let quals = Array.length names.UVars.quals in
+    let init n =
+      let ans = Array.make quals true in
+      let n = ref n in
+      for i = 0 to quals - 1 do
+        let b = !n mod 2 = 0 in
+        ans.(i) <- b;
+        n := !n / 2
+      done;
+      ans
+    in
+    List.init (1 lsl quals) init
+
+  let default actx =
+    let names = UVars.AbstractContext.names actx in
+    let quals = Array.length names.UVars.quals in
+    Array.make quals true
+
+  let ground inst =
+    let qvars, _ = UVars.Instance.to_array inst in
+    let map q = match q with
+    | Sorts.Quality.QConstant (QProp | QSProp) -> false
+    | Sorts.Quality.QConstant QType -> true
+    | Sorts.Quality.QVar qv ->
+      match Sorts.QVar.repr qv with
+      | Var _ -> CErrors.anomaly (Pp.str "Non-ground instance")
+      | Unif _ | Global _ -> true (* informative by default *)
+    in
+    Array.map map qvars
+
+  let instantiate actx inst =
+    let u = UVars.make_abstract_instance actx in
+    let fl l = l in
+    let fq q = match Sorts.QVar.var_index q with
+    | None -> assert false
+    | Some i ->
+      if inst.(i) then Sorts.Quality.qtype
+      else Sorts.Quality.qsprop
+    in
+    UVars.Instance.subst_fn (fq, fl) u
+
+  let encode inst =
+    if Array.for_all (fun b -> b) inst then None
+    else
+      let len = Array.length inst in
+      Some (String.init len (fun i -> if inst.(i) then 'X' else 'O'))
+
+end
+
+type global = { glob : GlobRef.t; inst : InfvInst.t }
+
 (* The [signature] type is used to know how many arguments a CIC
    object expects, and what these arguments will become in the ML
    object. *)
@@ -25,11 +85,10 @@ open Names
 type kill_reason =
   | Ktype
   | Kprop
-  | Kimplicit of GlobRef.t * int  (* n-th arg of a cst or construct *)
+  | Kimplicit of global * int  (* n-th arg of a cst or construct *)
 
 type sign = Keep | Kill of kill_reason
 
-
 (* Convention: outmost lambda/product gives the head of the list. *)
 
 type signature = sign list
@@ -38,7 +97,7 @@ type signature = sign list
 
 type ml_type =
   | Tarr    of ml_type * ml_type
-  | Tglob   of GlobRef.t * ml_type list
+  | Tglob   of global * ml_type list
   | Tvar    of int
   | Tvar'   of int (* same as Tvar, used to avoid clash *)
   | Tmeta   of ml_meta (* used during ML type reconstruction *)
@@ -59,7 +118,7 @@ type inductive_kind =
   | Singleton
   | Coinductive
   | Standard
-  | Record of GlobRef.t option list (* None for anonymous field *)
+  | Record of global option list (* None for anonymous field *)
 
 (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body].
    If the inductive is logical ([ip_logical = false]), then all other fields
@@ -71,9 +130,9 @@ type inductive_kind =
 
 type ml_ind_packet = {
   ip_typename : Id.t;
-  ip_typename_ref : GlobRef.t;
+  ip_typename_ref : global;
   ip_consnames : Id.t array;
-  ip_consnames_ref : GlobRef.t array;
+  ip_consnames_ref : global array;
   ip_logical : bool;
   ip_sign : signature;
   ip_vars : Id.t list;
@@ -119,8 +178,8 @@ and ml_ast =
   | MLapp    of ml_ast * ml_ast list
   | MLlam    of ml_ident * ml_ast
   | MLletin  of ml_ident * ml_ast * ml_ast
-  | MLglob   of GlobRef.t
-  | MLcons   of ml_type * GlobRef.t * ml_ast list
+  | MLglob   of global
+  | MLcons   of ml_type * global * ml_ast list
   | MLtuple  of ml_ast list
   | MLcase   of ml_type * ml_ast * ml_branch array
   | MLfix    of int * Id.t array * ml_ast array
@@ -134,24 +193,24 @@ and ml_ast =
   | MLparray of ml_ast array * ml_ast
 
 and ml_pattern =
-  | Pcons   of GlobRef.t * ml_pattern list
+  | Pcons   of global * ml_pattern list
   | Ptuple  of ml_pattern list
   | Prel    of int (** Cf. the idents in the branch. [Prel 1] is the last one. *)
   | Pwild
-  | Pusual  of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **)
+  | Pusual  of global (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **)
 
 (*s ML declarations. *)
 
 type ml_decl =
   | Dind  of ml_ind
-  | Dtype of GlobRef.t * Id.t list * ml_type
-  | Dterm of GlobRef.t * ml_ast * ml_type
-  | Dfix  of GlobRef.t array * ml_ast array * ml_type array
+  | Dtype of global * Id.t list * ml_type
+  | Dterm of global * ml_ast * ml_type
+  | Dfix  of global array * ml_ast array * ml_type array
 
 type ml_spec =
   | Sind  of ml_ind
-  | Stype of GlobRef.t * Id.t list * ml_type option
-  | Sval  of GlobRef.t * ml_type
+  | Stype of global * Id.t list * ml_type option
+  | Sval  of global * ml_type
 
 type ml_specif =
   | Spec of ml_spec
@@ -165,7 +224,7 @@ and ml_module_type =
   | MTwith of ml_module_type * ml_with_declaration
 
 and ml_with_declaration =
-  | ML_With_type of Id.t list * Id.t list * ml_type
+  | ML_With_type of InfvInst.t * Id.t list * Id.t list * ml_type
   | ML_With_module of Id.t list * ModPath.t
 
 and ml_module_sig = (Label.t * ml_specif) list
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
index 513960f73c4d..811c33a6a917 100644
--- a/plugins/extraction/miniml.mli
+++ b/plugins/extraction/miniml.mli
@@ -12,6 +12,36 @@
 
 open Names
 
+(* Informativity data for sort polymorphism *)
+module InfvInst :
+sig
+  type t
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+
+  val empty : t
+  (** No bound sort variables *)
+
+  val generate : UVars.AbstractContext.t -> t list
+  (** 2^n possible instances for this context *)
+
+  val default : UVars.AbstractContext.t -> t
+  (** All sorts informative *)
+
+  val ground : UVars.Instance.t -> t
+  (** From a ground instance returns an informativity instance *)
+
+  val instantiate : UVars.AbstractContext.t -> t -> UVars.Instance.t
+  (** The other way around *)
+
+  val encode : t -> string option
+  (** A string that can be used as an identifier suffix, guaranteed to be
+      injective for instances of the same length. *)
+
+end
+
+type global = { glob : GlobRef.t; inst : InfvInst.t }
+
 (* The [signature] type is used to know how many arguments a CIC
    object expects, and what these arguments will become in the ML
    object. *)
@@ -25,7 +55,7 @@ open Names
 type kill_reason =
   | Ktype
   | Kprop
-  | Kimplicit of GlobRef.t * int  (* n-th arg of a cst or construct *)
+  | Kimplicit of global * int  (* n-th arg of a cst or construct *)
 
 type sign = Keep | Kill of kill_reason
 
@@ -38,7 +68,7 @@ type signature = sign list
 
 type ml_type =
   | Tarr    of ml_type * ml_type
-  | Tglob   of GlobRef.t * ml_type list
+  | Tglob   of global * ml_type list
   | Tvar    of int
   | Tvar'   of int (* same as Tvar, used to avoid clash *)
   | Tmeta   of ml_meta (* used during ML type reconstruction *)
@@ -59,7 +89,7 @@ type inductive_kind =
   | Singleton
   | Coinductive
   | Standard
-  | Record of GlobRef.t option list (* None for anonymous field *)
+  | Record of global option list (* None for anonymous field *)
 
 (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body].
    If the inductive is logical ([ip_logical = false]), then all other fields
@@ -71,9 +101,9 @@ type inductive_kind =
 
 type ml_ind_packet = {
   ip_typename : Id.t;
-  ip_typename_ref : GlobRef.t;
+  ip_typename_ref : global;
   ip_consnames : Id.t array;
-  ip_consnames_ref : GlobRef.t array;
+  ip_consnames_ref : global array;
   ip_logical : bool;
   ip_sign : signature;
   ip_vars : Id.t list;
@@ -119,8 +149,8 @@ and ml_ast =
   | MLapp    of ml_ast * ml_ast list
   | MLlam    of ml_ident * ml_ast
   | MLletin  of ml_ident * ml_ast * ml_ast
-  | MLglob   of GlobRef.t
-  | MLcons   of ml_type * GlobRef.t * ml_ast list
+  | MLglob   of global
+  | MLcons   of ml_type * global * ml_ast list
   | MLtuple  of ml_ast list
   | MLcase   of ml_type * ml_ast * ml_branch array
   | MLfix    of int * Id.t array * ml_ast array
@@ -134,24 +164,24 @@ and ml_ast =
   | MLparray of ml_ast array * ml_ast
 
 and ml_pattern =
-  | Pcons   of GlobRef.t * ml_pattern list
+  | Pcons   of global * ml_pattern list
   | Ptuple  of ml_pattern list
   | Prel    of int (** Cf. the idents in the branch. [Prel 1] is the last one. *)
   | Pwild
-  | Pusual  of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **)
+  | Pusual  of global (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **)
 
 (*s ML declarations. *)
 
 type ml_decl =
   | Dind  of ml_ind
-  | Dtype of GlobRef.t * Id.t list * ml_type
-  | Dterm of GlobRef.t * ml_ast * ml_type
-  | Dfix  of GlobRef.t array * ml_ast array * ml_type array
+  | Dtype of global * Id.t list * ml_type
+  | Dterm of global * ml_ast * ml_type
+  | Dfix  of global array * ml_ast array * ml_type array
 
 type ml_spec =
   | Sind  of ml_ind
-  | Stype of GlobRef.t * Id.t list * ml_type option
-  | Sval  of GlobRef.t * ml_type
+  | Stype of global * Id.t list * ml_type option
+  | Sval  of global * ml_type
 
 type ml_specif =
   | Spec of ml_spec
@@ -165,7 +195,7 @@ and ml_module_type =
   | MTwith of ml_module_type * ml_with_declaration
 
 and ml_with_declaration =
-  | ML_With_type of Id.t list * Id.t list * ml_type
+  | ML_With_type of InfvInst.t * Id.t list * Id.t list * ml_type
   | ML_With_module of Id.t list * ModPath.t
 
 and ml_module_sig = (Label.t * ml_specif) list
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 31178c640157..c880c8dc123f 100644
--- a/plugins/extraction/mlutil.ml
+++ b/plugins/extraction/mlutil.ml
@@ -23,6 +23,8 @@ exception Impossible
 
 (*S Names operations. *)
 
+let eq_global g1 g2 = GlobRef.CanOrd.equal g1.glob g2.glob (* FIXME *)
+
 let anonymous_name = Id.of_string "x"
 let dummy_name = Id.of_string "_"
 
@@ -58,7 +60,7 @@ let rec eq_ml_type t1 t2 = match t1, t2 with
 | Tarr (tl1, tr1), Tarr (tl2, tr2) ->
   eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2
 | Tglob (gr1, t1), Tglob (gr2, t2) ->
-  GlobRef.CanOrd.equal gr1 gr2 && List.equal eq_ml_type t1 t2
+  eq_global gr1 gr2 && List.equal eq_ml_type t1 t2
 | Tvar i1, Tvar i2 -> Int.equal i1 i2
 | Tvar' i1, Tvar' i2 -> Int.equal i1 i2
 | Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2
@@ -120,7 +122,7 @@ let rec mgu = function
       | None -> m.contents <- Some t)
   | Tarr(a, b), Tarr(a', b') ->
       mgu (a, a'); mgu (b, b')
-  | Tglob (r,l), Tglob (r',l') when GlobRef.CanOrd.equal r r' ->
+  | Tglob (r,l), Tglob (r',l') when eq_global r r' ->
        List.iter mgu (List.combine l l')
   | Tdummy _, Tdummy _ -> ()
   | Tvar i, Tvar j when Int.equal i j -> ()
@@ -129,15 +131,15 @@ let rec mgu = function
   | Taxiom, Taxiom -> ()
   | _ -> raise Impossible
 
-let skip_typing ~compute () = lang () == Scheme || compute
+let skip_typing () = lang () == Scheme
 
-let needs_magic ~compute p =
-  if skip_typing ~compute () then false
+let needs_magic p =
+  if skip_typing () then false
   else try mgu p; false with Impossible -> true
 
 let put_magic_if b a = if b then MLmagic a else a
 
-let put_magic ~compute p a = if needs_magic ~compute p then MLmagic a else a
+let put_magic p a = if needs_magic p then MLmagic a else a
 
 let generalizable a =
   lang () != Ocaml ||
@@ -270,7 +272,7 @@ let rec var2var' = function
   | Tglob (r,l) -> Tglob (r, List.map var2var' l)
   | a -> a
 
-type abbrev_map = GlobRef.t -> ml_type option
+type abbrev_map = global -> ml_type option
 
 (*s Delta-reduction of type constants everywhere in a ML type [t].
    [env] is a function of type [ml_type_env]. *)
@@ -384,9 +386,9 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with
   eq_ml_ident na1 na2 && eq_ml_ast t1 t2
 | MLletin (na1, c1, t1), MLletin (na2, c2, t2) ->
   eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2
-| MLglob gr1, MLglob gr2 -> GlobRef.CanOrd.equal gr1 gr2
+| MLglob gr1, MLglob gr2 -> eq_global gr1 gr2
 | MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) ->
-  eq_ml_type t1 t2 && GlobRef.CanOrd.equal gr1 gr2 && List.equal eq_ml_ast c1 c2
+  eq_ml_type t1 t2 && eq_global gr1 gr2 && List.equal eq_ml_ast c1 c2
 | MLtuple t1, MLtuple t2 ->
   List.equal eq_ml_ast t1 t2
 | MLcase (t1, c1, p1), MLcase (t2, c2, p2) ->
@@ -408,13 +410,13 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with
 
 and eq_ml_pattern p1 p2 = match p1, p2 with
 | Pcons (gr1, p1), Pcons (gr2, p2) ->
-  GlobRef.CanOrd.equal gr1 gr2 && List.equal eq_ml_pattern p1 p2
+  eq_global gr1 gr2 && List.equal eq_ml_pattern p1 p2
 | Ptuple p1, Ptuple p2 ->
   List.equal eq_ml_pattern p1 p2
 | Prel i1, Prel i2 ->
   Int.equal i1 i2
 | Pwild, Pwild -> true
-| Pusual gr1, Pusual gr2 -> GlobRef.CanOrd.equal gr1 gr2
+| Pusual gr1, Pusual gr2 -> eq_global gr1 gr2
 | _ -> false
 
 and eq_ml_branch (id1, p1, t1) (id2, p2, t2) =
@@ -689,11 +691,11 @@ let is_regular_match br =
           | _ -> raise Impossible
       in
       let ind = match get_r br.(0) with
-        | GlobRef.ConstructRef (ind,_) -> ind
+        | { glob = GlobRef.ConstructRef (ind,_) } -> ind
         | _ -> raise Impossible
       in
       let is_ref i tr = match get_r tr with
-      | GlobRef.ConstructRef (ind', j) -> Ind.CanOrd.equal ind ind' && Int.equal j (i + 1)
+      | { glob = GlobRef.ConstructRef (ind', j) } -> Ind.CanOrd.equal ind ind' && Int.equal j (i + 1)
       | _ -> false
       in
       Array.for_all_i is_ref 0 br
@@ -839,12 +841,16 @@ let rec tmp_head_lams = function
   reduction (this helps the inlining of recursors).
 *)
 
+let is_constant g = match g.glob with
+| GlobRef.ConstRef _ -> true
+| _ -> false
+
 let rec ast_glob_subst s t = match t with
-  | MLapp ((MLglob ((GlobRef.ConstRef kn) as refe)) as f, a) ->
+  | MLapp ((MLglob refe) as f, a) when is_constant refe ->
       let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in
       (try linear_beta_red a (Refmap'.find refe s)
        with Not_found -> MLapp (f, a))
-  | MLglob ((GlobRef.ConstRef kn) as refe) ->
+  | MLglob refe when is_constant refe ->
       (try Refmap'.find refe s with Not_found -> t)
   | _ -> ast_map (ast_glob_subst s) t
 
@@ -1004,7 +1010,7 @@ let rec iota_red i lift br ((typ,r,a) as cons) =
   if i >= Array.length br then raise Impossible;
   let (ids,p,c) = br.(i) in
   match p with
-    | Pusual r' | Pcons (r',_) when not (GlobRef.CanOrd.equal r' r) -> iota_red (i+1) lift br cons
+    | Pusual r' | Pcons (r',_) when not (eq_global r' r) -> iota_red (i+1) lift br cons
     | Pusual r' ->
       let c = named_lams (List.rev ids) c in
       let c = ast_lift lift c
@@ -1523,7 +1529,7 @@ open Declareops
 let inline_test r t =
   if not (auto_inline ()) then false
   else
-    let c = match r with GlobRef.ConstRef c -> c | _ -> assert false in
+    let c = match r.glob with GlobRef.ConstRef c -> c | _ -> assert false in
     let has_body =
       Environ.mem_constant c (Global.env()) && constant_has_body (Global.lookup_constant c)
     in
@@ -1551,7 +1557,7 @@ let manual_inline_set =
     ]
     Cset_env.empty
 
-let manual_inline = function
+let manual_inline g = match g.glob with
   | GlobRef.ConstRef c -> Cset_env.mem c manual_inline_set
   | _ -> false
 
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
index 56d47e1ae0a2..7d15491c29a4 100644
--- a/plugins/extraction/mlutil.mli
+++ b/plugins/extraction/mlutil.mli
@@ -22,9 +22,9 @@ val type_subst_vect : ml_type array -> ml_type -> ml_type
 
 val instantiation : ml_schema -> ml_type
 
-val needs_magic : compute:bool -> ml_type * ml_type -> bool
+val needs_magic : ml_type * ml_type -> bool
 val put_magic_if : bool -> ml_ast -> ml_ast
-val put_magic : compute:bool -> ml_type * ml_type -> ml_ast -> ml_ast
+val put_magic : ml_type * ml_type -> ml_ast -> ml_ast
 
 val generalizable : ml_ast -> bool
 
@@ -58,7 +58,7 @@ val type_recomp : ml_type list * ml_type -> ml_type
 
 val var2var' : ml_type -> ml_type
 
-type abbrev_map = GlobRef.t -> ml_type option
+type abbrev_map = global -> ml_type option
 
 val type_expand : abbrev_map -> ml_type -> ml_type
 val type_simpl : ml_type -> ml_type
@@ -116,7 +116,7 @@ val dump_unused_vars : ml_ast -> ml_ast
 
 val normalize : ml_ast -> ml_ast
 val optimize_fix : ml_ast -> ml_ast
-val inline : Table.t -> GlobRef.t -> ml_ast -> bool
+val inline : Table.t -> global -> ml_ast -> bool
 
 val is_basic_pattern : ml_pattern -> bool
 val has_deep_pattern : ml_branch array -> bool
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index 84a237f0399d..acae35e219c1 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -35,13 +35,14 @@ let se_iter do_decl do_spec do_mp =
   let rec mt_iter = function
     | MTident mp -> do_mp mp
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
-    | MTwith (mt,ML_With_type(idl,l,t))->
+    | MTwith (mt, ML_With_type (rlv, idl, l, t))->
         let mp_mt = msid_of_mt mt in
         let l',idl' = List.sep_last idl in
         let mp_w =
           List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl'
         in
         let r = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l')) in
+        let r = { glob = r; inst = rlv } in
         mt_iter mt; do_spec (Stype(r,l,Some t))
     | MTwith (mt,ML_With_module(idl,mp))->
         let mp_mt = msid_of_mt mt in
@@ -75,7 +76,7 @@ let struct_iter do_decl do_spec do_mp s =
 (*s Apply some fonctions upon all references in [ml_type], [ml_ast],
   [ml_decl], [ml_spec] and [ml_structure]. *)
 
-type do_ref = GlobRef.t -> unit
+type do_ref = global -> unit
 
 let record_iter_references do_term = function
   | Record l -> List.iter (Option.iter do_term) l
@@ -117,8 +118,9 @@ let ind_iter_references do_term do_cons do_type ind =
   let packet_iter i p =
     let () = do_type p.ip_typename_ref in
     if lang () == Ocaml then
+      let inst = ind.ind_packets.(0).ip_typename_ref.inst in
       (match ind.ind_equiv with
-         | Miniml.Equiv kne -> do_type (GlobRef.IndRef (MutInd.make1 kne, i));
+         | Miniml.Equiv kne -> do_type { glob = (GlobRef.IndRef (MutInd.make1 kne, i)); inst };
          | _ -> ());
     Array.iteri (fun j -> cons_iter p.ip_consnames_ref.(j)) p.ip_types
   in
@@ -261,7 +263,7 @@ let dfix_to_mlfix rv av i =
   let s = make_subst (Array.length rv - 1) Refmap'.empty
   in
   let rec subst n t = match t with
-    | MLglob ((GlobRef.ConstRef kn) as refe) ->
+    | MLglob refe ->
         (try MLrel (n + (Refmap'.find refe s)) with Not_found -> t)
     | _ -> ast_map_lift subst n t
   in
@@ -312,10 +314,10 @@ and optim_me table to_appear s = function
    For non-library extraction, we recompute a minimal set of dependencies
    for first-level definitions (no module pruning yet). *)
 
-let base_r = let open GlobRef in function
-  | ConstRef c as r -> r
-  | IndRef (kn,_) -> IndRef (kn,0)
-  | ConstructRef ((kn,_),_) -> IndRef (kn,0)
+let base_r r = let open GlobRef in match r.glob with
+  | ConstRef _ -> r
+  | IndRef (kn,_) -> { glob = IndRef (kn, 0); inst = r.inst }
+  | ConstructRef ((kn,_),_) -> { glob = IndRef (kn, 0); inst = r.inst }
   | _ -> assert false
 
 let reset_needed, add_needed, add_needed_mp, found_needed, is_needed =
diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
index 2c7966da53ab..72aa3d0193d9 100644
--- a/plugins/extraction/modutil.mli
+++ b/plugins/extraction/modutil.mli
@@ -16,7 +16,7 @@ open Miniml
 val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool
 val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
 
-type do_ref = GlobRef.t -> unit
+type do_ref = global -> unit
 
 val type_iter_references : do_ref -> ml_type -> unit
 val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit
@@ -29,7 +29,7 @@ val mtyp_of_mexpr : ml_module_expr -> ml_module_type
 
 val msid_of_mt : ml_module_type -> ModPath.t
 
-val get_decl_in_structure : GlobRef.t -> ml_structure -> ml_decl
+val get_decl_in_structure : global -> ml_structure -> ml_decl
 
 (* Some transformations of ML terms. [optimize_struct] simplify
    all beta redexes (when the argument does not occur, it is just
@@ -38,5 +38,5 @@ val get_decl_in_structure : GlobRef.t -> ml_structure -> ml_decl
    optimizations. The first argument is the list of objects we want to appear.
 *)
 
-val optimize_struct : Common.State.t -> GlobRef.t list * ModPath.t list ->
+val optimize_struct : Common.State.t -> global list * ModPath.t list ->
   ml_structure -> ml_structure
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 9518c5b2da5f..72483cb65c4a 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -147,12 +147,12 @@ let get_infix r =
   let s = find_custom r in
   String.sub s 1 (String.length s - 2)
 
-let get_ind = let open GlobRef in function
-  | IndRef _ as r -> r
-  | ConstructRef (ind,_) -> IndRef ind
+let get_ind r = let open GlobRef in match r.glob with
+  | IndRef _ -> r
+  | ConstructRef (ind,_) -> { glob = IndRef ind; inst = r.inst }
   | _ -> assert false
 
-let kn_of_ind = let open GlobRef in function
+let kn_of_ind r = let open GlobRef in match r.glob with
   | IndRef (kn,_) -> MutInd.user kn
   | _ -> assert false
 
@@ -176,7 +176,7 @@ let pp_type table par vl t =
         pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2)
     | Tglob (r,[]) -> pp_global table Type r
     | Tglob (gr,l)
-        when not (keep_singleton ()) && Rocqlib.check_ref sig_type_name gr ->
+        when not (keep_singleton ()) && Rocqlib.check_ref sig_type_name gr.glob ->
         pp_tuple_light pp_rec l
     | Tglob (r,l) ->
         pp_tuple_light pp_rec l ++ spc () ++ pp_global table Type r
@@ -487,15 +487,16 @@ let pp_Dfix table (rv,c,t) =
 
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_equiv table param_list name = function
+let pp_equiv table param_list name inst = function
   | NoEquiv, _ -> mt ()
   | Equiv kn, i ->
-      str " = " ++ pp_parameters param_list ++ pp_global table Type (GlobRef.IndRef (MutInd.make1 kn,i))
+    let r = { glob = GlobRef.IndRef (MutInd.make1 kn, i); inst } in
+    str " = " ++ pp_parameters param_list ++ pp_global table Type r
   | RenEquiv ren, _  ->
       str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name
 
 
-let pp_one_ind table prefix ip_equiv pl name cnames ctyps =
+let pp_one_ind table prefix inst ip_equiv pl name cnames ctyps =
   let pl = rename_tvars keywords pl in
   let pp_constructor i typs =
     (if Int.equal i 0 then mt () else fnl ()) ++
@@ -505,7 +506,7 @@ let pp_one_ind table prefix ip_equiv pl name cnames ctyps =
             (fun () -> spc () ++ str "* ") (pp_type table true pl) typs)
   in
   pp_parameters pl ++ str prefix ++ name ++
-  pp_equiv table pl name ip_equiv ++ str " =" ++
+  pp_equiv table pl name inst ip_equiv ++ str " =" ++
   if Int.equal (Array.length ctyps) 0 then str " |"
   else fnl () ++ v 0 (prvecti pp_constructor ctyps)
 
@@ -531,7 +532,7 @@ let pp_record table fields ip_equiv packet =
   let l = List.combine fieldnames packet.ip_types.(0) in
   let pl = rename_tvars keywords packet.ip_vars in
   str "type " ++ pp_parameters pl ++ name ++
-  pp_equiv table pl name ip_equiv ++ str " = { "++
+  pp_equiv table pl name ind.inst ip_equiv ++ str " = { "++
   hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ())
            (fun (p,t) -> p ++ str " : " ++ pp_type table true pl t) l)
   ++ str " }"
@@ -567,8 +568,9 @@ let pp_ind table co ind =
       if is_custom ip then pp (i+1) kwd
       else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd
       else
+        let inst = p.ip_typename_ref.inst in
         kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++
-        pp_one_ind table prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++
+        pp_one_ind table prefix inst ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++
         pp (i+1) nextkwd
   in
   pp 0 initkwd
@@ -703,14 +705,14 @@ and pp_module_type table params = function
        else
          v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl ())
       ++ str "end"
-  | MTwith(mt,ML_With_type(idl,vl,typ)) ->
+  | MTwith(mt,ML_With_type (rlv, idl, vl, typ)) ->
       let ids = pp_parameters (rename_tvars keywords vl) in
       let mp_mt = msid_of_mt mt in
       let l,idl' = List.sep_last idl in
       let mp_w =
         List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl'
       in
-      let r = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l)) in
+      let r = { glob = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l)); inst = rlv } in
       let pp_w = State.with_visibility table mp_mt [] begin fun table ->
         str " with type " ++ ids ++ pp_global table Type r
       end in
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 8f95395ca351..bd4ddb2cf091 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -29,19 +29,27 @@ let blacklist_table = Summary.ref Id.Set.empty ~name:"ExtrBlacklist"
 (** Sets and maps for [global_reference] that use the "user" [kernel_name]
     instead of the canonical one *)
 
-module Refmap' = GlobRef.Map_env
-module Refset' = GlobRef.Set_env
+module GlobOrd =
+struct
+  type t = global
+  let compare g1 g2 =
+    let c = GlobRef.UserOrd.compare g1.glob g2.glob in
+    if Int.equal c 0 then InfvInst.compare g1.inst g2.inst else c
+end
+
+module Refmap' = CMap.Make(GlobOrd)
+module Refset' = Set.Make(GlobOrd)
 
 (*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
 
-let occur_kn_in_ref kn = let open GlobRef in function
+let occur_kn_in_ref kn r = let open GlobRef in match r.glob with
   | IndRef (kn',_)
   | ConstructRef ((kn',_),_) -> MutInd.CanOrd.equal kn kn'
   | ConstRef _ | VarRef _ -> false
 
 (* Return the "canonical" name used for declaring a name *)
 
-let repr_of_r = let open GlobRef in function
+let repr_of_r r = let open GlobRef in match r.glob with
   | ConstRef kn -> Constant.user kn
   | IndRef (kn,_)
   | ConstructRef ((kn,_),_) -> MutInd.user kn
@@ -112,11 +120,13 @@ let labels_of_ref r =
 (* We use [constant_body] (resp. [mutual_inductive_body]) as checksum
    to ensure that the table contents aren't outdated. *)
 
+module InfvMap = Map.Make(InfvInst)
+
 type table = {
-  typedefs : (constant_body * ml_type) Cmap_env.t;
-  cst_types : (constant_body * ml_schema) Cmap_env.t;
-  inductives : (mutual_inductive_body * ml_ind) Mindmap_env.t;
-  inductive_kinds : inductive_kind Mindmap_env.t;
+  typedefs : (constant_body * ml_type) InfvMap.t Cmap_env.t;
+  cst_types : (constant_body * ml_schema) InfvMap.t Cmap_env.t;
+  inductives : (mutual_inductive_body * ml_ind) InfvMap.t Mindmap_env.t;
+  inductive_kinds : inductive_kind InfvMap.t Mindmap_env.t;
   recursors : KNset.t;
   (* recursors: we can use the equivalence between canonical and user constant names. *)
   projs : (inductive * int) GlobRef.Map.t;
@@ -148,44 +158,60 @@ let empty_table = {
 
 let make_table () = ref { empty_table with modfile_ids = !blacklist_table }
 
-let add_typedef table kn cb t =
-  table := { !table with typedefs = Cmap_env.add kn (cb,t) !table.typedefs }
+let add_typedef table kn inst cb t =
+  let upd = function
+  | None -> Some (InfvMap.singleton inst (cb, t))
+  | Some map -> Some (InfvMap.add inst (cb, t) map)
+  in
+  table := { !table with typedefs = Cmap_env.update kn upd !table.typedefs }
 
-let lookup_typedef table kn cb =
+let lookup_typedef table kn inst cb =
   try
-    let (cb0,t) = Cmap_env.find kn !table.typedefs in
+    let (cb0, t) = InfvMap.find inst (Cmap_env.find kn !table.typedefs) in
     if cb0 == cb then Some t else None
   with Not_found -> None
 
-let add_cst_type table kn cb s =
-  table := { !table with cst_types = Cmap_env.add kn (cb,s) !table.cst_types }
+let add_cst_type table kn inst cb s =
+  let upd = function
+  | None -> Some (InfvMap.singleton inst (cb, s))
+  | Some map -> Some (InfvMap.add inst (cb, s) map)
+  in
+  table := { !table with cst_types = Cmap_env.update kn upd !table.cst_types }
 
-let lookup_cst_type table kn cb =
+let lookup_cst_type table kn inst cb =
   try
-    let (cb0,s) = Cmap_env.find kn !table.cst_types in
+    let (cb0, s) = InfvMap.find inst (Cmap_env.find kn !table.cst_types) in
     if cb0 == cb then Some s else None
   with Not_found -> None
 
-let add_ind table kn mib ml_ind =
-  table := { !table with inductives = Mindmap_env.add kn (mib,ml_ind) !table.inductives }
+let add_ind table kn inst mib ml_ind =
+  let upd = function
+  | None -> Some (InfvMap.singleton inst (mib, ml_ind))
+  | Some map -> Some (InfvMap.add inst (mib, ml_ind) map)
+  in
+  table := { !table with inductives = Mindmap_env.update kn upd !table.inductives }
 
-let lookup_ind table kn mib =
+let lookup_ind table kn inst mib =
   try
-    let (mib0,ml_ind) = Mindmap_env.find kn !table.inductives in
+    let (mib0, ml_ind) = InfvMap.find inst (Mindmap_env.find kn !table.inductives) in
     if mib == mib0 then Some ml_ind
     else None
   with Not_found -> None
 
-let add_inductive_kind table kn k =
-  table := { !table with inductive_kinds = Mindmap_env.add kn k !table.inductive_kinds }
+let add_inductive_kind table kn inst k =
+  let upd = function
+  | None -> Some (InfvMap.singleton inst k)
+  | Some map -> Some (InfvMap.add inst k map)
+  in
+  table := { !table with inductive_kinds = Mindmap_env.update kn upd !table.inductive_kinds }
 
 let is_coinductive table r =
-  let kn = let open GlobRef in match r with
+  let kn = let open GlobRef in match r.glob with
     | ConstructRef ((kn,_),_) -> kn
     | IndRef (kn,_) -> kn
     | _ -> assert false
   in
-  try Mindmap_env.find kn !table.inductive_kinds == Coinductive
+  try InfvMap.find r.inst (Mindmap_env.find kn !table.inductive_kinds) == Coinductive
   with Not_found -> false
 
 let is_coinductive_type table = function
@@ -193,12 +219,12 @@ let is_coinductive_type table = function
   | _ -> false
 
 let get_record_fields table r =
-  let kn = let open GlobRef in match r with
+  let kn = let open GlobRef in match r.glob with
     | ConstructRef ((kn,_),_) -> kn
     | IndRef (kn,_) -> kn
     | _ -> assert false
   in
-  try match Mindmap_env.find kn !table.inductive_kinds with
+  try match InfvMap.find r.inst (Mindmap_env.find kn !table.inductive_kinds) with
     | Record f -> f
     | _ -> []
   with Not_found -> []
@@ -221,14 +247,12 @@ let add_recursors table env ind =
        table := { !table with recursors = KNset.add kn_rec (KNset.add kn_rect !table.recursors) })
     mib.mind_packets
 
-let is_recursor table = function
+let is_recursor table r = match r.glob with
   | GlobRef.ConstRef c -> KNset.mem (Constant.canonical c) !table.recursors
   | _ -> false
 
 let add_projection table n kn ip = table := { !table with projs = GlobRef.Map.add (GlobRef.ConstRef kn) (ip,n) !table.projs }
-let is_projection table r = GlobRef.Map.mem r !table.projs
-let projection_arity table r = snd (GlobRef.Map.find r !table.projs)
-let projection_info table r = GlobRef.Map.find r !table.projs
+let is_projection table r = GlobRef.Map.mem r.glob !table.projs
 
 (*s Table of used axioms *)
 
@@ -263,12 +287,13 @@ let safe_basename_of_global_gen table r =
       let id = Id.to_string (Label.to_id (MutInd.label kn)) in
       Id.of_string (id ^ "_" ^ String.concat "_" (List.map string_of_int pos))
   in
-  let unsafe_lookup_ind table kn = snd (Mindmap_env.find kn !table.inductives) in
+  let unsafe_lookup_ind table kn = snd (InfvMap.find r.inst (Mindmap_env.find kn !table.inductives)) in
   let open GlobRef in
-  match r with
+  match r.glob with
     | ConstRef kn -> Label.to_id (Constant.label kn)
     | IndRef (kn,0) -> Label.to_id (MutInd.label kn)
     | IndRef (kn,i) ->
+      let r = r.glob in
       begin match table with
       | None -> last_chance r (kn, [i])
       | Some table ->
@@ -276,6 +301,7 @@ let safe_basename_of_global_gen table r =
         with Not_found -> last_chance r (kn, [i])
       end
     | ConstructRef ((kn,i),j) ->
+      let r = r.glob in
       begin match table with
       | None -> last_chance r (kn, [i; j])
       | Some table ->
@@ -286,8 +312,8 @@ let safe_basename_of_global_gen table r =
 
 let safe_basename_of_global table r = safe_basename_of_global_gen (Some table) r
 
-let string_of_global r =
- try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r)
+let string_of_global r  =
+ try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r.glob)
  with Not_found -> Id.to_string (safe_basename_of_global_gen None r)
 
 let safe_pr_global r = str (string_of_global r)
@@ -295,8 +321,8 @@ let safe_pr_global r = str (string_of_global r)
 (* idem, but with qualification, and only for constants. *)
 
 let safe_pr_long_global r =
-  try Printer.pr_global r
-  with Not_found -> match r with
+  try Printer.pr_global r.glob
+  with Not_found -> match r.glob with
     | GlobRef.ConstRef kn ->
         let mp,l = KerName.repr (Constant.user kn) in
         str ((ModPath.to_string mp)^"."^(Label.to_string l))
@@ -430,7 +456,9 @@ let error_no_module_expr mp =
        ++ str "This situation is currently unsupported by the extraction.")
 
 let error_singleton_become_prop ind =
-  err (str "The informative inductive type " ++ safe_pr_global (IndRef ind) ++
+  (* Should be fine, only used for printing and with template poly inductives *)
+  let ind = { glob = IndRef ind; inst = InfvInst.empty } in
+  err (str "The informative inductive type " ++ safe_pr_global ind ++
        str " has a Prop instance" ++ str "." ++ fnl () ++
        str "This happens when a sort-polymorphic singleton inductive type\n" ++
        str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++
@@ -459,7 +487,7 @@ let error_MPfile_as_mod mp b =
 
 let argnames_of_global r =
   let env = Global.env () in
-  let typ, _ = Typeops.type_of_global_in_context env r in
+  let typ, _ = Typeops.type_of_global_in_context env r.glob in
   let rels,_ =
     decompose_prod (Reduction.whd_all env typ) in
   List.rev_map (fun x -> Context.binder_name (fst x)) rels
@@ -704,32 +732,39 @@ let add_callback_entry alias_opt qualid_ref =
 
 (* Registration of operations for rollback. *)
 
-let inline_extraction : bool * GlobRef.t list -> obj =
+let subst_global s g = { glob = fst (subst_global s g.glob); inst = g.inst }
+
+let inline_extraction : bool * global list -> obj =
   declare_object @@ superglobal_object "Extraction Inline"
     ~cache:(fun (b,l) -> add_inline_entries b l)
-    ~subst:(Some (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))))
+    ~subst:(Some (fun (s,(b,l)) -> (b,(List.map (fun x -> subst_global s x) l))))
     ~discharge:(fun x -> Some x)
 
-let foreign_extraction : GlobRef.t list -> obj =
+let foreign_extraction : global list -> obj =
   declare_object @@ superglobal_object "Extraction Foreign"
     ~cache:(fun l -> add_foreign_entries l)
-    ~subst:(Some (fun (s,l) -> (List.map (fun x -> fst (subst_global s x)) l)))
+    ~subst:(Some (fun (s,l) -> (List.map (fun x -> subst_global s x) l)))
     ~discharge:(fun x -> Some x)
 
-let callback_extraction : string option * GlobRef.t -> obj =
+let callback_extraction : string option * global -> obj =
   declare_object @@ superglobal_object "Extraction Callback"
     ~cache:(fun (alias, x) -> add_callback_entry alias x)
-    ~subst:(Some (fun (s,(alias, x)) -> (alias, (fst (subst_global s x)))))
+    ~subst:(Some (fun (s,(alias, x)) -> (alias, subst_global s x)))
     ~discharge:(fun x -> Some x)
 
 
 
 (* Grammar entries. *)
 
+let mono_global_with_alias qid =
+  let gr = Smartlocate.global_with_alias qid in
+  let inst = Environ.universes_of_global (Global.env ()) gr in
+  List.map (fun inst -> { glob = gr; inst }) (InfvInst.generate inst)
+
 let extraction_inline b l =
-  let refs = List.map Smartlocate.global_with_alias l in
+  let refs = List.map_append mono_global_with_alias l in
   List.iter
-    (fun r -> match r with
+    (fun r -> match r.glob with
        | GlobRef.ConstRef _ -> ()
        | _ -> error_constant r) refs;
   Lib.add_leaf (inline_extraction (b,refs))
@@ -738,7 +773,7 @@ let extraction_inline b l =
 
 let print_extraction_inline () =
   let (i,n)= !inline_table in
-  let i'= Refset'.filter (function GlobRef.ConstRef _ -> true | _ -> false) i in
+  let i'= Refset'.filter (function { glob = GlobRef.ConstRef _ } -> true | _ -> false) i in
     (str "Extraction Inline:" ++ fnl () ++
      Refset'.fold
        (fun r p ->
@@ -809,16 +844,17 @@ let add_implicits r l =
 
 (* Registration of operations for rollback. *)
 
-let implicit_extraction : GlobRef.t * int_or_id list -> obj =
+let implicit_extraction : global * int_or_id list -> obj =
   declare_object @@ superglobal_object_nodischarge "Extraction Implicit"
     ~cache:(fun (r,l) -> add_implicits r l)
-    ~subst:(Some (fun (s,(r,l)) -> (fst (subst_global s r), l)))
+    ~subst:(Some (fun (s,(r,l)) -> (subst_global s r, l)))
 
 (* Grammar entries. *)
 
 let extraction_implicit r l =
   check_inside_section ();
-  Lib.add_leaf (implicit_extraction (Smartlocate.global_with_alias r,l))
+  let r = mono_global_with_alias r in
+  List.iter (fun r -> Lib.add_leaf (implicit_extraction (r, l))) r
 
 let string_of_modfile table mp =
   try MPmap.find mp !table.modfile_mps
@@ -903,8 +939,8 @@ let indref_of_match pv =
   if Array.is_empty pv then raise Not_found;
   let (_,pat,_) = pv.(0) in
   match pat with
-    | Pusual (GlobRef.ConstructRef (ip,_)) -> GlobRef.IndRef ip
-    | Pcons (GlobRef.ConstructRef (ip,_),_) -> GlobRef.IndRef ip
+    | Pusual { glob = GlobRef.ConstructRef (ip,_); inst } -> { glob = GlobRef.IndRef ip; inst }
+    | Pcons ({ glob = GlobRef.ConstructRef (ip,_); inst }, _) -> { glob = GlobRef.IndRef ip; inst }
     | _ -> raise Not_found
 
 let is_custom_match pv =
@@ -917,7 +953,7 @@ let find_custom_match pv =
 (* Printing entries *)
 
 let print_constref_extractions ref_set val_lookup_f section_str =
-  let i'= Refset'.filter (function GlobRef.ConstRef _ -> true | _ -> false) ref_set in
+  let i'= Refset'.filter (function { glob = GlobRef.ConstRef _ } -> true | _ -> false) ref_set in
       (str section_str ++ fnl () ++
        Refset'.fold
          (fun r p ->
@@ -936,15 +972,15 @@ let print_extraction_callback () =
 
 (* Registration of operations for rollback. *)
 
-let in_customs : GlobRef.t * string list * string -> obj =
+let in_customs : global * string list * string -> obj =
   declare_object @@ superglobal_object_nodischarge "ML extractions"
     ~cache:(fun (r,ids,s) -> add_custom r ids s)
-    ~subst:(Some (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)))
+    ~subst:(Some (fun (s,(r,ids,str)) -> (subst_global s r, ids, str)))
 
-let in_custom_matchs : GlobRef.t * string -> obj =
+let in_custom_matchs : global * string -> obj =
   declare_object @@ superglobal_object_nodischarge "ML extractions custom matches"
     ~cache:(fun (r,s) -> add_custom_match r s)
-    ~subst:(Some (fun (subs,(r,s)) -> (fst (subst_global subs r), s)))
+    ~subst:(Some (fun (subs,(r,s)) -> (subst_global subs r, s)))
 
 (* Grammar entries. *)
 
@@ -952,18 +988,21 @@ let extract_callback optstr x =
   if lang () != Ocaml then
       CErrors.user_err (Pp.str "Extract Callback is supported only for OCaml extraction.");
 
-  let qualid_ref = Smartlocate.global_with_alias x in
-  match qualid_ref with
+  let refs = mono_global_with_alias x in
+  List.iter begin fun qualid_ref ->
+  match qualid_ref.glob with
       (* Add the alias and qualid_ref to callback extraction.*)
     | GlobRef.ConstRef _ -> Lib.add_leaf (callback_extraction (optstr, qualid_ref))
     | _                  -> error_constant ?loc:x.CAst.loc qualid_ref
+  end refs
 
 let extract_constant_generic r ids s arity_handler (is_redef, redef_msg) extr_type =
   check_inside_section ();
-  let g = Smartlocate.global_with_alias r in
-  match g with
+  let g = mono_global_with_alias r in
+  List.iter begin fun g -> match g.glob with
     | GlobRef.ConstRef kn ->
         let env = Global.env () in
+        (* FIXME: substitute ground instance *)
         let typ, _ = Typeops.type_of_global_in_context env (GlobRef.ConstRef kn) in
         let typ = Reduction.whd_all env typ in
         if Reduction.is_arity env typ then arity_handler env typ g;
@@ -973,6 +1012,7 @@ let extract_constant_generic r ids s arity_handler (is_redef, redef_msg) extr_ty
         Lib.add_leaf (extr_type g);
         Lib.add_leaf (in_customs (g,ids,s));
     | _ -> error_constant ?loc:r.CAst.loc g
+  end g
 
 let extract_constant_inline inline r ids s =
   let arity_handler env typ g =
@@ -993,9 +1033,10 @@ let extract_constant_foreign r s =
 
 let extract_inductive r s l optstr =
   check_inside_section ();
-  let g = Smartlocate.global_with_alias r in
-  Dumpglob.add_glob ?loc:r.CAst.loc g;
-  match g with
+  let g = mono_global_with_alias r in
+  List.iter begin fun g ->
+  Dumpglob.add_glob ?loc:r.CAst.loc g.glob;
+  match g.glob with
     | GlobRef.IndRef ((kn,i) as ip) ->
         let mib = Global.lookup_mind kn in
         let n = Array.length mib.mind_packets.(i).mind_consnames in
@@ -1006,7 +1047,8 @@ let extract_inductive r s l optstr =
           optstr;
         List.iteri
           (fun j s ->
-             let g = GlobRef.ConstructRef (ip,succ j) in
+             let g = { glob = GlobRef.ConstructRef (ip,succ j); inst = g.inst } in
              Lib.add_leaf (inline_extraction (true,[g]));
              Lib.add_leaf (in_customs (g,[],s))) l
     | _ -> error_inductive ?loc:r.CAst.loc g
+  end g
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index 7893e429288c..ed7120450e3b 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -13,12 +13,12 @@ open Libnames
 open Miniml
 open Declarations
 
-module Refset' : CSig.USetS with type elt = GlobRef.t
-module Refmap' : CSig.UMapS with type key = GlobRef.t
+module Refset' : CSig.USetS with type elt = global
+module Refmap' : CSig.UMapS with type key = global
 
 type t
 
-val safe_basename_of_global : t -> GlobRef.t -> Id.t
+val safe_basename_of_global : t -> global -> Id.t
 
 val make_table : unit -> t
 
@@ -28,16 +28,16 @@ val warning_axioms : t -> unit
 val warning_opaques : t -> bool -> unit
 val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * GlobRef.t -> unit
 val warning_id : string -> unit
-val error_axiom_scheme : ?loc:Loc.t -> GlobRef.t -> int -> 'a
-val error_constant : ?loc:Loc.t -> GlobRef.t -> 'a
-val error_inductive : ?loc:Loc.t -> GlobRef.t -> 'a
+val error_axiom_scheme : ?loc:Loc.t -> global -> int -> 'a
+val error_constant : ?loc:Loc.t -> global -> 'a
+val error_inductive : ?loc:Loc.t -> global -> 'a
 val error_nb_cons : unit -> 'a
 val error_module_clash : ModPath.t -> ModPath.t -> 'a
 val error_no_module_expr : ModPath.t -> 'a
 val error_singleton_become_prop : inductive -> 'a
 val error_unknown_module : ?loc:Loc.t -> qualid -> 'a
 val error_scheme : unit -> 'a
-val error_not_visible : GlobRef.t -> 'a
+val error_not_visible : global -> 'a
 val error_MPfile_as_mod : ModPath.t -> bool -> 'a
 val check_inside_section : unit -> unit
 val check_loaded_modfile : ModPath.t -> unit
@@ -48,10 +48,10 @@ val info_file : string -> unit
 
 (*s utilities about [module_path] and [kernel_names] and [GlobRef.t] *)
 
-val occur_kn_in_ref : MutInd.t -> GlobRef.t -> bool
-val repr_of_r : GlobRef.t -> KerName.t
-val modpath_of_r : GlobRef.t -> ModPath.t
-val label_of_r : GlobRef.t -> Label.t
+val occur_kn_in_ref : MutInd.t -> global -> bool
+val repr_of_r : global -> KerName.t
+val modpath_of_r : global -> ModPath.t
+val label_of_r : global -> Label.t
 val base_mp : ModPath.t -> ModPath.t
 val is_modfile : ModPath.t -> bool
 val string_of_modfile : t -> ModPath.t -> string
@@ -63,7 +63,7 @@ val prefixes_mp : ModPath.t -> MPset.t
 val common_prefix_from_list :
   ModPath.t -> ModPath.t list -> ModPath.t option
 val get_nth_label_mp : int -> ModPath.t -> Label.t
-val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list
+val labels_of_ref : global -> ModPath.t * Label.t list
 
 (*s Some table-related operations *)
 
@@ -75,39 +75,37 @@ val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list
    [mutual_inductive_body] as checksum. In both case, we should ideally
    also check the env *)
 
-val add_typedef : t -> Constant.t -> constant_body -> ml_type -> unit
-val lookup_typedef : t -> Constant.t -> constant_body -> ml_type option
+val add_typedef : t -> Constant.t -> InfvInst.t -> constant_body -> ml_type -> unit
+val lookup_typedef : t -> Constant.t -> InfvInst.t -> constant_body -> ml_type option
 
-val add_cst_type : t -> Constant.t -> constant_body -> ml_schema -> unit
-val lookup_cst_type : t -> Constant.t -> constant_body -> ml_schema option
+val add_cst_type : t -> Constant.t -> InfvInst.t -> constant_body -> ml_schema -> unit
+val lookup_cst_type : t -> Constant.t -> InfvInst.t -> constant_body -> ml_schema option
 
-val add_ind : t -> MutInd.t -> mutual_inductive_body -> ml_ind -> unit
-val lookup_ind : t -> MutInd.t -> mutual_inductive_body -> ml_ind option
+val add_ind : t -> MutInd.t -> InfvInst.t -> mutual_inductive_body -> ml_ind -> unit
+val lookup_ind : t -> MutInd.t ->  InfvInst.t -> mutual_inductive_body -> ml_ind option
 
-val add_inductive_kind : t -> MutInd.t -> inductive_kind -> unit
-val is_coinductive : t -> GlobRef.t -> bool
+val add_inductive_kind : t -> MutInd.t -> InfvInst.t -> inductive_kind -> unit
+val is_coinductive : t -> global -> bool
 val is_coinductive_type : t -> ml_type -> bool
 (* What are the fields of a record (empty for a non-record) *)
 val get_record_fields :
-  t -> GlobRef.t -> GlobRef.t option list
-val record_fields_of_type : t -> ml_type -> GlobRef.t option list
+  t -> global -> global option list
+val record_fields_of_type : t -> ml_type -> global option list
 
 val add_recursors : t -> Environ.env -> MutInd.t -> unit
-val is_recursor : t -> GlobRef.t -> bool
+val is_recursor : t -> global -> bool
 
 val add_projection : t -> int -> Constant.t -> inductive -> unit
-val is_projection : t -> GlobRef.t -> bool
-val projection_arity : t -> GlobRef.t -> int
-val projection_info : t -> GlobRef.t -> inductive * int (* arity *)
+val is_projection : t -> global -> bool
 
-val add_info_axiom : t -> GlobRef.t -> unit
-val remove_info_axiom : t -> GlobRef.t -> unit
-val add_log_axiom : t -> GlobRef.t -> unit
-val add_symbol : t -> GlobRef.t -> unit
-val add_symbol_rule : t -> GlobRef.t -> Label.t -> unit
+val add_info_axiom : t -> global -> unit
+val remove_info_axiom : t -> global -> unit
+val add_log_axiom : t -> global-> unit
+val add_symbol : t -> global -> unit
+val add_symbol_rule : t -> global -> Label.t -> unit
 
-val add_opaque : t -> GlobRef.t -> unit
-val remove_opaque : t -> GlobRef.t -> unit
+val add_opaque : t -> global -> unit
+val remove_opaque : t -> global -> unit
 
 (*s Output Directory parameter *)
 
@@ -161,24 +159,24 @@ val lang : unit -> lang
 
 (*s Table for custom inlining *)
 
-val to_inline : GlobRef.t -> bool
-val to_keep : GlobRef.t -> bool
+val to_inline : global -> bool
+val to_keep : global -> bool
 
 (*s Table for implicits arguments *)
 
-val implicits_of_global : GlobRef.t -> Int.Set.t
+val implicits_of_global : global -> Int.Set.t
 
 (*s Table for user-given custom ML extractions. *)
 
 (* UGLY HACK: registration of a function defined in [extraction.ml] *)
 val type_scheme_nb_args_hook : (Environ.env -> Constr.t -> int) Hook.t
 
-val is_custom : GlobRef.t -> bool
-val is_inline_custom : GlobRef.t -> bool
-val is_foreign_custom : GlobRef.t -> bool
-val find_callback : GlobRef.t -> string option
-val find_custom : GlobRef.t -> string
-val find_type_custom : GlobRef.t -> string list * string
+val is_custom : global -> bool
+val is_inline_custom : global -> bool
+val is_foreign_custom : global -> bool
+val find_callback : global -> string option
+val find_custom : global -> string
+val find_type_custom : global -> string list * string
 
 val is_custom_match : ml_branch array -> bool
 val find_custom_match : ml_branch array -> string
diff --git a/test-suite/success/sort_poly_extraction.v b/test-suite/success/sort_poly_extraction.v
index 8d3b2b40cdea..97f35fdff677 100644
--- a/test-suite/success/sort_poly_extraction.v
+++ b/test-suite/success/sort_poly_extraction.v
@@ -5,7 +5,7 @@ Definition foo@{s| |} := tt.
 
 Definition bar := foo@{Prop|}.
 
-Fail Extraction bar.
+Extraction bar.
 
 (* the actual problem only appears once we have inductives with sort poly output: *)
 
@@ -18,4 +18,37 @@ Definition make_pair := pair@{Prop|_} _ I I.
 
 Definition hell := use_pair True (fun _ => 0) make_pair.
 
-Fail Recursive Extraction hell.
+Extraction TestCompile hell.
+
+(* Some tests *)
+
+Module Foo.
+
+Definition foo@{s1 s2| |} := fun (A : Type@{s1|Set}) (x : A) => x.
+
+Definition foo0 := foo@{SProp Type|}.
+Definition foo1 := foo@{Type SProp|}.
+
+Inductive T@{s| |} : Type@{s|Set} := O : T | S : T -> T.
+
+Inductive box@{s1 s2| |} (A : Type@{s1|Set}) (B : Type@{s2|Set}) : Type@{Set} := Box : A -> B -> box A B.
+
+Definition bar (A : Type) (x : A) := 0.
+
+Definition qux := bar (forall A : Prop, A -> A) foo@{Prop Type|}.
+
+End Foo.
+
+Extraction TestCompile Foo.
+
+(* Check module subtyping *)
+
+Module Type S.
+Inductive box@{s1 s2| |} (A : Type@{s1|Set}) (B : Type@{s2|Set}) : Type@{Set} := Box : A -> B -> box A B.
+End S.
+
+Module Bar : S.
+Inductive box@{s1 s2| |} (A : Type@{s1|Set}) (B : Type@{s2|Set}) : Type@{Set} := Box : A -> B -> box A B.
+End Bar.
+
+Extraction TestCompile Bar.


Reviews:
user: login: SkySkimmer
state: COMMENTED
author_association: CONTRIBUTOR
submitted_at: 2025-05-21T11:39:29Z
user: login: SkySkimmer
state: COMMENTED
author_association: CONTRIBUTOR
submitted_at: 2025-05-21T11:40:18Z
user: login: ppedrot
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-05-21T11:47:30Z
user: login: ppedrot
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-05-21T11:49:05Z
user: login: SkySkimmer
state: APPROVED
author_association: CONTRIBUTOR
submitted_at: 2025-05-22T08:20:39Z

Review comments:
diff_hunk: @@ -12,7 +12,35 @@
 
 open Names
 
-type global = { glob : GlobRef.t }
+(* Informativity data for sort polymorphism *)
+module InfvInst :
+sig
+  type t
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+
+  val empty : t
+  (** No bound sort variables *)
+
+  val generate : UVars.AbstractContext.t -> t list
+  (** 2^n possible instances for this context *)
+
+  val default : UVars.AbstractContext.t -> t
+  (** All sorts informative *)
+
+  val ground : UVars.Instance.t -> t
+  (** From a ground instance returns a relevance instance *)
path: plugins/extraction/miniml.mli
user: login: SkySkimmer
body: ~~~suggestion
  (** From a ground instance returns a informativity instance *)
~~~
created_at: 2025-05-21T11:25:43Z
author_association: CONTRIBUTOR
diff_hunk: @@ -12,7 +12,66 @@
 
 open Names
 
-type global = { glob : GlobRef.t }
+module InfvInst =
+struct
+  type t = bool array (* true if informative *)
+  let empty = [||]
+  let bcmp b1 b2 = if b1 then if b2 then 0 else 1 else if b2 then -1 else 0
path: plugins/extraction/miniml.ml
user: login: SkySkimmer
body: why not Bool.compare?
created_at: 2025-05-21T11:26:52Z
author_association: CONTRIBUTOR
diff_hunk: @@ -246,6 +281,13 @@ and extract_mexpr_spec table venv env mp1 (me_struct_o,me_alg) = match me_alg wi
     let () = Visit.add_mp_all venv mp in
     MTident mp
   | MEwith(me',WithDef(idl,(c,ctx)))->
+      let () = match ctx with
+      | None -> ()
+      | Some auctx ->
+        (* TODO *)
+        if Array.is_empty (UVars.AbstractContext.names auctx).quals then ()
+        else user_err Pp.(str "with Definition clauses not allowed for sort polymorphic definitions")
path: plugins/extraction/extract_env.ml
user: login: SkySkimmer
body: ~~~suggestion
        else user_err Pp.(str "Extraction of \"with Definition\" clauses not supported for sort polymorphic definitions.")
~~~
created_at: 2025-05-21T11:32:58Z
author_association: CONTRIBUTOR
diff_hunk: @@ -246,6 +281,13 @@ and extract_mexpr_spec table venv env mp1 (me_struct_o,me_alg) = match me_alg wi
     let () = Visit.add_mp_all venv mp in
     MTident mp
   | MEwith(me',WithDef(idl,(c,ctx)))->
+      let () = match ctx with
+      | None -> ()
+      | Some auctx ->
+        (* TODO *)
path: plugins/extraction/extract_env.ml
user: login: SkySkimmer
body: ~~~suggestion
        (* XXX maybe implement this someday *)
~~~
created_at: 2025-05-21T11:33:06Z
author_association: CONTRIBUTOR
diff_hunk: @@ -18,4 +18,37 @@ Definition make_pair := pair@{Prop|_} _ I I.
 
 Definition hell := use_pair True (fun _ => 0) make_pair.
 
-Fail Recursive Extraction hell.
+Recursive Extraction hell.
+
+(* Some tests *)
+
+Module Foo.
+
+Definition foo@{s1 s2| |} := fun (A : Type@{s1|Set}) (x : A) => x.
+
+Definition foo0 := foo@{SProp Type|}.
+Definition foo1 := foo@{Type SProp|}.
+
+Inductive T@{s| |} : Type@{s|Set} := O : T | S : T -> T.
+
+Inductive box@{s1 s2| |} (A : Type@{s1|Set}) (B : Type@{s2|Set}) : Type@{Set} := Box : A -> B -> box A B.
+
+Definition bar (A : Type) (x : A) := 0.
+
+Definition qux := bar (forall A : Prop, A -> A) foo@{Prop Type|}.
+
+End Foo.
+
+Recursive Extraction Foo.
path: test-suite/success/sort_poly_extraction.v
user: login: SkySkimmer
body: should we be doing TestCompile?
created_at: 2025-05-21T11:39:26Z
author_association: CONTRIBUTOR
diff_hunk: @@ -246,6 +281,13 @@ and extract_mexpr_spec table venv env mp1 (me_struct_o,me_alg) = match me_alg wi
     let () = Visit.add_mp_all venv mp in
     MTident mp
   | MEwith(me',WithDef(idl,(c,ctx)))->
+      let () = match ctx with
+      | None -> ()
+      | Some auctx ->
+        (* TODO *)
path: plugins/extraction/extract_env.ml
user: login: SkySkimmer
body: (let's try to keep TODO for stuff that should be resolved before merging)
created_at: 2025-05-21T11:40:18Z
author_association: CONTRIBUTOR
diff_hunk: @@ -18,4 +18,37 @@ Definition make_pair := pair@{Prop|_} _ I I.
 
 Definition hell := use_pair True (fun _ => 0) make_pair.
 
-Fail Recursive Extraction hell.
+Recursive Extraction hell.
+
+(* Some tests *)
+
+Module Foo.
+
+Definition foo@{s1 s2| |} := fun (A : Type@{s1|Set}) (x : A) => x.
+
+Definition foo0 := foo@{SProp Type|}.
+Definition foo1 := foo@{Type SProp|}.
+
+Inductive T@{s| |} : Type@{s|Set} := O : T | S : T -> T.
+
+Inductive box@{s1 s2| |} (A : Type@{s1|Set}) (B : Type@{s2|Set}) : Type@{Set} := Box : A -> B -> box A B.
+
+Definition bar (A : Type) (x : A) := 0.
+
+Definition qux := bar (forall A : Prop, A -> A) foo@{Prop Type|}.
+
+End Foo.
+
+Recursive Extraction Foo.
path: test-suite/success/sort_poly_extraction.v
user: login: ppedrot
body: Good idea.
created_at: 2025-05-21T11:47:30Z
author_association: MEMBER
diff_hunk: @@ -12,7 +12,66 @@
 
 open Names
 
-type global = { glob : GlobRef.t }
+module InfvInst =
+struct
+  type t = bool array (* true if informative *)
+  let empty = [||]
+  let bcmp b1 b2 = if b1 then if b2 then 0 else 1 else if b2 then -1 else 0
path: plugins/extraction/miniml.ml
user: login: ppedrot
body: I was not aware there was such a thing.
created_at: 2025-05-21T11:49:05Z
author_association: MEMBER

PR comments:
user: login: SkySkimmer
created_at: 2025-05-20T11:24:03Z
body: @coqbot bench
author_association: CONTRIBUTOR
user: login: pi8027
created_at: 2025-05-20T15:55:58Z
body: Although I think I don't qualify as a reviewer of this kind of PR, I support the idea. I would like to see if we can extract the entire MathComp or not.
author_association: CONTRIBUTOR
user: login: ppedrot
created_at: 2025-05-20T20:35:45Z
body: I've added some tests, if CI is green this is good to go IMO.
author_association: MEMBER
user: login: coqbot-app[bot]
created_at: 2025-05-21T00:26:49Z
body: :checkered_flag: Bench results:
```
┌─────────────────────────────────────┬─────────────────────────┬───────────────────────────────────────┬─────────────────────────┐
│                                     │      user time [s]      │           CPU instructions            │  max resident mem [KB]  │
│                                     │                         │                                       │                         │
│            package_name             │   NEW      OLD    PDIFF │      NEW             OLD        PDIFF │   NEW      OLD    PDIFF │
├─────────────────────────────────────┼─────────────────────────┼───────────────────────────────────────┼─────────────────────────┤
│             rocq-mathcomp-ssreflect │    1.29     1.32  -2.27 │     9279315361      9275139740   0.05 │  551672   551724  -0.01 │
│                           rocq-elpi │   12.75    12.87  -0.93 │    91949967985     91961125440  -0.01 │  482340   481640   0.15 │
│                  coq-metacoq-common │   65.51    65.94  -0.65 │   425296142854    425288666649   0.00 │  913092   909420   0.40 │
│                           coq-color │  252.20   253.66  -0.58 │  1590144802629   1590167566660  -0.00 │ 1115312  1115068   0.02 │
│                       coq-fiat-core │   58.81    59.11  -0.51 │   359326449347    359340828782  -0.00 │  487272   485288   0.41 │
│                         rocq-stdlib │  216.35   217.32  -0.45 │  1369190793421   1369083014902   0.01 │  580028   579424   0.10 │
│              coq-mathcomp-odd-order │  583.53   586.02  -0.42 │  4197629047986   4197751789597  -0.00 │ 2203220  2202840   0.02 │
│              rocq-mathcomp-fingroup │   23.55    23.64  -0.38 │   152312831745    152334270452  -0.01 │  529068   528752   0.06 │
│                         coq-coqutil │   44.97    45.14  -0.38 │   284210405045    284273468446  -0.02 │  561980   562744  -0.14 │
│                        coq-coqprime │   51.67    51.86  -0.37 │   354926845270    354956359230  -0.01 │  799888   801948  -0.26 │
│                        rocq-bignums │   30.17    30.25  -0.26 │   193671214152    193679156035  -0.00 │  484572   485372  -0.16 │
│                    coq-math-classes │   86.96    87.19  -0.26 │   534224547465    534321928475  -0.02 │  511796   513044  -0.24 │
│             coq-metacoq-safechecker │  346.48   347.31  -0.24 │  2613704483295   2613707012472  -0.00 │ 1799324  1800484  -0.06 │
│                           rocq-core │    6.29     6.30  -0.16 │    38676200349     38677101792  -0.00 │  440404   436024   1.00 │
│                            coq-hott │  155.29   155.51  -0.14 │  1074536158978   1074614509873  -0.01 │  484080   483908   0.04 │
│                   coq-metacoq-pcuic │  661.15   662.06  -0.14 │  4246294247732   4246083630078   0.00 │ 2331752  2333568  -0.08 │
│             rocq-mathcomp-character │   87.63    87.73  -0.11 │   615472086824    615850960307  -0.06 │ 1446808  1448416  -0.11 │
│               rocq-mathcomp-algebra │  274.11   274.34  -0.08 │  2039170313055   2039727835677  -0.03 │ 1415636  1417896  -0.16 │
│                      coq-coquelicot │   37.97    38.00  -0.08 │   228250935005    228283594474  -0.01 │  826948   826764   0.02 │
│                    coq-fiat-parsers │  279.22   279.38  -0.06 │  2154265063996   2153647923349   0.03 │ 2293556  2291256   0.10 │
│                      coq-verdi-raft │  535.79   535.89  -0.02 │  3727634450500   3727294775190   0.01 │  844852   851384  -0.77 │
│                       coq-fourcolor │ 1331.47  1331.40   0.01 │ 12360603021252  12361841608087  -0.01 │  883876   882188   0.19 │
│                        rocq-runtime │   73.73    73.70   0.04 │   532828624827    532375102525   0.09 │  487676   489204  -0.31 │
│                             coq-vst │  873.16   872.75   0.05 │  6590941824233   6591085229857  -0.00 │ 2229444  2229412   0.00 │
│                        coq-bedrock2 │  347.58   347.30   0.08 │  2897102705265   2897254020487  -0.01 │  871888   876020  -0.47 │
│                 coq-category-theory │  616.83   616.22   0.10 │  4534780608059   4534787329152  -0.00 │  932236   932712  -0.05 │
│                        coq-rewriter │  338.22   337.88   0.10 │  2524303088573   2524335969763  -0.00 │ 1313976  1314636  -0.05 │
│                         coq-unimath │ 1787.08  1785.17   0.11 │ 14779553388745  14779261136065   0.00 │ 1036872  1036804   0.01 │
│               coq-mathcomp-analysis │  852.20   851.16   0.12 │  6319239100244   6317081919416   0.03 │ 1855480  1855604  -0.01 │
│                   coq-iris-examples │  362.86   362.38   0.13 │  2400911620139   2400859307016   0.00 │ 1051224  1053160  -0.18 │
│ coq-neural-net-interp-computed-lite │  234.74   234.37   0.16 │  2250276635085   2250327063760  -0.00 │  878520   874296   0.48 │
│        coq-fiat-crypto-with-bedrock │ 6183.52  6172.34   0.18 │ 50103695138971  50029355021313   0.15 │ 3159556  3173852  -0.45 │
│                        coq-compcert │  311.26   310.62   0.21 │  2037676516379   2034234190668   0.17 │ 1146556  1103144   3.94 │
│                 rocq-mathcomp-field │  157.14   156.79   0.22 │  1181222395803   1180669594586   0.05 │ 1895320  1894132   0.06 │
│                            coq-corn │  684.71   682.95   0.26 │  4688916917564   4689091681735  -0.00 │  709608   711112  -0.21 │
│          coq-performance-tests-lite │  901.97   899.18   0.31 │  7265888345436   7266090761424  -0.00 │ 1939296  1939616  -0.02 │
│              rocq-mathcomp-solvable │   92.23    91.93   0.33 │   627602671256    627625512219  -0.00 │ 1037436  1037400   0.00 │
│                      rocq-equations │    9.01     8.98   0.33 │    63103607048     63082003775   0.03 │  400380   400284   0.02 │
│                   coq-metacoq-utils │   23.35    23.27   0.34 │   152319621713    152325011037  -0.00 │  582776   581144   0.28 │
│               coq-engine-bench-lite │  125.75   125.30   0.36 │   941112200188    938789964995   0.25 │ 1096316  1094624   0.15 │
│                           coq-verdi │   44.31    44.15   0.36 │   296972825994    296956754625   0.01 │  526320   526580  -0.05 │
│         coq-rewriter-perf-SuperFast │  480.30   478.15   0.45 │  3741928361781   3742157422702  -0.01 │ 1229380  1243964  -1.17 │
│                            coq-core │    2.94     2.88   2.08 │    19682974813     19680068124   0.01 │   96156    91900   4.63 │
└─────────────────────────────────────┴─────────────────────────┴───────────────────────────────────────┴─────────────────────────┘

```


INFO: failed to install 
coq-metacoq-template (in NEW)

coq-metacoq-erasure (dependency coq-metacoq-template failed)
coq-metacoq-translations (dependency coq-metacoq-template failed)

<details>
<summary>:turtle: Top 25 slow downs</summary>

<pre>┌─────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┐
│                                                            TOP 25 SLOW DOWNS                                                            │
│                                                                                                                                         │
│ OLD   NEW    DIFF   %DIFF    Ln                      FILE                                                                               │
├─────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┤
│ 40.5  43.7  3.2126   7.94%     2  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/ExtractionJsOfOCaml/fiat_crypto.v.html#L2">coq-fiat-crypto-with-bedrock/src/ExtractionJsOfOCaml/fiat_crypto.v.html</a>                               │
│ 42.3  44.8  2.4945   5.90%     3  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/ExtractionJsOfOCaml/WithBedrock/fiat_crypto.v.html#L3">coq-fiat-crypto-with-bedrock/src/ExtractionJsOfOCaml/WithBedrock/fiat_crypto.v.html</a>                   │
│ 42.4  44.8  2.4303   5.73%     3  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/ExtractionJsOfOCaml/bedrock2_fiat_crypto.v.html#L3">coq-fiat-crypto-with-bedrock/src/ExtractionJsOfOCaml/bedrock2_fiat_crypto.v.html</a>                      │
│  120   121  1.0371   0.86%    22  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Rewriter/Passes/ArithWithCasts.v.html#L22">coq-fiat-crypto-with-bedrock/src/Rewriter/Passes/ArithWithCasts.v.html</a>                                │
│  200   201  0.8693   0.43%     8  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-neural-net-interp-computed-lite/theories/MaxOfTwoNumbersSimpler/Computed/AllLogits.v.html#L8">coq-neural-net-interp-computed-lite/theories/MaxOfTwoNumbersSimpler/Computed/AllLogits.v.html</a>         │
│ 99.4   100  0.7548   0.76%   999  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-performance-tests-lite/src/fiat_crypto_via_setoid_rewrite_standalone.v.html#L999">coq-performance-tests-lite/src/fiat_crypto_via_setoid_rewrite_standalone.v.html</a>                       │
│ 99.6   100  0.7353   0.74%   968  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-performance-tests-lite/src/fiat_crypto_via_setoid_rewrite_standalone.v.html#L968">coq-performance-tests-lite/src/fiat_crypto_via_setoid_rewrite_standalone.v.html</a>                       │
│ 2.45  3.16  0.7052  28.78%    34  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Rewriter/Passes/ArithWithCasts.v.html#L34">coq-fiat-crypto-with-bedrock/src/Rewriter/Passes/ArithWithCasts.v.html</a>                                │
│ 64.4  65.0  0.5777   0.90%   609  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-bedrock2/bedrock2/src/bedrock2Examples/lightbulb.v.html#L609">coq-bedrock2/bedrock2/src/bedrock2Examples/lightbulb.v.html</a>                                           │
│ 17.8  18.3  0.4388   2.46%    31  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-engine-bench-lite/coq/PerformanceDemos/pattern.v.html#L31">coq-engine-bench-lite/coq/PerformanceDemos/pattern.v.html</a>                                             │
│ 42.2  42.6  0.3347   0.79%    50  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/Field/Synthesis/Examples/p224_64_new.v.html#L50">coq-fiat-crypto-with-bedrock/src/Bedrock/Field/Synthesis/Examples/p224_64_new.v.html</a>                  │
│ 16.6  16.9  0.2871   1.73%     6  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/rupicola/bedrock2/deps/riscv-coq/src/riscv/Proofs/DecodeEncodeCSR.v.html#L6">coq-fiat-crypto-with-bedrock/rupicola/bedrock2/deps/riscv-coq/src/riscv/Proofs/DecodeEncodeCSR.v.html</a> │
│ 21.0  21.2  0.2785   1.33%    40  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/PushButtonSynthesis/SolinasReductionReificationCache.v.html#L40">coq-fiat-crypto-with-bedrock/src/PushButtonSynthesis/SolinasReductionReificationCache.v.html</a>          │
│ 7.97  8.21  0.2326   2.92%  3024  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Assembly/EquivalenceProofs.v.html#L3024">coq-fiat-crypto-with-bedrock/src/Assembly/EquivalenceProofs.v.html</a>                                    │
│ 2.18  2.41  0.2283  10.46%    82  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-category-theory/Functor/Strong/Product.v.html#L82">coq-category-theory/Functor/Strong/Product.v.html</a>                                                     │
│ 38.5  38.8  0.2165   0.56%  1423  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/rupicola/bedrock2/compiler/src/compiler/FlatToRiscvFunctions.v.html#L1423">coq-fiat-crypto-with-bedrock/rupicola/bedrock2/compiler/src/compiler/FlatToRiscvFunctions.v.html</a>      │
│ 36.4  36.6  0.2134   0.59%   139  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-parsers/src/Parsers/Refinement/SharpenedJSON.v.html#L139">coq-fiat-parsers/src/Parsers/Refinement/SharpenedJSON.v.html</a>                                          │
│ 19.6  19.8  0.2053   1.05%    12  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fourcolor/theories/proof/job546to549.v.html#L12">coq-fourcolor/theories/proof/job546to549.v.html</a>                                                       │
│ 23.7  24.0  0.2012   0.85%    12  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fourcolor/theories/proof/job486to489.v.html#L12">coq-fourcolor/theories/proof/job486to489.v.html</a>                                                       │
│ 2.81  3.01  0.1929   6.86%   460  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/PERSubobjectClassifier.v.html#L460">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/PERSubobjectClassifier.v.html</a>         │
│ 3.18  3.37  0.1898   5.98%   480  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/ExponentialPER.v.html#L480">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/ExponentialPER.v.html</a>                 │
│ 3.44  3.62  0.1878   5.47%     6  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/rupicola/bedrock2/deps/riscv-coq/src/riscv/Proofs/DecodeEncodeM.v.html#L6">coq-fiat-crypto-with-bedrock/rupicola/bedrock2/deps/riscv-coq/src/riscv/Proofs/DecodeEncodeM.v.html</a>   │
│ 1.70  1.88  0.1874  11.04%   109  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-category-theory/Functor/Strong/Product.v.html#L109">coq-category-theory/Functor/Strong/Product.v.html</a>                                                     │
│ 3.71  3.89  0.1853   5.00%   189  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/PEREqualizers.v.html#L189">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/PEREqualizers.v.html</a>                  │
│ 3.33  3.51  0.1838   5.53%   776  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/PERSubobjectClassifier.v.html#L776">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/PERSubobjectClassifier.v.html</a>         │
└─────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┘</pre>


</details>

<details>
<summary>:rabbit2: Top 25 speed ups</summary>

<pre>┌────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┐
│                                                                TOP 25 SPEED UPS                                                                │
│                                                                                                                                                │
│  OLD    NEW     DIFF     %DIFF    Ln                      FILE                                                                                 │
├────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┤
│  64.0    63.3  -0.7295   -1.14%   609  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/rupicola/bedrock2/bedrock2/src/bedrock2Examples/lightbulb.v.html#L609">coq-fiat-crypto-with-bedrock/rupicola/bedrock2/bedrock2/src/bedrock2Examples/lightbulb.v.html</a>           │
│   173     172  -0.7038   -0.41%   233  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/rupicola/bedrock2/deps/riscv-coq/src/riscv/Proofs/DecodeByExtension.v.html#L233">coq-fiat-crypto-with-bedrock/rupicola/bedrock2/deps/riscv-coq/src/riscv/Proofs/DecodeByExtension.v.html</a> │
│  8.76    8.23  -0.5246   -5.99%  1331  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-mathcomp-odd-order/theories/PFsection9.v.html#L1331">coq-mathcomp-odd-order/theories/PFsection9.v.html</a>                                                       │
│  20.8    20.3  -0.5209   -2.50%   289  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/Logic/Universal.v.html#L289">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/Logic/Universal.v.html</a>                  │
│  21.9    21.4  -0.4827   -2.20%    49  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Curves/Weierstrass/AffineProofs.v.html#L49">coq-fiat-crypto-with-bedrock/src/Curves/Weierstrass/AffineProofs.v.html</a>                                 │
│  56.6    56.2  -0.4717   -0.83%   731  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JacobianCoZ.v.html#L731">coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JacobianCoZ.v.html</a>                                   │
│  27.1    26.6  -0.4279   -1.58%   149  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/End2End/X25519/GarageDoorTop.v.html#L149">coq-fiat-crypto-with-bedrock/src/Bedrock/End2End/X25519/GarageDoorTop.v.html</a>                            │
│  35.9    35.6  -0.3506   -0.98%   974  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JoyeLadder.v.html#L974">coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JoyeLadder.v.html</a>                                    │
│  8.62    8.29  -0.3290   -3.82%   925  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-mathcomp-odd-order/theories/PFsection4.v.html#L925">coq-mathcomp-odd-order/theories/PFsection4.v.html</a>                                                       │
│  29.7    29.4  -0.3285   -1.11%   974  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JoyeLadder.v.html#L974">coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JoyeLadder.v.html</a>                                    │
│  29.6    29.2  -0.3281   -1.11%   673  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JoyeLadder.v.html#L673">coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JoyeLadder.v.html</a>                                    │
│   236     236  -0.2736   -0.12%   141  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/UnsaturatedSolinasHeuristics/Tests.v.html#L141">coq-fiat-crypto-with-bedrock/src/UnsaturatedSolinasHeuristics/Tests.v.html</a>                              │
│  3.77    3.56  -0.2160   -5.72%  1198  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-mathcomp-odd-order/theories/PFsection9.v.html#L1198">coq-mathcomp-odd-order/theories/PFsection9.v.html</a>                                                       │
│  13.2    13.0  -0.2084   -1.58%   571  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-mathcomp-odd-order/theories/PFsection9.v.html#L571">coq-mathcomp-odd-order/theories/PFsection9.v.html</a>                                                       │
│  26.2    26.0  -0.2070   -0.79%    12  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fourcolor/theories/proof/job190to206.v.html#L12">coq-fourcolor/theories/proof/job190to206.v.html</a>                                                         │
│  7.60    7.40  -0.2040   -2.68%   604  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/StructureEnrichedColimits.v.html#L604">coq-unimath/UniMath/CategoryTheory/EnrichedCats/Colimits/Examples/StructureEnrichedColimits.v.html</a>      │
│  3.15    2.95  -0.2026   -6.42%   509  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/ExponentialLam.v.html#L509">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/ExponentialLam.v.html</a>                   │
│  19.2    19.0  -0.1963   -1.02%   708  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Rewriter/RulesProofs.v.html#L708">coq-fiat-crypto-with-bedrock/src/Rewriter/RulesProofs.v.html</a>                                            │
│  9.57    9.39  -0.1842   -1.92%   751  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JacobianCoZ.v.html#L751">coq-fiat-crypto-with-bedrock/src/Bedrock/Secp256k1/JacobianCoZ.v.html</a>                                   │
│ 0.209  0.0252  -0.1834  -87.92%   104  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/rocq-mathcomp-field/field/algnum.v.html#L104">rocq-mathcomp-field/field/algnum.v.html</a>                                                                 │
│  32.6    32.4  -0.1809   -0.56%    12  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fourcolor/theories/proof/job439to465.v.html#L12">coq-fourcolor/theories/proof/job439to465.v.html</a>                                                         │
│  79.9    79.7  -0.1797   -0.22%    48  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Curves/Weierstrass/AffineProofs.v.html#L48">coq-fiat-crypto-with-bedrock/src/Curves/Weierstrass/AffineProofs.v.html</a>                                 │
│  4.76    4.59  -0.1707   -3.59%   116  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/ExponentialEqs.v.html#L116">coq-unimath/UniMath/CategoryTheory/Hyperdoctrines/PartialEqRels/ExponentialEqs.v.html</a>                   │
│  22.7    22.6  -0.1697   -0.75%    85  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-fiat-crypto-with-bedrock/src/Curves/Montgomery/AffineProofs.v.html#L85">coq-fiat-crypto-with-bedrock/src/Curves/Montgomery/AffineProofs.v.html</a>                                  │
│  14.0    13.9  -0.1637   -1.17%    61  <a href="https://coq.gitlabpages.inria.fr/-/coq/-/jobs/5767921/artifacts/_bench/html/coq-rewriter/src/Rewriter/Rewriter/Examples/PrefixSums.v.html#L61">coq-rewriter/src/Rewriter/Rewriter/Examples/PrefixSums.v.html</a>                                           │
└────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────┘</pre>


</details>

- [:chair: GitLab Bench Job](https://gitlab.inria.fr/coq/coq/-/jobs/5767921)
author_association: CONTRIBUTOR
user: login: ppedrot
created_at: 2025-05-21T07:57:27Z
body: Nothing out of the ordinary in the bench, as expected somehow. We don't really test extraction in the CI, at least it's never a bottleneck and I'm not even sure we profile it properly.
author_association: MEMBER
user: login: ppedrot
created_at: 2025-05-21T11:51:24Z
body: @SkySkimmer nitpicks addressed
author_association: MEMBER
user: login: SkySkimmer
created_at: 2025-05-22T08:20:54Z
body: @coqbot merge now
author_association: CONTRIBUTOR