From e6a8fcaec0ca21cd7abb4902d40e498cb19f2372 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 23 Feb 2026 17:28:39 +0100 Subject: [PATCH 01/36] bignat part 1 --- dev/top_printers.ml | 3 + engine/eConstr.ml | 11 ++-- engine/eConstr.mli | 3 + engine/evd.ml | 2 +- engine/namegen.ml | 2 + engine/termops.ml | 6 +- interp/constrextern.ml | 5 ++ interp/impargs.ml | 2 +- interp/notation.ml | 3 + interp/notation_ops.ml | 3 +- interp/primNotations.ml | 6 ++ kernel/cClosure.ml | 64 +++++++++++++++---- kernel/cClosure.mli | 3 + kernel/cPrimitives.ml | 2 + kernel/cPrimitives.mli | 1 + kernel/constr.ml | 29 ++++++--- kernel/constr.mli | 4 ++ kernel/conversion.ml | 36 ++++++++++- kernel/dune | 2 +- kernel/environ.ml | 13 ++++ kernel/environ.mli | 3 + kernel/genlambda.ml | 14 ++-- kernel/genlambda.mli | 1 + kernel/hConstr.ml | 3 + kernel/inductive.ml | 14 ++-- kernel/inferCumulativity.ml | 1 + kernel/nativecode.ml | 4 +- kernel/primred.ml | 6 ++ kernel/reduction.ml | 8 +-- kernel/relevanceops.ml | 2 +- kernel/retroknowledge.ml | 2 + kernel/retroknowledge.mli | 1 + kernel/safe_typing.ml | 7 ++ kernel/typeops.ml | 12 ++++ kernel/typeops.mli | 1 + kernel/vars.ml | 4 +- kernel/vmbytegen.ml | 2 + plugins/extraction/extraction.ml | 3 +- .../funind/functional_principles_proofs.ml | 3 +- plugins/funind/gen_principle.ml | 2 +- plugins/funind/glob_term_to_relation.ml | 5 +- plugins/funind/glob_termops.ml | 9 +-- plugins/funind/recdef.ml | 6 +- plugins/ltac2/tac2core.ml | 1 + plugins/ssrmatching/ssrmatching.ml | 4 +- pretyping/cbv.ml | 32 ++++++++-- pretyping/constr_matching.ml | 2 +- pretyping/detyping.ml | 2 + pretyping/evarconv.ml | 23 +++++-- pretyping/glob_ops.ml | 9 +-- pretyping/glob_term.mli | 1 + pretyping/heads.ml | 2 +- pretyping/keys.ml | 6 ++ pretyping/patternops.ml | 5 +- pretyping/pretyping.ml | 12 ++++ pretyping/pretyping.mli | 1 + pretyping/reductionops.ml | 6 +- pretyping/retyping.ml | 3 +- pretyping/typing.ml | 10 ++- pretyping/typing.mli | 1 + pretyping/unification.ml | 8 ++- tactics/autorewrite.ml | 1 + tactics/btermdn.ml | 1 + tactics/cbn.ml | 2 + tactics/hints.ml | 1 + test-suite/success/bignat.v | 3 + vernac/assumptions.ml | 2 +- vernac/auto_ind_decl.ml | 6 +- vernac/vernacentries.ml | 1 + 69 files changed, 363 insertions(+), 95 deletions(-) create mode 100644 test-suite/success/bignat.v diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 5109e6c10e75..c3982318303a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -402,6 +402,7 @@ let constr_display csr = ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"," ^(array_display bl)^")" + | Nat n -> "Nat("^Z.to_string n^")" | Int i -> "Int("^(Uint63.to_string i)^")" | Float f -> @@ -563,6 +564,8 @@ let print_pure_constr csr = print_cut(); done in print_string"{"; print_fix (); print_string"}" + | Nat n -> + print_string ("Nat("^(Z.to_string n)^")") | Int i -> print_string ("Int("^(Uint63.to_string i)^")") | Float f -> diff --git a/engine/eConstr.ml b/engine/eConstr.ml index f31e880d4529..e718d1d78834 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -99,7 +99,7 @@ struct (* Despite the type, the sparse list contains no default element *) SList.Skip.iter (f h) args | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _ -> () + | Construct _ | Nat _ | Int _ | Float _ | String _ -> () | Cast (c, _, t) -> f h c; f h t | Prod (_, t, c) -> f h t; f (liftn_handle 1 h) c | Lambda (_, t, c) -> f h t; f (liftn_handle 1 h) c @@ -128,7 +128,7 @@ struct (* Despite the type, the sparse list contains no default element *) SList.Skip.iter (f l h) args | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _ -> () + | Construct _ | Nat _ | Int _ | Float _ | String _ -> () | Cast (c, _, t) -> f l h c; f l h t | Prod (_, t, c) -> f l h t; f (g l) (liftn_handle 1 h) c | Lambda (_, t, c) -> f l h t; f (g l) (liftn_handle 1 h) c @@ -209,6 +209,7 @@ let mkCoFix f = of_kind (CoFix f) let mkProj (p, r, c) = of_kind (Proj (p, r, c)) let mkArrow t1 r t2 = of_kind (Prod (make_annot Anonymous r, t1, t2)) let mkArrowR t1 t2 = mkArrow t1 ERelevance.relevant t2 +let mkNat n = of_kind (Nat n) let mkInt i = of_kind (Int i) let mkFloat f = of_kind (Float f) let mkString s = of_kind (String s) @@ -659,11 +660,13 @@ let contract_case env _sigma (ci, (p,r), iv, c, bl) = let bl = of_branches bl in (ci, u, pms, p, iv, c, bl) +let unfold_nat env n = of_constr @@ Environ.unfold_nat env n + let iter_with_full_binders env sigma g f n c = let open Context.Rel.Declaration in match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> () + | Construct _ | Nat _ | Int _ | Float _ | String _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c @@ -1252,7 +1255,7 @@ let kind_of_type sigma t = match kind sigma t with | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) - | (Lambda _ | Construct _ | Int _ | Float _ | String _ | Array _) -> failwith "Not a type" + | (Lambda _ | Construct _ | Nat _ | Int _ | Float _ | String _ | Array _) -> failwith "Not a type" module Unsafe = struct diff --git a/engine/eConstr.mli b/engine/eConstr.mli index ef42c242fa35..28489b92bd12 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -179,6 +179,7 @@ val mkFix : (t, t, ERelevance.t) pfixpoint -> t val mkCoFix : (t, t, ERelevance.t) pcofixpoint -> t val mkArrow : t -> ERelevance.t -> t -> t val mkArrowR : t -> t -> t +val mkNat : Z.t -> t val mkInt : Uint63.t -> t val mkFloat : Float64.t -> t val mkString : Pstring.t -> t @@ -463,6 +464,8 @@ val expand_branch : Environ.env -> Evd.evar_map -> val contract_case : Environ.env -> Evd.evar_map -> (t,t,ERelevance.t) Inductive.pexpanded_case -> case +val unfold_nat : Environ.env -> Z.t -> constr + (** {5 Extra} *) val of_existential : Constr.existential -> existential diff --git a/engine/evd.ml b/engine/evd.ml index bb675f50d72a..8a2a7cf80cf6 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1598,7 +1598,7 @@ let rec kind sigma h c = match Constr.kind c with end | Meta _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ | CoFix _ | Proj _ -| Int _ | Float _ | String _ | Array _ as c0 -> +| Nat _ | Int _ | Float _ | String _ | Array _ as c0 -> (h, c0) let expand0 sigma h c = diff --git a/engine/namegen.ml b/engine/namegen.ml index 108ac00b9013..78c176f90185 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -119,6 +119,7 @@ let head_name sigma c = (* Find the head constant of a constr if any *) | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) | Cast (c,_,_) | App (c,_) -> hdrec c | Proj (kn,_,_) -> Some (Constant.label (Projection.constant kn)) + | Nat n -> Some (Nametab.basename_of_global (ConstructRef (ctor_of_nat (Global.env()) n))) | Const _ | Ind _ | Construct _ | Var _ as c -> Some (Nametab.basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> @@ -156,6 +157,7 @@ let hdchar env sigma c = | Const (kn,_) -> lowercase_first_char (Constant.label kn) | Ind (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.IndRef x)) with Not_found when !Flags.in_debugger -> "zz") | Construct (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.ConstructRef x)) with Not_found when !Flags.in_debugger -> "zz") + | Nat n -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.ConstructRef (ctor_of_nat env n))) with _ when !Flags.in_debugger -> "zz") | Var id -> lowercase_first_char id | Sort s -> sort_hdchar (ESorts.kind sigma s) | Rel n -> diff --git a/engine/termops.ml b/engine/termops.ml index 8ba3fcb0182d..85b8fdb454be 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -546,7 +546,7 @@ let map_constr_with_binders_left_to_right env sigma g f l c = let open EConstr in match EConstr.kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> c + | Construct _ | Nat _ | Int _ | Float _ | String _) -> c | Cast (b,k,t) -> let b' = f l b in let t' = f l t in @@ -622,7 +622,7 @@ let map_constr_with_full_binders env sigma g f l cstr = let open EConstr in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> cstr + | Construct _ | Nat _ | Int _ | Float _ | String _) -> cstr | Cast (c,k, t) -> let c' = f l c in let t' = f l t in @@ -694,7 +694,7 @@ let fold_constr_with_full_binders env sigma g f n acc c = let open EConstr.Vars in let open Context.Rel.Declaration in match EConstr.kind sigma c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> acc + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _ -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c diff --git a/interp/constrextern.ml b/interp/constrextern.ml index b8b9a51d731b..6c077fd98d1f 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1041,6 +1041,11 @@ let rec extern depth0 inctx scopes (eenv:extern_env) r = let c = extern depth true (fst scopes,(scl, snd (snd scopes))) eenv c in CCast (c, k, c') + | GNat n -> + extern_prim_token_delimiter_if_required + (Number NumTok.(Signed.of_bigint CHex n)) + "nat" "nat_scope" (snd scopes) + | GInt i -> extern_prim_token_delimiter_if_required (Number NumTok.(Signed.of_bigint CHex (Z.of_int64 (Uint63.to_int64 i)))) diff --git a/interp/impargs.ml b/interp/impargs.ml index e0df324054a9..ce8ecc3365bb 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -240,7 +240,7 @@ let rec is_rigid_head sigma t = match kind sigma t with | Fix ((fi,i),_) -> is_rigid_head sigma (args.(fi.(i))) | _ -> is_rigid_head sigma f) | Lambda _ | LetIn _ | Construct _ | CoFix _ | Fix _ - | Prod _ | Meta _ | Cast _ | Int _ | Float _ | String _ | Array _ -> assert false + | Prod _ | Meta _ | Cast _ | Nat _ | Int _ | Float _ | String _ | Array _ -> assert false let is_rigid env sigma t = let open Context.Rel.Declaration in diff --git a/interp/notation.ml b/interp/notation.ml index d1327f62aaf7..7af6ea202e35 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -341,6 +341,9 @@ let glob_prim_constr_key c = match DAst.get c with | _ -> None end | GProj ((cst,_), _, _) -> Some (canonical_gr (GlobRef.ConstRef cst)) + | GNat n -> + let c = Environ.ctor_of_nat (Global.env()) n in + Some (canonical_gr (GlobRef.ConstructRef c)) | _ -> None let check_required_module ?loc sc (sp,d) = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 2f5d3bec7801..c4225372ce9b 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -700,6 +700,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = if Option.is_empty k then forgetful := { !forgetful with forget_volatile_cast = true }; NCast (aux c, k, aux t) | GSort s -> NSort s + | GNat _ -> failwith "TODO" | GInt i -> NInt i | GFloat f -> NFloat f | GString s -> NString s @@ -1629,7 +1630,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GProj _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GGenarg _ - | GCast _ | GInt _ | GFloat _ | GString _ | GArray _), _ -> raise No_match + | GCast _ | GNat _ | GInt _ | GFloat _ | GString _ | GArray _), _ -> raise No_match and match_in_type u alp metas sigma t = function | None -> sigma diff --git a/interp/primNotations.ml b/interp/primNotations.ml index 4fc27fad0f95..74bd8a7088df 100644 --- a/interp/primNotations.ml +++ b/interp/primNotations.ml @@ -187,6 +187,7 @@ type 'a token_kind = | TConst of Constant.t * 'a list | TInd of inductive * 'a list | TConstruct of constructor * 'a list +| TNat of Z.t | TInt of Uint63.t | TFloat of Float64.t | TString of Pstring.t @@ -216,6 +217,7 @@ let kind c = | Float f -> TFloat f | String s -> TString s | Array (_, t, u, v) -> TArray (t, u, v) + | Nat n -> TNat n | Rel _ | Meta _ | Evar _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Case _ | Fix _ | CoFix _ -> TOther @@ -299,6 +301,7 @@ let rec check_glob env sigma g c = try List.fold_left2_map (check_glob env) sigma gcl (Array.to_list gc'a) with Invalid_argument _ -> raise NotAValidPrimToken in sigma, mkApp (c, Array.of_list cl) + | Glob_term.GNat n, Constr.Nat n' when Z.equal n n' -> sigma, mkNat n | Glob_term.GInt i, Constr.Int i' when Uint63.equal i i' -> sigma, mkInt i | Glob_term.GFloat f, Constr.Float f' when Float64.equal f f' -> sigma, mkFloat f | Glob_term.GString s, Constr.String s' when Pstring.equal s s' -> sigma, mkString s @@ -362,6 +365,7 @@ let rec constr_of_glob to_post post env sigma g = let sigma,cl = aux sigma a gcl in sigma,mkApp (c, Array.of_list cl) end + | Glob_term.GNat n -> sigma, mkNat n | Glob_term.GInt i -> sigma, mkInt i | Glob_term.GFloat f -> sigma, mkFloat f | Glob_term.GString s -> sigma, mkString s @@ -390,6 +394,7 @@ let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.ConstRef c, None)) | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.IndRef ind, None)) | Var id -> DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) + | Nat n -> DAst.make ?loc (Glob_term.GNat n) | Int i -> DAst.make ?loc (Glob_term.GInt i) | Float f -> DAst.make ?loc (Glob_term.GFloat f) | String s -> DAst.make ?loc (Glob_term.GString s) @@ -425,6 +430,7 @@ let rec glob_of_token token_kind ?loc env sigma c = match TokenValue.kind c with let ce = DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) in let cel = List.map (glob_of_token token_kind ?loc env sigma) l in mkGApp ?loc ce cel + | TNat n -> DAst.make ?loc (GNat n) | TInt i -> DAst.make ?loc (Glob_term.GInt i) | TFloat f -> DAst.make ?loc (Glob_term.GFloat f) | TString s -> DAst.make ?loc (Glob_term.GString s) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 95d947515318..44877a9a6b03 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -96,6 +96,7 @@ and fterm = | FProd of Name.t binder_annot * fconstr * constr * usubs | FLetIn of Name.t binder_annot * fconstr * fconstr * constr * usubs | FEvar of Evar.t * constr list * usubs * evar_repack + | FNat of Z.t | FInt of Uint63.t | FFloat of Float64.t | FString of Pstring.t @@ -236,7 +237,7 @@ let usubs_shft (n,(e,u)) = subs_shft (n, e), u when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with - | (FInd _|FConstruct (_,[||])|FFlex(ConstKey _|VarKey _)|FInt _|FFloat _|FString _|FIrrelevant) -> ft + | (FInd _|FConstruct (_,[||])|FFlex(ConstKey _|VarKey _)|FNat _|FInt _|FFloat _|FString _|FIrrelevant) -> ft | FRel i -> {mark=ft.mark;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {mark=Cstr; term=FLambda(k,tys,f,usubs_shft(n,e))} | FFix(fx,e) -> @@ -322,6 +323,8 @@ let destFLambda clos_fun t = (usubst_binder e na,clos_fun e ty,{mark=t.mark;term=FLambda(n-1,tys,b,usubs_lift e)}) | _ -> assert false +let mkFNat n = {mark = Cstr; term = FNat n} + (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos (e:usubs) t = @@ -335,6 +338,7 @@ let mk_clos (e:usubs) t = | Meta _ -> {mark = Ntrl; term = FAtom t } | Ind kn -> {mark = Ntrl; term = FInd (usubst_punivs e kn) } | Construct kn -> {mark = Cstr; term = FConstruct (usubst_punivs e kn,[||]) } + | Nat n -> mkFNat n | Int i -> {mark = Cstr; term = FInt i} | Float f -> {mark = Cstr; term = FFloat f} | String s -> {mark = Cstr; term = FString s} @@ -594,6 +598,8 @@ let rec to_constr lfts v = repack (ev, List.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a + | FNat n -> + Constr.mkNat n | FInt i -> Constr.mkInt i | FFloat f -> @@ -939,6 +945,15 @@ let get_branch infos ci pms cterm br e = let ext = push (Array.length args - 1) [] ctx in (br, usubs_consv (Array.rev_of_list ext) e) +let get_nat_branch n br e = + if Z.equal n Z.zero then + let _nas, br = br.(0) in + br, e + else + let _nas, br = br.(1) in + let n = Z.sub n Z.one in + br, usubs_cons {mark = Cstr; term = FNat n} e + let has_valid_relevance u ind_relevance flds = let ind_relevance = UVars.subst_instance_relevance u ind_relevance in let flds = Array.map (UVars.subst_instance_relevance u) flds in @@ -1408,6 +1423,7 @@ let rec knh info m stk = | None -> (m, stk) | Some s -> knh info c (s :: zupdate info m stk)) | FConstruct _ -> strip_update_shift_absorb_app m stk + | FNat _ -> strip_update_shift_absorb_app m stk (* cases where knh stops *) | (FFlex _|FLetIn _|FEvar _|FCaseInvert _|FIrrelevant| @@ -1447,7 +1463,7 @@ and knht info e t stk = | Some s -> knht info e c (s :: stk) end | Construct _ -> knh info (mk_clos e t) stk - | (Ind _|Const _|Var _|Meta _ | Sort _ | Int _|Float _|String _) -> (mk_clos e t, stk) + | (Ind _|Const _|Var _|Meta _ | Sort _ | Nat _|Int _|Float _|String _) -> (mk_clos e t, stk) | CoFix cfx -> { mark = Cstr; term = FCoFix (cfx,e) }, stk | Lambda _ -> { mark = Cstr ; term = mk_lambda e t }, stk @@ -1917,22 +1933,22 @@ let rec knr info tab ~pat_state m stk = let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then - (match [@ocaml.warning "-4"] m, stk with - | (_, Zapp _ :: _) -> assert false (* knh *) - | (c, ZcaseT(ci,_,pms,_,br,e)::s) when use_match -> + (match [@ocaml.warning "-4"] stk with + | (Zapp _ :: _) -> assert false (* knh *) + | (ZcaseT(ci,_,pms,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); (* instance on the case and instance on the constructor are compatible by typing *) - let (br, e) = get_branch info ci pms c br e in + let (br, e) = get_branch info ci pms m br e in knit info tab ~pat_state e br s - | (rarg, Zfix(fx,par)::s) when use_fix -> - let stk' = par @ append_stack [|rarg|] s in + | (Zfix(fx,par)::s) when use_fix -> + let stk' = par @ append_stack [|m|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info tab ~pat_state fxe fxbd stk' - | (m, Zproj (p,_)::s) when use_match -> + | (Zproj (p,_)::s) when use_match -> let rargs = drop_parameters (Projection.Repr.npars p) m in let rarg = rargs.(Projection.Repr.arg p) in kni info tab ~pat_state rarg s - | (m, s) -> + | s -> if is_irrelevant_constructor info c then knr_ret info tab ~pat_state (mk_irrelevant, skip_irrelevant_stack info stk) else @@ -1940,6 +1956,26 @@ let rec knr info tab ~pat_state m stk = else if is_irrelevant_constructor info c then knr_ret info tab ~pat_state (mk_irrelevant, skip_irrelevant_stack info stk) else + knr_ret info tab ~pat_state (m, stk) + | FNat n -> + let use_match = red_set info.i_flags fMATCH in + let use_fix = red_set info.i_flags fFIX in + if use_match || use_fix then + (match [@ocaml.warning "-4"] stk with + | (Zapp _ :: _) -> assert false (* knh *) + | (ZcaseT(ci,_,_,_,br,e)::s) when use_match -> + assert (ci.ci_npar>=0); + (* instance on the case and instance on the constructor are compatible by typing *) + let (br, e) = get_nat_branch n br e in + knit info tab ~pat_state e br s + | (Zfix(fx,par)::s) when use_fix -> + let stk' = par @ append_stack [|m|] s in + let (fxe,fxbd) = contract_fix_vect fx.term in + knit info tab ~pat_state fxe fxbd stk' + | (Zproj _::_) -> + assert false + | s -> knr_ret info tab ~pat_state (m,s)) + else knr_ret info tab ~pat_state (m, stk) | FCoFix ((i, (lna, _, _)), e) -> if is_irrelevant info (usubst_relevance e (lna.(i)).binder_relevance) then @@ -2057,7 +2093,7 @@ let kh info tab v stk = fapp_stack(kni info tab v stk) calls itself recursively. *) let is_val v = match v.term with -| FAtom _ | FRel _ | FInd _ | FConstruct (_,[||]) | FInt _ | FFloat _ | FString _ -> true +| FAtom _ | FRel _ | FInd _ | FConstruct (_,[||]) | FNat _ | FInt _ | FFloat _ | FString _ -> true | FFlex _ -> v.mark == Ntrl | FConstruct _ | FApp _ | FProj _ | FFix _ | FCoFix _ | FCaseT _ | FCaseInvert _ | FLambda _ | FProd _ | FLetIn _ | FEvar _ | FArray _ | FLIFT _ | FCLOS _ -> false @@ -2086,7 +2122,7 @@ and klt info tab e t = match kind t with if hd' == hd && args' == args then t else mkApp (hd', args') | Var _ | Const _ | CoFix _ | Lambda _ | Fix _ | Prod _ | Evar _ | Case _ - | Cast _ | LetIn _ | Proj _ | Array _ | Rel _ | Meta _ | Sort _ | Int _ + | Cast _ | LetIn _ | Proj _ | Array _ | Rel _ | Meta _ | Sort _ | Nat _ | Int _ | Float _ | String _ -> let share = info.i_cache.i_share in let (nm,s) = knit info tab e t [] in @@ -2112,7 +2148,7 @@ and klt info tab e t = match kind t with let (nm,s) = knit info tab e t [] in let () = if share then ignore (fapp_stack (nm, s)) in (* to unlock Zupdates! *) zip_term info tab (norm_head info tab nm) s -| Meta _ | Sort _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> +| Meta _ | Sort _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _ -> subst_instance_constr (snd e) t (* no redex: go up for atoms and already normalized terms, go down @@ -2162,7 +2198,7 @@ and norm_head info tab m = mkArray (u, a, def, ty) | FConstruct (c,args) -> mkApp (mkConstructU c, Array.map (kl info tab) args) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ - | FApp _ | FCaseT _ | FCaseInvert _ | FLIFT _ | FCLOS _ | FInt _ + | FApp _ | FCaseT _ | FCaseInvert _ | FLIFT _ | FCLOS _ | FNat _ | FInt _ | FFloat _ | FString _ -> term_of_fconstr m | FIrrelevant -> assert false (* only introduced when converting *) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index cc31068e6948..0e9b079878bd 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -48,6 +48,7 @@ type fterm = | FProd of Name.t binder_annot * fconstr * constr * usubs | FLetIn of Name.t binder_annot * fconstr * fconstr * constr * usubs | FEvar of Evar.t * constr list * usubs * evar_repack + | FNat of Z.t | FInt of Uint63.t | FFloat of Float64.t | FString of Pstring.t @@ -108,6 +109,8 @@ val inject : constr -> fconstr val mk_clos : usubs -> constr -> fconstr val mk_clos_vect : usubs -> constr array -> fconstr array +val mkFNat : Z.t -> fconstr + val zip : fconstr -> stack -> fconstr val fterm_of : fconstr -> fterm diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 830a122ddd2d..433901e7a76a 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -295,6 +295,7 @@ type 'a prim_type = | PT_array : (Instance.t * ind_or_type) prim_type and 'a prim_ind = + | PIT_nat : unit prim_ind | PIT_bool : unit prim_ind | PIT_carry : ind_or_type prim_ind | PIT_pair : (ind_or_type * ind_or_type) prim_ind @@ -561,6 +562,7 @@ type op_or_type = | OT_const of const let prim_ind_to_string (type a) (p : a prim_ind) = match p with + | PIT_nat -> "nat" | PIT_bool -> "bool" | PIT_carry -> "carry" | PIT_pair -> "pair" diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index c2686ada0160..c8a1aed16471 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -109,6 +109,7 @@ type 'a prim_type = | PT_array : (UVars.Instance.t * ind_or_type) prim_type and 'a prim_ind = + | PIT_nat : unit prim_ind | PIT_bool : unit prim_ind | PIT_carry : ind_or_type prim_ind | PIT_pair : (ind_or_type * ind_or_type) prim_ind diff --git a/kernel/constr.ml b/kernel/constr.ml index e8896c649382..4c418d411725 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -112,6 +112,7 @@ type ('constr, 'types, 'sort, 'univs, 'r) kind_of_term = | Float of Float64.t | String of Pstring.t | Array of 'univs * 'constr array * 'constr * 'types + | Nat of Z.t (* constr is the fixpoint of the previous type. *) type t = T of (t, t, Sorts.t, Instance.t, Sorts.relevance) kind_of_term [@@unboxed] @@ -360,6 +361,7 @@ let of_kind = function | Sort Sorts.SProp -> mkSProp | Sort Sorts.Prop -> mkProp | Sort Sorts.Set -> mkSet +| Nat i as k -> assert (Z.leq Z.zero i); T k | k -> T k (* Construct a type *) @@ -455,6 +457,8 @@ let mkRef (gr,u) = let open GlobRef in match gr with | ConstructRef c -> mkConstructU (c,u) | VarRef x -> mkVar x +let mkNat i = of_kind @@ Nat i + (* Constructs a primitive integer *) let mkInt i = of_kind @@ Int i @@ -488,7 +492,7 @@ let fold_invert f acc = function let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> acc + | Construct _ | Nat _ | Int _ | Float _ | String _) -> acc | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c @@ -516,7 +520,7 @@ let iter_invert f = function let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> () + | Construct _ | Nat _ | Int _ | Float _ | String _) -> () | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c @@ -538,7 +542,7 @@ let iter f c = match kind c with let iter_with_binders g f n c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> () + | Construct _ | Nat _ | Int _ | Float _ | String _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c @@ -571,7 +575,7 @@ let iter_with_binders g f n c = match kind c with let fold_constr_with_binders g f n acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> acc + | Construct _ | Nat _ | Int _ | Float _ | String _) -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (_na,t,c) -> f (g n) (f n acc t) c | Lambda (_na,t,c) -> f (g n) (f n acc t) c @@ -635,7 +639,7 @@ let map_invert f = function let map f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> c + | Construct _ | Nat _ | Int _ | Float _ | String _) -> c | Cast (b,k,t) -> let b' = f b in let t' = f t in @@ -720,7 +724,7 @@ let fold_map_return_predicate f accu (p,r as v) = let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> accu, c + | Construct _ | Nat _ | Int _ | Float _ | String _) -> accu, c | Cast (b,k,t) -> let accu, b' = f accu b in let accu, t' = f accu t in @@ -788,7 +792,7 @@ let fold_map f accu c = match kind c with let map_with_binders g f l c0 = match kind c0 with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ | Float _ | String _) -> c0 + | Construct _ | Nat _ | Int _ | Float _ | String _) -> c0 | Cast (c, k, t) -> let c' = f l c in let t' = f l t in @@ -904,6 +908,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq_evars eq le | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 + | Nat i1, Nat i2 -> Z.equal i1 i2 (* XXX nat vs constructor? *) | Int i1, Int i2 -> Uint63.equal i1 i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -942,7 +947,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq_evars eq le eq 0 def1 def2 && eq 0 ty1 ty2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _ | Int _ | Float _ | String _ | Array _), _ -> false + | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -1074,6 +1079,8 @@ let constr_ord_int f t1 t2 = | CoFix _, _ -> -1 | _, CoFix _ -> 1 | Proj (p1,_r1,c1), Proj (p2,_r2,c2) -> compare [(Projection.CanOrd.compare, p1, p2); (f, c1, c2)] | Proj _, _ -> -1 | _, Proj _ -> 1 + | Nat i1, Nat i2 -> Z.compare i1 i2 + | Nat _, _ -> -1 | _, Nat _ -> 1 | Int i1, Int i2 -> Uint63.compare i1 i2 | Int _, _ -> -1 | _, Int _ -> 1 | Float f1, Float f2 -> Float64.total_compare f1 f2 @@ -1179,6 +1186,7 @@ let hasheq_kind t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 + | Nat i1, Nat i2 -> Z.equal i1 i2 | Int i1, Int i2 -> i1 == i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -1186,7 +1194,7 @@ let hasheq_kind t1 t2 = u1 == u2 && def1 == def2 && ty1 == ty2 && array_eqeq t1 t2 | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ - | Fix _ | CoFix _ | Int _ | Float _ | String _ | Array _), _ -> false + | Fix _ | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _), _ -> false let hasheq t1 t2 = hasheq_kind (kind t1) (kind t2) @@ -1255,6 +1263,7 @@ let rec hash t = | String s -> combinesmall 20 (Pstring.hash s) | Array(u,t,def,ty) -> combinesmall 21 (combine4 (Instance.hash u) (hash_term_array t) (hash def) (hash ty)) + | Nat i -> combinesmall 22 (Z.hash i) and hash_invert = function | NoInvert -> 0 @@ -1446,6 +1455,7 @@ let rec hash_term (t : t) : int * (constr,constr,_,_,_) kind_of_term = let hty, ty = sh_rec ty in let h = combine4 hu ht hdef hty in (combinesmall 21 h, Array(u,t,def,ty)) + | Nat i as t -> combinesmall 22 (Z.hash i), t and sh_invert civ iv = match civ, iv with | NoInvert, NoInvert -> 0, NoInvert @@ -1595,6 +1605,7 @@ let rec debug_print c = Name.print na.binder_name ++ str":" ++ debug_print ty ++ cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ str"}") + | Nat i -> str "Nat(" ++ str (Z.to_string i) ++ str ")" | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" | Float i -> str"Float("++str (Float64.to_string i) ++ str")" | String s -> str"String("++str (Printf.sprintf "%S" (Pstring.to_string s)) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index 53e10fccb545..502ec4852264 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -73,6 +73,9 @@ val mkVar : Id.t -> constr (** Constructs a machine integer *) val mkInt : Uint63.t -> constr +(** Construct an optimized nat. Must be >= 0. *) +val mkNat : Z.t -> constr + (** Constructs an array *) val mkArray : UVars.Instance.t * constr array * constr * types -> constr @@ -291,6 +294,7 @@ type ('constr, 'types, 'sort, 'univs, 'r) kind_of_term = | Array of 'univs * 'constr array * 'constr * 'types (** [Array (u,vals,def,t)] is an array of [vals] in type [t] with default value [def]. [u] is a universe containing [t]. *) + | Nat of Z.t (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative diff --git a/kernel/conversion.ml b/kernel/conversion.ml index aa4c0bd3a1a4..04b8628ee93a 100644 --- a/kernel/conversion.ml +++ b/kernel/conversion.ml @@ -317,6 +317,7 @@ let rec compare_under e1 c1 e2 c2 = end | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 + | Nat i1, Nat i2 -> Z.equal i1 i2 (* XXX also try to fast check nat vs constructor? *) | Int i1, Int i2 -> Uint63.equal i1 i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -358,7 +359,7 @@ let rec compare_under e1 c1 e2 c2 = && compare_under e1 ty1 e2 ty2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _ | Int _ | Float _ | String _ | Array _), _ -> false + | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _), _ -> false let rec fast_test lft1 term1 lft2 term2 = match fterm_of term1, fterm_of term2 with @@ -678,6 +679,37 @@ and eqwhnf cv_pb l2r infos (lft1, (hd1, v1) as appr1) (lft2, (hd2, v2) as appr2) eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible + | FNat n1, FNat n2 -> + let () = assert_reduced_constructor v1 in + let () = assert_reduced_constructor v2 in + if Z.equal n1 n2 then cuniv + else raise NotConvertible + + (* XXX should we expect reduction to turn fconstruct into fnat when possible? *) + | FNat n1, FConstruct (((ind2,j2),_),args2) -> + let () = assert_reduced_constructor v1 in + let () = assert_reduced_constructor v2 in + let natind = Option.get (Environ.retroknowledge @@ info_env infos.cnv_inf).retro_nat in + if not (Ind.CanOrd.equal natind ind2) then raise NotConvertible + else if Z.equal n1 Z.zero then + if Int.equal j2 1 && Array.is_empty args2 then cuniv + else raise NotConvertible + else if Int.equal j2 2 && Int.equal (Array.length args2) 1 then + ccnv CONV l2r infos lft1 lft2 (mkFNat (Z.sub n1 Z.one)) args2.(0) cuniv + else raise NotConvertible + + | FConstruct (((ind1,j1),_),args1), FNat n2 -> + let () = assert_reduced_constructor v1 in + let () = assert_reduced_constructor v2 in + let natind = Option.get (Environ.retroknowledge @@ info_env infos.cnv_inf).retro_nat in + if not (Ind.CanOrd.equal ind1 natind) then raise NotConvertible + else if Z.equal n2 Z.zero then + if Int.equal j1 1 && Array.is_empty args1 then cuniv + else raise NotConvertible + else if Int.equal j1 2 && Int.equal (Array.length args1) 1 then + ccnv CONV l2r infos lft1 lft2 args1.(0) (mkFNat (Z.sub n2 Z.one)) cuniv + else raise NotConvertible + (* Eta expansion of records *) | (FConstruct (((ind1,j1),u1), _),_) -> let () = assert_reduced_constructor v1 in @@ -812,7 +844,7 @@ and eqwhnf cv_pb l2r infos (lft1, (hd1, v1) as appr1) (lft2, (hd2, v2) as appr2) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ | FCaseInvert _ - | FProd _ | FEvar _ | FInt _ | FFloat _ | FString _ + | FProd _ | FEvar _ | FNat _ | FInt _ | FFloat _ | FString _ | FArray _ | FIrrelevant), _ -> raise NotConvertible and convert_stacks ?(mask = [||]) l2r infos lft1 lft2 stk1 stk2 cuniv = diff --git a/kernel/dune b/kernel/dune index 03c5e801acea..1467e64728f3 100644 --- a/kernel/dune +++ b/kernel/dune @@ -5,7 +5,7 @@ (wrapped false) (modules_without_implementation values declarations entries) (modules (:standard \ genOpcodeFiles uint63_31 uint63_63 float64_31 float64_63)) - (libraries boot lib coqrun dynlink)) + (libraries boot lib coqrun dynlink zarith)) (deprecated_library_name (old_public_name coq-core.kernel) diff --git a/kernel/environ.ml b/kernel/environ.ml index 65cd4df5fed2..9f7bc4ab8cf3 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -1129,6 +1129,19 @@ end module QGlobRef = HackQ(GlobRef)(GlobRef.Map_env) +let is_nat env ind = + Option.equal (QInd.equal env) (Some ind) env.retroknowledge.retro_nat + +let ctor_of_nat env i = + let natind = Option.get (retroknowledge env).retro_nat in + let ctor = if Z.equal i Z.zero then 1 else 2 in + natind, ctor + +let unfold_nat env n = + let natind = Option.get (retroknowledge env).retro_nat in + if Z.equal n Z.zero then UnsafeMonomorphic.mkConstruct (natind, 1) + else mkApp (UnsafeMonomorphic.mkConstruct (natind, 2), [|mkNat (Z.sub n Z.one)|]) + let rec constant_dependencies_with_cache env cache kn = match DepCache.get kn cache with | Inl deps -> deps diff --git a/kernel/environ.mli b/kernel/environ.mli index 235ad7033de3..bd86ef0fd682 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -498,6 +498,9 @@ val retroknowledge : env -> Retroknowledge.retroknowledge val constant_depends_on : env -> Constant.t -> Constant.t -> bool (** {5 Internals} *) +val is_nat : env -> inductive -> bool +val ctor_of_nat : env -> Z.t -> constructor +val unfold_nat : env -> Z.t -> constr module Internal : sig (** Makes the qvars treated as above prop. diff --git a/kernel/genlambda.ml b/kernel/genlambda.ml index 31d75df1ca30..3c1ad926a0de 100644 --- a/kernel/genlambda.ml +++ b/kernel/genlambda.ml @@ -39,6 +39,7 @@ type 'v node = | Lparray of 'v lambda array * 'v lambda | Lmakeblock of inductive * int * 'v lambda array (* inductive name, constructor tag, arguments *) +| Lnat of Z.t | Luint of Uint63.t | Lfloat of Float64.t | Lstring of Pstring.t @@ -162,6 +163,7 @@ let rec pp_lam lam = (str "(makeblock " ++ int tag ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") + | Lnat i -> str (Z.to_string i) | Luint i -> str (Uint63.to_string i) | Lfloat f -> str (Float64.to_string f) | Lstring s -> str (Printf.sprintf "%S" (Pstring.to_string s)) @@ -239,7 +241,7 @@ let decompose_Llam_Llet lam = let map_lam_with_binders g f n lam = match lam.node with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ + | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lnat _ | Lint _ | Luint _ | Lfloat _ | Lstring _ -> lam | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in @@ -308,7 +310,7 @@ let map_lam_with_binders g f n lam = let free_rels lam = let rec aux k accu lam = match node lam with | Lrel (_, n) -> if n >= k then Int.Set.add (n - k + 1) accu else accu - | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lnat _ | Lint _ | Luint _ | Lfloat _ | Lstring _ -> accu | Levar (_, args) -> Array.fold_left (fun accu lam -> aux k accu lam) accu args @@ -387,7 +389,7 @@ let lam_subst_args subst args = (* Invariant: Terms in [subst] are already simplified and can be substituted *) let can_subst lam = match node lam with -| Lrel _ | Lvar _ | Lconst _ | Luint _ +| Lrel _ | Lvar _ | Lconst _ | Lnat _ | Luint _ | Lval _ | Lsort _ | Lind _ -> true | Levar _ | Lprod _ | Llam _ | Llet _ | Lapp _ | Lcase _ | Lfix _ | Lcofix _ | Lparray _ | Lmakeblock _ | Lfloat _ | Lstring _ | Lprim _ | Lproj _ -> false @@ -470,7 +472,7 @@ let rec occurrence k kind lam = if n = k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lnat _ | Lint _ | Luint _ | Lfloat _ | Lstring _ -> kind | Levar (_, args) -> occurrence_args k kind args @@ -516,7 +518,7 @@ let occur_once lam = let is_value lam = match node lam with | Lrel _ | Lvar _ | Lconst _ | Luint _ -| Lval _ | Lsort _ | Lind _ | Lint _ | Llam _ | Lfix _ | Lcofix _ | Lfloat _ | Lstring _ -> true +| Lval _ | Lsort _ | Lind _ | Lnat _ | Lint _ | Llam _ | Lfix _ | Lcofix _ | Lfloat _ | Lstring _ -> true | Levar _ | Lprod _ | Llet _ | Lapp _ | Lcase _ | Lparray _ | Lmakeblock _ | Lprim _ | Lproj _ -> false @@ -764,6 +766,8 @@ let rec lambda_of_constr cache env sigma c = let lbodies = lambda_of_args cache env sigma 0 rec_bodies in mknode @@ Lcofix(init, (names, ltypes, lbodies)) + | Nat i -> mknode @@ Lnat i + | Int i -> mknode @@ Luint i | Float f -> mknode @@ Lfloat f diff --git a/kernel/genlambda.mli b/kernel/genlambda.mli index 4c57218e4878..edd63a1ebc90 100644 --- a/kernel/genlambda.mli +++ b/kernel/genlambda.mli @@ -38,6 +38,7 @@ type 'v node = | Lparray of 'v lambda array * 'v lambda | Lmakeblock of inductive * int * 'v lambda array (* inductive name, constructor tag, arguments *) +| Lnat of Z.t | Luint of Uint63.t | Lfloat of Float64.t | Lstring of Pstring.t diff --git a/kernel/hConstr.ml b/kernel/hConstr.ml index a39b2227d3ef..8290e3efce0a 100644 --- a/kernel/hConstr.ml +++ b/kernel/hConstr.ml @@ -285,6 +285,7 @@ let hash_kind = let open Hashset.Combine in function | Float f -> combinesmall 19 (Float64.hash f) | String s -> combinesmall 20 (Pstring.hash s) | Array (u,t,def,ty) -> combinesmall 21 (combine4 (UVars.Instance.hash u) (hash_array hash t) def.hash ty.hash) + | Nat i -> combinesmall 22 (Z.hash i) let kind_to_constr = function | Rel n -> mkRel n @@ -315,6 +316,7 @@ let kind_to_constr = function | Float f -> mkFloat f | String s -> mkString s | Array (u,t,def,ty) -> mkArray (u,Array.map self t,def.self,ty.self) + | Nat i -> mkNat i let of_kind_nohashcons = function | App (c, [||]) -> c @@ -452,6 +454,7 @@ and of_constr_aux henv c = let _, p = Projection.hcons p in let c = of_constr henv c in Proj (p,r,c) + | Nat _ as t -> t | Int _ as t -> t | Float _ as t -> t | String _ as t -> t diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 568b000a738b..39a3286c7272 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -1236,7 +1236,7 @@ let rec subterm_specif cache ?evars renv stack t = end | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Ind _ - | Construct _ | CoFix _ | Int _ | Float _ | String _ + | Construct _ | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _ -> Not_subterm @@ -1484,9 +1484,10 @@ let check_one_fix cache ?evars renv recpos trees def = decompose_app_list (whd_all ?evars renv.env (Term.applist (contract_cofix cofix, args))) | _ -> hd, args in match kind hd with + (* XXX Nat? *) | Construct cstr -> Some (apply_branch cstr args ci brs, []) | CoFix _ | Ind _ | Lambda _ | Prod _ | LetIn _ - | Sort _ | Int _ | Float _ | String _ | Array _ -> assert false + | Sort _ | Nat _ | Int _ | Float _ | String _ | Array _ -> assert false | Rel _ | Var _ | Const _ | App _ | Case _ | Fix _ | Proj _ | Cast _ | Meta _ | Evar _ -> None) @@ -1533,9 +1534,10 @@ let check_one_fix cache ?evars renv recpos trees def = let c = whd_all ?evars renv.env (lift n recArg) in let hd, _ = decompose_app_list c in match kind hd with + (* XXX Nat? *) | Construct _ -> Some (contract_fix fix, absorbed_stack) | CoFix _ | Ind _ | Lambda _ | Prod _ | LetIn _ - | Sort _ | Int _ | Float _ | String _ + | Sort _ | Nat _ | Int _ | Float _ | String _ | Array _ -> assert false | Rel _ | Var _ | Const _ | App _ | Case _ | Fix _ | Proj _ | Cast _ | Meta _ | Evar _ -> None) @@ -1590,7 +1592,7 @@ let check_one_fix cache ?evars renv recpos trees def = match kind hd with | Construct _ -> Some (args.(Projection.npars p + Projection.arg p), []) | CoFix _ | Ind _ | Lambda _ | Prod _ | LetIn _ - | Sort _ | Int _ | Float _ | String _ | Array _ -> assert false + | Sort _ | Nat _ | Int _ | Float _ | String _ | Array _ -> assert false | Rel _ | Var _ | Const _ | App _ | Case _ | Fix _ | Proj _ | Cast _ | Meta _ | Evar _ -> None) end @@ -1620,7 +1622,7 @@ let check_one_fix cache ?evars renv recpos trees def = let rs = check_rec_call_stack renv stack rs c in rs - | Sort _ | Int _ | Float _ | String _ -> + | Sort _ | Nat _ | Int _ | Float _ | String _ -> (* See [Prod]: we cannot ensure that the stack is empty *) rs @@ -1884,7 +1886,7 @@ let check_one_cofix cache ?evars env nbfix def deftype = | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ - | Ind _ | Fix _ | Proj _ | Int _ | Float _ | String _ + | Ind _ | Fix _ | Proj _ | Nat _ | Int _ | Float _ | String _ | Array _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 9116b5713386..a597c171c294 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -186,6 +186,7 @@ let rec infer_fterm cv_pb infos variances hd stk = end | FEvar _ -> assert false | FRel _ -> infer_stack infos variances stk + | FNat _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk | FFloat _ -> infer_stack infos variances stk | FString _ -> infer_stack infos variances stk diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index a869bebd8cc9..e20f41b9cc4d 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -52,7 +52,7 @@ let rec is_lazy env t = | Array (_, t, d, _) -> Array.exists (fun t -> is_lazy env t) t || is_lazy env d | Cast (c, _, _) | Prod (_, c, _) -> is_lazy env c | Const (c, _) -> get_const_lazy env c - | Rel _ | Meta _ | Var _ | Sort _ | Ind _ | Construct _ | Int _ + | Rel _ | Meta _ | Var _ | Sort _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _ | Lambda _ | Evar _ | Fix _ | CoFix _ -> false @@ -1538,6 +1538,8 @@ let compile_prim env decl cond paux = let knot = push_global_cofix env.env_cenv knot fv_params (Array.mapi map t_norm_f) in MLprimitive (Array_get, [|MLapp (MLglobal knot, fv_args); MLint start|]) + | Lnat _ -> failwith "TODO" + | Lint tag -> MLprimitive (Mk_int, [|MLint tag|]) | Lmakeblock (cn,tag,args) -> diff --git a/kernel/primred.ml b/kernel/primred.ml index 55224e46259e..719654b9e82e 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -46,6 +46,12 @@ let add_retroknowledge retro action = | Register_ind(pit,ind) -> begin match pit with + | PIT_nat -> + let r = + match retro.retro_nat with + | None -> ind + | Some (ind' as t) -> check_same_inds pit ind ind'; t in + { retro with retro_nat = Some r } | PIT_bool -> let r = match retro.retro_bool with diff --git a/kernel/reduction.ml b/kernel/reduction.ml index ab08557b0c57..da9d37f8703d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -23,10 +23,10 @@ open Context.Rel.Declaration let whd_all ?evars env t = match kind t with | (Sort _|Meta _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|Int _|Float _|String _|Array _) -> t + Prod _|Lambda _|Fix _|CoFix _|Nat _ | Int _|Float _|String _|Array _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Meta _ | Int _ | Float _ | String _ | Array _ -> t + | Ind _ | Construct _ | Meta _ | Nat _ | Int _ | Float _ | String _ | Array _ -> t | Sort _ | Rel _ | Var _ | Evar _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Const _ |Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos ?evars RedFlags.all env) (create_tab ()) (inject t) @@ -37,10 +37,10 @@ let whd_all ?evars env t = let whd_allnolet ?evars env t = match kind t with | (Sort _|Meta _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|LetIn _|Int _|Float _|String _|Array _) -> t + Prod _|Lambda _|Fix _|CoFix _|LetIn _|Nat _ | Int _|Float _|String _|Array _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Meta _ | LetIn _ | Int _ | Float _ | String _ | Array _ -> t + | Ind _ | Construct _ | Meta _ | LetIn _ | Nat _ | Int _ | Float _ | String _ | Array _ -> t | Sort _ | Rel _ | Var _ | Evar _ | Cast _ | Prod _ | Lambda _ | App _ | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos ?evars RedFlags.allnolet env) (create_tab ()) (inject t) diff --git a/kernel/relevanceops.ml b/kernel/relevanceops.ml index 650d38291da3..5eb461c003b3 100644 --- a/kernel/relevanceops.ml +++ b/kernel/relevanceops.ml @@ -62,7 +62,7 @@ let rec relevance_of_term_extra env extra lft c = | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (_, r, _) -> r - | Int _ | Float _ | String _ -> Sorts.Relevant + | Nat _ | Int _ | Float _ | String _ -> Sorts.Relevant | Array _ -> Sorts.Relevant | Meta _ | Evar _ -> Sorts.Relevant (* let's assume metas and evars are relevant for now *) diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 9b92c7fa9018..68ddbfb27033 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -36,6 +36,7 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) + retro_nat : inductive option; } let empty = { @@ -49,6 +50,7 @@ let empty = { retro_cmp = None; retro_f_cmp = None; retro_f_class = None; + retro_nat = None; } type action = diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 9202cd9e7ee3..25464b474c18 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -30,6 +30,7 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) + retro_nat : inductive option; } val empty : retroknowledge diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 5b834ae8d8cf..50b5964eb509 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1774,6 +1774,13 @@ let check_register_ind (type t) ind (r : t CPrimitives.prim_ind) env = "th constructor does not have the expected type") in let check_type_cte pos = check_type pos ind in match r with + | CPrimitives.PIT_nat -> + check_nparams 0; + check_nconstr 2; + check_name 0 "O"; + check_type_cte 0; + check_name 1 "S"; + check_type 1 (Term.mkArrow ind Relevant ind) | CPrimitives.PIT_bool -> check_nparams 0; check_nconstr 2; diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 2f837f7afbb9..3f3cc0b67397 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -316,6 +316,11 @@ let type_of_prim_type _env u (type a) (prim : a CPrimitives.prim_type) = match p | _ -> anomaly Pp.(str"universe instance for array type should have length 1") end +let type_of_nat env = +match (Environ.retroknowledge env).Retroknowledge.retro_nat with + | Some c -> UnsafeMonomorphic.mkInd c + | None -> CErrors.user_err Pp.(str"The type nat must be registered before this construction can be typechecked.") + let type_of_int env = match (Environ.retroknowledge env).Retroknowledge.retro_int63 with | Some c -> UnsafeMonomorphic.mkConst c @@ -834,6 +839,7 @@ and execute_aux tbl env cstr = fix_ty (* Primitive types *) + | Nat n -> assert (Z.leq Z.zero n); type_of_nat env | Int _ -> type_of_int env | Float _ -> type_of_float env | String _ -> type_of_string env @@ -963,6 +969,11 @@ let type_of_prim env u t = let float_ty () = type_of_float env in let string_ty () = type_of_string env in let array_ty u a = mkApp(type_of_array env u, [|a|]) in + let nat_ty () = + match (Environ.retroknowledge env).Retroknowledge.retro_nat with + | Some ind -> UM.mkInd ind + | None -> CErrors.user_err Pp.(str"The type bool must be registered before this primitive.") + in let bool_ty () = match (Environ.retroknowledge env).Retroknowledge.retro_bool with | Some ((ind,_),_) -> UM.mkInd ind @@ -1001,6 +1012,7 @@ let type_of_prim env u t = | PT_array -> array_ty (fst t) (tr_type (snd t)) in let tr_ind (tr_type : ind_or_type -> constr) (type t) (i : t prim_ind) (a : t) = match i, a with + | PIT_nat, () -> nat_ty () | PIT_bool, () -> bool_ty () | PIT_carry, t -> carry_ty (tr_type t) | PIT_pair, (t1, t2) -> pair_ty (tr_type t1) (tr_type t2) diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d9a47916cc16..a0fbf475c269 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -77,6 +77,7 @@ val check_hyps_inclusion : env -> ?evars:CClosure.evar_handler -> (** Types for primitives *) +val type_of_nat : env -> types val type_of_int : env -> types val type_of_float : env -> types val type_of_string : env -> types diff --git a/kernel/vars.ml b/kernel/vars.ml index 969c12551322..5e0882b447e3 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -293,7 +293,7 @@ let map_constr_relevance f c = | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast _ | App _ | Const _ | Ind _ | Construct _ - | Int _ | Float _ | String _ | Array _ -> c + | Nat _ | Int _ | Float _ | String _ | Array _ -> c | Prod (na,x,y) -> let na' = map_annot_relevance f na in @@ -340,7 +340,7 @@ let fold_kind_relevance f acc c = | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast _ | App _ | Const _ | Ind _ | Construct _ - | Int _ | Float _ | String _ | Array _ -> acc + | Nat _ | Int _ | Float _ | String _ | Array _ -> acc | Prod (na,_,_) | Lambda (na,_,_) | LetIn (na,_,_,_) -> fold_annot_relevance f acc na diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index cef33cd6a45a..ea0bfb52b7ff 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -569,6 +569,8 @@ let rec compile_lam env cenv lam sz cont = match node lam with | Lrel(_, i) -> pos_rel i cenv sz :: cont + | Lnat _ -> failwith "TODO" + | Lint i -> compile_structured_constant cenv (Const_b0 i) sz cont | Lval v -> compile_structured_constant cenv (Const_val (get_lval v)) sz cont diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index cb56c7d8bcba..ec2a9cc2adc0 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -411,7 +411,7 @@ let rec extract_type (table : Common.State.t) env sg db j c args = | (Info, TypeScheme) -> extract_type_app table env sg db (r, type_sign env sg ty) args | (Info, Default) -> Tunknown)) - | Cast _ | LetIn _ | Construct _ | Int _ | Float _ | String _ | Array _ -> assert false + | Cast _ | LetIn _ | Construct _ | Nat _ | Int _ | Float _ | String _ | Array _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], @@ -757,6 +757,7 @@ let rec extract_term table env sg mle mlt c args = 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 + | Nat n -> assert (args = []); extract_term table env sg mle mlt (EConstr.unfold_nat env n) [] | Int i -> assert (args = []); MLuint i | Float f -> assert (args = []); MLfloat f | String s -> assert (args = []); MLstring s diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 08214b0866c7..f389b9c1749b 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -664,11 +664,12 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos | _ -> do_finalize dyn_infos ) | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ - |Int _ | Float _ | String _ -> + | Nat _ | Int _ | Float _ | String _ -> do_finalize dyn_infos | App (_, _) -> ( let f, args = decompose_app_list sigma dyn_infos.info in match EConstr.kind sigma f with + | Nat _ -> user_err Pp.(str "nat cannot be applied") | Int _ -> user_err Pp.(str "integer cannot be applied") | Float _ -> user_err Pp.(str "float cannot be applied") | String _ -> user_err Pp.(str "string cannot be applied") diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 62a51b5ae8b3..66097f288686 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -85,7 +85,7 @@ let is_rec names = match DAst.get gt with | GVar id -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GGenarg _ - | GInt _ | GFloat _ | GString _ -> + | GNat _ | GInt _ | GFloat _ | GString _ -> false | GCast (b, _, _) -> lookup names b | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index a9bdbb4a7891..9694fb33fcf4 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -468,7 +468,7 @@ let rec build_entry_lc env sigma funnames avoid rt : observe (str " Entering : " ++ pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GGenarg _ | GInt _ + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GGenarg _ | GNat _ | GInt _ |GFloat _ | GString _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid @@ -574,6 +574,7 @@ let rec build_entry_lc env sigma funnames avoid rt : build_entry_lc env sigma funnames avoid (mkGApp (b, args)) | GRec _ -> user_err Pp.(str "Not handled GRec") | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GNat _ -> user_err Pp.(str "Cannot apply a nat") | GInt _ -> user_err Pp.(str "Cannot apply an integer") | GFloat _ -> user_err Pp.(str "Cannot apply a float") | GString _ -> user_err Pp.(str "Cannot apply a string") @@ -1208,7 +1209,7 @@ let rec compute_cst_params relnames params gt = DAst.with_val (function | GRef _ | GVar _ | GEvar _ | GPatVar _ - | GInt _ | GFloat _ | GString _ -> params + | GNat _ | GInt _ | GFloat _ | GString _ -> params | GApp (f, args) -> ( match DAst.get f with | GVar relname' when Id.Set.mem relname' relnames -> diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 4809a1ef05e1..055b0e0e923a 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -116,7 +116,7 @@ let change_vars = , Array.map (change_vars mapping) t , change_vars mapping def , change_vars mapping ty ) - | GSort _ | GHole _ | GGenarg _ | GInt _ | GString _ as x -> x) + | GSort _ | GHole _ | GGenarg _ | GNat _ | GInt _ | GString _ as x -> x) rt and change_vars_br mapping ({CAst.loc; v = idl, patl, res} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in @@ -284,7 +284,7 @@ let rec alpha_rt excluded rt = , alpha_rt excluded lhs , alpha_rt excluded rhs ) | GRec _ -> user_err Pp.(str "Not handled GRec") - | (GSort _ | GInt _ | GFloat _ | GString _ | GHole _ | GGenarg _) as rt -> rt + | (GSort _ | GNat _ | GInt _ | GFloat _ | GString _ | GHole _ | GGenarg _) as rt -> rt | GCast (b, k, c) -> GCast (alpha_rt excluded b, k, alpha_rt excluded c) | GApp (f, args) -> @@ -347,7 +347,7 @@ let is_free_in id = | GGenarg _ -> false (* XXX isn't this incorrect? *) | GCast (b, _, t) -> is_free_in b || is_free_in t - | GInt _ | GFloat _ | GString _ -> false + | GNat _ | GInt _ | GFloat _ | GString _ -> false | GArray (_u, t, def, ty) -> Array.exists is_free_in t || is_free_in def || is_free_in ty) x @@ -423,6 +423,7 @@ let replace_var_by_term x_id term = , replace_var_by_pattern rhs ) | GRec _ -> CErrors.user_err (Pp.str "Not handled GRec") | (GSort _ | GHole _ | GGenarg _) as rt -> rt (* is this correct for GGenarg? *) + | GNat _ as rt -> rt | GInt _ as rt -> rt | GFloat _ as rt -> rt | GString _ as rt -> rt @@ -506,7 +507,7 @@ let expand_as = in let rec expand_as map = DAst.map (function - | (GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GGenarg _ | GInt _ + | (GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GGenarg _ | GNat _ | GInt _ | GFloat _ | GString _ ) as rt -> rt | GVar id as rt -> ( try DAst.get (Id.Map.find id map) with Not_found -> rt ) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 0cedf8d8181e..b71de961a8b9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -241,7 +241,7 @@ let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with | Rel _ -> () - | Int _ | Float _ | String _ -> () + | Nat _ | Int _ | Float _ | String _ -> () | Var x -> if Id.List.mem x forbidden then user_err @@ -460,14 +460,14 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") | Proj _ -> user_err Pp.(str "Function cannot treat projections") | Lambda _ | Cast _ | LetIn _ - | CoFix _ | Array _ | Int _ | Float _ | String _ -> + | CoFix _ | Array _ | Nat _ | Int _ | Float _ | String _ -> anomaly ( Pp.str "travel_aux : unexpected " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str "." ) ) | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ - |Int _ | Float _ | String _ -> + | Nat _ | Int _ | Float _ | String _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in new_continuation_tac expr_info) diff --git a/plugins/ltac2/tac2core.ml b/plugins/ltac2/tac2core.ml index 3e779c0a8801..51ac5b241fb9 100644 --- a/plugins/ltac2/tac2core.ml +++ b/plugins/ltac2/tac2core.ml @@ -586,6 +586,7 @@ let () = Tac2ffi.of_constr def; Tac2ffi.of_constr ty; |] + | Nat n -> failwith "TODO" let () = define "constr_make" (valexpr @-> eret constr) @@ fun knd env sigma -> diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index c1644adc86d5..84a2792b51e7 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -372,7 +372,7 @@ let iter_constr_LR sigma f c = match EConstr.kind sigma c with | Proj(_,_,a) -> f a | Array(_u,t,def,ty) -> Array.iter f t; f def; f ty | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ - | Int _ | Float _ | String _) -> () + | Nat _ | Int _ | Float _ | String _) -> () (* The comparison used to determine which subterms matches is KEYED *) (* CONVERSION. This looks for convertible terms that either have the same *) @@ -426,7 +426,7 @@ let proj_nparams env c = with Not_found -> 0 let isRigid sigma c = match EConstr.kind sigma c with - | (Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _| Int _ + | (Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _| Nat _ | Int _ | Float _ | String _ | Array _) -> true | (Rel _ | Var _ | Meta _ | Evar (_, _) | Cast (_, _, _) | LetIn (_, _, _, _) | App (_, _) | Const (_, _) | Ind ((_, _), _) | Construct (((_, _), _), _) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index e228c3aab231..69e8b789e158 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -52,6 +52,7 @@ type cbv_value = | COFIX of cofixpoint * cbv_value subs * cbv_value array | CONSTRUCT of constructor UVars.puniverses * cbv_value array | PRIMITIVE of CPrimitives.t * pconstant * cbv_value array + | NAT of Z.t | ARRAY of UVars.Instance.t * cbv_value Parray.t * cbv_value | SYMBOL of { cst: Constant.t UVars.puniverses; unfoldfix: bool; rules: Declarations.machine_rewrite_rule list; stk: cbv_stack } @@ -99,6 +100,7 @@ let rec shift_value n = function CONSTRUCT (c, Array.map (shift_value n) args) | PRIMITIVE(op,c,args) -> PRIMITIVE(op,c,Array.map (shift_value n) args) + | NAT _ as v -> v | ARRAY (u,t,ty) -> ARRAY(u, Parray.map (shift_value n) t, shift_value n ty) | SYMBOL s -> SYMBOL { s with stk = shift_stack n s.stk } @@ -198,7 +200,7 @@ let strip_appl head stack = | COFIX (cofix,env,app) -> (COFIX(cofix,env,[||]), stack_vect_app app stack) | CONSTRUCT (c,app) -> (CONSTRUCT(c,[||]), stack_vect_app app stack) | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_vect_app app stack) - | LETIN _ | VAL _ | STACK _ | PROD _ | LAMBDA _ | ARRAY _ | SYMBOL _ -> (head, stack) + | LETIN _ | VAL _ | STACK _ | PROD _ | LAMBDA _ | NAT _ | ARRAY _ | SYMBOL _ -> (head, stack) let destack head stack = match head with @@ -208,7 +210,7 @@ let destack head stack = | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_vect_app app stack) | STACK (k, v, stk) -> (shift_value k v, stack_concat (shift_stack k stk) stack) | SYMBOL ({ stk } as s) -> (SYMBOL { s with stk=TOP }, stack_concat stk stack) - | LETIN _ | VAL _ | PROD _ | LAMBDA _ | ARRAY _ -> (head, stack) + | LETIN _ | VAL _ | PROD _ | LAMBDA _ | NAT _ | ARRAY _ -> (head, stack) let rec fixp_reducible_symb_stk = function | TOP -> true @@ -224,7 +226,7 @@ let fixp_reducible flgs ((reci,i),_) stk = | [] -> false | v :: appl -> if Int.equal n 0 then match v with - | CONSTRUCT _ -> true + | CONSTRUCT _ | NAT _ -> true | SYMBOL { unfoldfix=true; stk; _ } -> fixp_reducible_symb_stk stk | _ -> false @@ -436,6 +438,7 @@ and reify_value = function (* reduction under binders *) mkApp(mkConstructU c, Array.map reify_value args) | PRIMITIVE(op,c,args) -> mkApp(mkConstU c, Array.map reify_value args) + | NAT n -> mkNat n | ARRAY (u,t,ty) -> let t, def = Parray.to_array t in mkArray(u, Array.map reify_value t, reify_value def, reify_value ty) @@ -578,7 +581,13 @@ let rec norm_head info env t stack = (LAMBDA(List.length ctxt, List.rev ctxt,b,env), stack) | Fix fix -> (FIX(fix,env,[||]), stack) | CoFix cofix -> (COFIX(cofix,env,[||]), stack) - | Construct c -> (CONSTRUCT(c, [||]), stack) + | Construct ((ind,j),_ as c) -> + if Environ.is_nat info.env ind then match j, stack with + | 1, _ -> NAT Z.zero, stack + | 2, APP ([NAT n], stack) -> NAT (Z.succ n), stack + | 2, _ -> (CONSTRUCT(c, [||]), stack) + | _ -> assert false + else (CONSTRUCT(c, [||]), stack) | Array(u,t,def,ty) -> let ty = cbv_stack_term info TOP env ty in @@ -589,6 +598,8 @@ let rec norm_head info env t stack = (cbv_stack_term info TOP env def) in (ARRAY (u,t,ty), stack) + | Nat n -> (NAT n, stack) + (* neutral cases *) | (Sort _ | Meta _ | Ind _ | Int _ | Float _ | String _) -> (VAL(0, t), stack) | Prod (na,t,u) -> (PROD(na,t,u,env), stack) @@ -686,6 +697,16 @@ and cbv_stack_value info env = function in cbv_stack_term info stk env (snd br.(n-1)) + (* unlike CONSTRUCT this is the only NAT case (no APP/PROJ at the head of the stack by typing) *) + | NAT n, CASE (_,_,_,br,_,_,env,stk) when red_set info.reds fMATCH -> + if Z.equal n Z.zero then + let _, br = br.(0) in + cbv_stack_term info stk env br + else + let env = subs_cons (NAT (Z.pred n)) env in + let _, br = br.(1) in + cbv_stack_term info stk env br + (* constructor in a Projection -> IOTA *) | (CONSTRUCT(((sp,n),u),[||]), APP(args,PROJ(p,_,stk))) when red_set info.reds fMATCH && Projection.unfolded p -> @@ -695,6 +716,8 @@ and cbv_stack_value info env = function (* may be reduced later by application *) | (FIX(fix,env,[||]), APP(appl,TOP)) -> FIX(fix,env,Array.of_list appl) | (COFIX(cofix,env,[||]), APP(appl,TOP)) -> COFIX(cofix,env,Array.of_list appl) + | CONSTRUCT (((ind,2),_),[||]), APP([NAT n], TOP) when Environ.is_nat info.env ind -> + NAT (Z.succ n) | (CONSTRUCT(c,[||]), APP(appl,TOP)) -> CONSTRUCT(c,Array.of_list appl) (* primitive apply to arguments *) @@ -985,6 +1008,7 @@ and cbv_norm_value info = function mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) | PRIMITIVE(op,c,args) -> mkApp(mkConstU c,Array.map (cbv_norm_value info) args) + | NAT n -> mkNat n | ARRAY (u,t,ty) -> let ty = cbv_norm_value info ty in let t, def = Parray.to_array t in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 701785c7820c..2b3aca33f545 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -614,7 +614,7 @@ let sub_match ?(closed=true) env sigma pat c = in let sub = (env,def) :: (env,ty) :: subargs env t in try_aux sub next_mk_ctx next - | Construct _|Ind _|Evar _|Const _|Rel _|Meta _|Var _|Sort _|Int _|Float _|String _ -> + | Construct _|Ind _|Evar _|Const _|Rel _|Meta _|Var _|Sort _|Nat _|Int _|Float _|String _ -> next () in here next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index f5bdb4ad391a..b60510988b3e 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -914,6 +914,7 @@ and detype_r d flags avoid env sigma t = avoid env sigma case | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef + | Nat n -> GNat n | Int i -> GInt i | Float f -> GFloat f | String s -> GString s @@ -1108,6 +1109,7 @@ let rec subst_glob_constr env subst = DAst.map (function | GSort _ | GVar _ | GEvar _ + | GNat _ | GInt _ | GFloat _ | GString _ diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index e1665d2f9b9f..2f98aa6b78ec 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -180,7 +180,7 @@ let flex_kind_of_term flags env evd c sk = else Rigid | Evar ev -> if is_evar_allowed flags (fst ev) then Flexible ev else Rigid - | Lambda _ | Prod _ | Sort _ | Ind _ | Int _ | Float _ | String _ | Array _ -> Rigid + | Lambda _ | Prod _ | Sort _ | Ind _ | Nat _ | Int _ | Float _ | String _ | Array _ -> Rigid | Construct _ | CoFix _ (* Incorrect: should check only app in sk *) -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied (should check it?) *) @@ -265,7 +265,7 @@ let occur_rigidly flags env evd (evk,_) t = (match aux c with | Rigid b -> Rigid b | _ -> Reducible) - | Meta _ | Fix _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> Reducible + | Meta _ | Fix _ | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _ -> Reducible in match aux t with | Rigid b -> b @@ -1194,7 +1194,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) let rec is_unnamed (hd, args) = match EConstr.kind i hd with - | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _ |Float _|String _|Array _) -> + | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Nat _|Int _ |Float _|String _|Array _) -> Stack.not_purely_applicative args | (CoFix _|Meta _|Rel _)-> true | Evar _ -> Stack.not_purely_applicative args @@ -1333,12 +1333,25 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | Const _, Const _ | Ind _, Ind _ | Construct _, Construct _ + | Nat _, Nat _ | Int _, Int _ | Float _, Float _ | String _, String _ | Array _, Array _ -> rigids env evd sk1 term1 sk2 term2 + | Nat n1, Construct _ -> + let term1 = EConstr.unfold_nat env n1 in + let term1, pred1 = decompose_app evd term1 in + let sk1 = Stack.append_app pred1 sk1 in + rigids env evd sk1 term1 sk2 term2 + + | Construct _, Nat n2 -> + let term2 = EConstr.unfold_nat env n2 in + let term2, pred2 = decompose_app evd term2 in + let sk2 = Stack.append_app pred2 sk2 in + rigids env evd sk1 term1 sk2 term2 + | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) if Evar.equal sp1 sp2 then match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with @@ -1413,9 +1426,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | None -> UnifFailure (evd,NotSameHead) end - | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Float _ | String _ | Array _ | Evar _ | Lambda _), _ -> + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Nat _ | Int _ | Float _ | String _ | Array _ | Evar _ | Lambda _), _ -> UnifFailure (evd,NotSameHead) - | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Array _ | Evar _ | Lambda _) -> + | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Nat _ | Int _ | Array _ | Evar _ | Lambda _) -> UnifFailure (evd,NotSameHead) | Case _, _ -> UnifFailure (evd,NotSameHead) | Proj _, _ -> UnifFailure (evd,NotSameHead) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 7655d8cfbf06..925864142346 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -217,6 +217,7 @@ let mk_glob_constr_eq f g c1 c2 = match DAst.get c1, DAst.get c2 with GlobRef.(CanOrd.equal (ConstRef cst1) (ConstRef cst2)) && Option.equal instance_eq u1 u2 && List.equal f args1 args2 && f c1 c2 + | GNat i1, GNat i2 -> Z.equal i1 i2 | GInt i1, GInt i2 -> Uint63.equal i1 i2 | GFloat f1, GFloat f2 -> Float64.equal f1 f2 | GString s1, GString s2 -> Pstring.equal s1 s2 @@ -225,7 +226,7 @@ let mk_glob_constr_eq f g c1 c2 = match DAst.get c1, DAst.get c2 with Option.equal instance_eq u1 u2 | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GGenarg _ | GCast _ | GProj _ | - GInt _ | GFloat _ | GString _ | GArray _), _ -> false + GNat _ | GInt _ | GFloat _ | GString _ | GArray _), _ -> false let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq (fun na1 na2 _ _ -> Name.equal na1 na2) c @@ -297,7 +298,7 @@ let map_glob_constr_left_to_right_with_names f g = DAst.map (function let comp2 = f def in let comp3 = f ty in GArray (u,comp1,comp2,comp3) - | (GVar _ | GSort _ | GHole _ | GGenarg _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ | GString _) as x -> x + | (GVar _ | GSort _ | GHole _ | GGenarg _ | GRef _ | GEvar _ | GPatVar _ | GNat _ | GInt _ | GFloat _ | GString _) as x -> x ) let map_glob_constr_left_to_right f = map_glob_constr_left_to_right_with_names f (fun na -> na) @@ -333,7 +334,7 @@ let fold_glob_constr f acc = DAst.with_val (function | GProj (p,args,c) -> f (List.fold_left f acc args) c | GArray (_u,t,def,ty) -> f (f (Array.fold_left f acc t) def) ty - | (GSort _ | GHole _ | GGenarg _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ | GString _) -> acc + | (GSort _ | GHole _ | GGenarg _ | GRef _ | GEvar _ | GPatVar _ | GNat _ | GInt _ | GFloat _ | GString _) -> acc ) let fold_return_type_with_binders f g v acc (na,tyopt) = (* eta expansion is important if g has effects, eg bound_glob_vars below, see #11959 *) @@ -378,7 +379,7 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function | GProj (p,args,c) -> f v (List.fold_left (f v) acc args) c | GArray (_u, t, def, ty) -> f v (f v (Array.fold_left (f v) acc t) def) ty - | (GSort _ | GHole _ | GGenarg _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ | GString _) -> acc)) + | (GSort _ | GHole _ | GGenarg _ | GRef _ | GEvar _ | GPatVar _ | GNat _ | GInt _ | GFloat _ | GString _) -> acc)) let iter_glob_constr f = fold_glob_constr (fun () -> f) () diff --git a/pretyping/glob_term.mli b/pretyping/glob_term.mli index 57ebcf07fe98..2eebe6f9cb71 100644 --- a/pretyping/glob_term.mli +++ b/pretyping/glob_term.mli @@ -116,6 +116,7 @@ type 'a glob_constr_r = | GGenarg of GenConstr.glb | GCast of 'a glob_constr_g * Constr.cast_kind option * 'a glob_constr_g | GProj of (Constant.t * glob_instance option) * 'a glob_constr_g list * 'a glob_constr_g + | GNat of Z.t | GInt of Uint63.t | GFloat of Float64.t | GString of Pstring.t diff --git a/pretyping/heads.ml b/pretyping/heads.ml index 39b51b68958c..76074e4e2480 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -76,7 +76,7 @@ and kind_of_head env sigma t = | Proj (p,_,c) -> RigidHead RigidOther | Case (_,_,_,_,_,c,_) -> aux k [] c true - | Int _ | Float _ | String _ | Array _ -> ConstructorHead + | Nat _ | Int _ | Float _ | String _ | Array _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in try aux k [] (List.nth l n) true diff --git a/pretyping/keys.ml b/pretyping/keys.ml index 250d8d6c235c..bb900c5d6d20 100644 --- a/pretyping/keys.ml +++ b/pretyping/keys.ml @@ -85,6 +85,11 @@ let equiv_keys k k' = let mkKGlob env gr = KGlob (Environ.QGlobRef.canonize env gr) +let mkKNat env i = + let natind = Option.get (Environ.retroknowledge env).retro_nat in + let ctor = if Z.equal i Z.zero then 1 else 2 in + mkKGlob env (ConstructRef (natind, ctor)) + (** Registration of keys as an object *) let load_keys _ (ref,ref') = @@ -128,6 +133,7 @@ let constr_key env kind c = | Const (c, _) -> mkKGlob env (GlobRef.ConstRef c) | Ind (i, u) -> mkKGlob env (GlobRef.IndRef i) | Construct (c,u) -> mkKGlob env (GlobRef.ConstructRef c) + | Nat i -> mkKNat env i | Var id -> mkKGlob env (GlobRef.VarRef id) | App (f, _) -> aux f | Proj (p, _, _) -> mkKGlob env (GlobRef.ConstRef (Projection.constant p)) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 58b7bddbe6c4..e0505086982f 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -219,7 +219,8 @@ let pattern_of_constr ~broken env sigma t = let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in PCoFix (ln,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, - Array.map (pattern_of_constr env') bl)) + Array.map (pattern_of_constr env') bl)) + | Nat n -> pattern_of_constr env (Environ.unfold_nat env n) (* XXX optimized Nat pattern *) | Int i -> PInt i | Float f -> PFloat f | String s -> PString s @@ -587,6 +588,8 @@ let rec pat_of_raw metas vars : _ -> _ constr_pattern_r = DAst.with_loc_val (fun let names = Array.map (fun id -> Name id) ids in PCoFix (n, (names, tl, cl)) + | GNat _ -> failwith "TODO" + | GInt i -> PInt i | GFloat f -> PFloat f | GString s -> PString s diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a173b74a2d23..988e6cb442bb 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -630,6 +630,7 @@ type pretyper = { pretype_hole : pretyper -> Evar_kinds.glob_evar_kind -> unsafe_judgment pretype_fun; pretype_genarg : pretyper -> GenConstr.glb -> unsafe_judgment pretype_fun; pretype_cast : pretyper -> glob_constr * cast_kind option * glob_constr -> unsafe_judgment pretype_fun; + pretype_nat : pretyper -> Z.t -> unsafe_judgment pretype_fun; pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; pretype_string : pretyper -> Pstring.t -> unsafe_judgment pretype_fun; @@ -675,6 +676,8 @@ let eval_pretyper self ~flags tycon env sigma t = self.pretype_genarg self arg ?loc ~flags tycon env sigma | GCast (c, k, t) -> self.pretype_cast self (c, k, t) ?loc ~flags tycon env sigma + | GNat n -> + self.pretype_nat self n ?loc ~flags tycon env sigma | GInt n -> self.pretype_int self n ?loc ~flags tycon env sigma | GFloat f -> @@ -1570,6 +1573,14 @@ let pretype_type self c ?loc ~flags valcon (env : GlobEnv.t) sigma = match DAst. ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v e end + let pretype_nat self n ?loc ~flags tycon env sigma = + let resj = + try Typing.judge_of_nat !!env n + with Invalid_argument _ -> + user_err ?loc (str "Type of int63 should be registered first.") + in + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~flags env sigma resj tycon + let pretype_int self i = fun ?loc ~flags tycon env sigma -> let resj = @@ -1665,6 +1676,7 @@ let default_pretyper = pretype_hole = pretype_hole; pretype_genarg = pretype_genarg; pretype_cast = pretype_cast; + pretype_nat = pretype_nat; pretype_int = pretype_int; pretype_float = pretype_float; pretype_string = pretype_string; diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 5c5766f6a061..aa81968d2761 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -201,6 +201,7 @@ type pretyper = { pretype_hole : pretyper -> Evar_kinds.glob_evar_kind -> unsafe_judgment pretype_fun; pretype_genarg : pretyper -> GenConstr.glb -> unsafe_judgment pretype_fun; pretype_cast : pretyper -> glob_constr * Constr.cast_kind option * glob_constr -> unsafe_judgment pretype_fun; + pretype_nat : pretyper -> Z.t -> unsafe_judgment pretype_fun; pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; pretype_string : pretyper -> Pstring.t -> unsafe_judgment pretype_fun; diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1730bb25e60e..7e80104d758f 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -927,6 +927,8 @@ let rec whd_state_gen flags ?metas env sigma = |_, _ -> fold () else fold () + | Nat _ -> failwith "TODO" + | CoFix cofix -> if RedFlags.red_set flags RedFlags.fCOFIX then match Stack.strip_app stack with @@ -1015,6 +1017,8 @@ let local_whd_state_gen flags ?metas env sigma = |_, _ -> s else s + | Nat _ -> failwith "TODO" + | CoFix cofix -> if RedFlags.red_set flags RedFlags.fCOFIX then match Stack.strip_app stack with @@ -1118,7 +1122,7 @@ let shrink_eta sigma c = | _ -> x else x | Meta _ | App _ | Case _ | Fix _ | Construct _ | CoFix _ | Evar _ | Rel _ | Var _ | Sort _ | Prod _ - | LetIn _ | Const _ | Ind _ | Proj _ | Int _ | Float _ | String _ | Array _ -> x + | LetIn _ | Const _ | Ind _ | Proj _ | Nat _ | Int _ | Float _ | String _ | Array _ -> x in whrec c diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 89532ca0ec26..941df4f06401 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -274,6 +274,7 @@ let retype ?metas ?(polyprop=true) sigma = with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) + | Nat _ -> EConstr.of_constr (Typeops.type_of_nat env) | Int _ -> EConstr.of_constr (Typeops.type_of_int env) | Float _ -> EConstr.of_constr (Typeops.type_of_float env) | String _ -> EConstr.of_constr (Typeops.type_of_string env) @@ -458,7 +459,7 @@ let relevance_of_term env sigma c = | Evar (evk, _) -> let evi = Evd.find_undefined sigma evk in Evd.evar_relevance evi - | Int _ | Float _ | String _ | Array _ -> ERelevance.relevant + | Nat _ | Int _ | Float _ | String _ | Array _ -> ERelevance.relevant | Meta _ -> ERelevance.relevant in aux Range.empty c diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 4da05cc1ffd0..3dfbd0223514 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -450,8 +450,14 @@ let type_of_constructor env sigma ((ind,_ as ctor),u) = let sigma = Evd.add_poly_constraints ~src:UState.Internal sigma csts in sigma, (EConstr.of_constr (rename_type env ty (GR.ConstructRef ctor))) +let type_of_nat env = EConstr.of_constr (Typeops.type_of_nat env) + let type_of_int env = EConstr.of_constr (Typeops.type_of_int env) +let judge_of_nat env n = + if not @@ Z.leq Z.zero n then CErrors.user_err Pp.(str "Optimized nat should be >= 0."); + { uj_val = mkNat n; uj_type = type_of_nat env } + let judge_of_int env v = { uj_val = mkInt v; uj_type = type_of_int env } @@ -656,6 +662,8 @@ let rec execute env sigma cstr = let sigma, tj = type_judgment env sigma tj in judge_of_cast env sigma cj k tj + | Nat n -> sigma, judge_of_nat env n + | Int i -> sigma, judge_of_int env i @@ -789,7 +797,7 @@ let rec recheck_against env sigma good c = match kind sigma good, kind sigma c with (* No subterms *) | _, (Meta _ | Rel _ | Var _ | Const _ | Ind _ | Construct _ - | Sort _ | Int _ | Float _ | String _) -> + | Sort _ | Nat _ | Int _ | Float _ | String _) -> default () (* Evar (todo deal with Evar differently??? execute recurses on its type) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index a68b2231ba01..5904b3d7fc06 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -60,6 +60,7 @@ val judge_of_abstraction : Environ.env -> evar_map -> Name.t -> val judge_of_product : Environ.env -> evar_map -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment val judge_of_projection : env -> evar_map -> Projection.t -> unsafe_judgment -> unsafe_judgment +val judge_of_nat : Environ.env -> Z.t -> unsafe_judgment val judge_of_int : Environ.env -> Uint63.t -> unsafe_judgment val judge_of_float : Environ.env -> Float64.t -> unsafe_judgment val judge_of_string : Environ.env -> Pstring.t -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 95ae3f13d918..ef2d3950bff4 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -934,7 +934,7 @@ let is_rigid_head sigma flags t = match EConstr.kind sigma t with | Const (cst,u) -> not (Structures.PrimitiveProjections.is_transparent_constant flags.modulo_delta cst) | Ind (i,u) -> true - | Construct _ | Int _ | Float _ | String _ | Array _ -> true + | Construct _ | Nat _ | Int _ | Float _ | String _ | Array _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ | Lambda _ | LetIn _ | App (_, _) | Case _ @@ -1037,7 +1037,7 @@ let rec is_neutral env sigma ts t = | Evar _ | Meta _ -> true | Case (_, _, _, _, _, c, _) -> is_neutral env sigma ts c | Proj (p, _, c) -> is_neutral env sigma ts c - | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> false + | Lambda _ | LetIn _ | Construct _ | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) | Fix _ -> false (* This is an approximation *) | App _ -> assert false @@ -2320,7 +2320,7 @@ let get_max_rel_array sigma v = Array.fold_left (fun accu c -> max accu (get_max let anorec = AOther [||] let rec make sigma c0 = match EConstr.kind sigma c0 with -| (Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _) -> +| (Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _) -> { proj = c0; self = anorec; data = 0 } | Rel n -> { proj = c0; self = anorec; data = n } @@ -2538,6 +2538,8 @@ let w_unify_to_subterm_all ~metas env evd ?(flags=default_unify_flags ()) (op,cl let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) + | Nat n -> matchrec (EConstr.unfold_nat env n) (* XXX seems very bad performance wise *) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec (Array.map snd lf)) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index e80034bee87a..2d8f3932e5f5 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -212,6 +212,7 @@ struct (* UnsafeMonomorphic is fine because the term will only be used by pat_of_constr which ignores universes *) pat_of_constr (mkApp (UnsafeMonomorphic.mkConst (Projection.constant p), [|c|])) + | Nat n -> pat_of_constr (Environ.unfold_nat env n) (* optimized Nat? *) | Int i -> Some (DInt i, []) | Float f -> Some (DFloat f, []) | String s -> Some (DString s, []) diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 97e0f79a8894..d069a6903c81 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -226,6 +226,7 @@ let constr_val_discr env sigma ts t : constr_res = | (Label _ | Nothing) as res -> Label(CaseLabel, PartialConstr res :: stack) | Everything -> Everything end + | Nat n -> decomp stack (EConstr.unfold_nat env n) (* XXX optimized Nat? *) | Rel _ | Meta _ | LetIn _ | Fix _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> Nothing in diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 77ac9bd20506..58238b6db499 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -916,6 +916,8 @@ let rec whd_state_gen ?csts flags env sigma = |_, _ -> fold () else fold () + | Nat _ -> failwith "TODO" + | CoFix cofix -> if RedFlags.red_set flags RedFlags.fCOFIX then match Stack.strip_app stack with diff --git a/tactics/hints.ml b/tactics/hints.ml index f4082bcc6f9f..ed38521a7071 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -52,6 +52,7 @@ let rec head_bound sigma t = match EConstr.kind sigma t with | Var id -> GlobRef.VarRef id | Proj (p, _, _) -> GlobRef.ConstRef (Projection.constant p) | Cast (c, _, _) -> head_bound sigma c +| Nat n -> failwith "TODO" | Evar _ | Rel _ | Meta _ | Sort _ | Fix _ | Lambda _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> raise Bound diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v new file mode 100644 index 000000000000..cb5cc03314e1 --- /dev/null +++ b/test-suite/success/bignat.v @@ -0,0 +1,3 @@ +Register nat as kernel.ind_nat. + +Check 200. diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 8209d698a631..14516017ac27 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -177,7 +177,7 @@ let fold_with_full_binders g f n acc c = let open Context.Rel.Declaration in let open Constr in match kind c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> acc + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _ -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 745ae0fae4db..22323c9c6523 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -153,7 +153,7 @@ let get_inductive_deps ~noprop env kn = | Some c -> aux env accu (EConstr.applist (EConstr.of_constr c,a)) | None -> accu) | Rel _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | Proj _ - | Construct _ | Case _ | CoFix _ | Fix _ | Meta _ | Evar _ | Int _ + | Construct _ | Case _ | CoFix _ | Fix _ | Meta _ | Evar _ | Nat _ | Int _ | Float _ | String _ | Array _ -> Termops.fold_constr_with_full_binders env sigma EConstr.push_rel aux env (List.fold_left (aux env) accu a) c in let fold i accu (constr_ctx,_) = @@ -470,7 +470,7 @@ let build_beq_scheme env handle kn = | Fix _ -> None (* Not building a type *) - | Proj _ | CoFix _ | Int _ | Float _ | String _ -> None + | Proj _ | CoFix _ | Nat _ | Int _ | Float _ | String _ -> None | Meta _ | Evar _ -> assert false (* kernel terms *) in @@ -603,7 +603,7 @@ let build_beq_scheme env handle kn = | Prod _ -> raise InductiveWithProduct (* loss of decidable if uncountable domain *) | Meta _ | Evar _ -> None (* assert false! *) - | Int _ | Float _ | String _ | Array _ -> None + | Nat _ | Int _ | Float _ | String _ | Array _ -> None in Option.map (fun c -> Term.it_mkLambda_or_LetIn c ctx) c diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 7d6f7363f93c..226c07c92adf 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2356,6 +2356,7 @@ let vernac_register ~atts qid r = if DirPath.equal (dirpath_of_string "kernel") ns then begin unsupported_attributes atts; let CPrimitives.PIE pind = match Id.to_string id with + | "ind_nat" -> CPrimitives.(PIE PIT_nat) | "ind_bool" -> CPrimitives.(PIE PIT_bool) | "ind_carry" -> CPrimitives.(PIE PIT_carry) | "ind_pair" -> CPrimitives.(PIE PIT_pair) From 0397816d1114fc205c35599bd83219260dc1c827 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Thu, 5 Mar 2026 13:51:27 +0100 Subject: [PATCH 02/36] Optimized nat operations in cbv --- pretyping/cbv.ml | 59 ++++++++++++++++++++++++++++++++----- test-suite/success/bignat.v | 53 ++++++++++++++++++++++++++++++++- 2 files changed, 103 insertions(+), 9 deletions(-) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 69e8b789e158..5783f6fed5da 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -16,6 +16,8 @@ open Esubst (**** Call by value reduction ****) +type optimized_def = Add | Mul + (* The type of terms with closure. The meaning of the constructors and * the invariants of this datatype are the following: * VAL(k,c) represents the constr c with a delayed shift of k. c must be @@ -45,6 +47,7 @@ open Esubst type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack + | OPTIMIZED of optimized_def * cbv_value | LAMBDA of int * (Name.t Constr.binder_annot * types) list * constr * cbv_value subs | PROD of Name.t Constr.binder_annot * types * types * cbv_value subs | LETIN of Name.t Constr.binder_annot * cbv_value * types * constr * cbv_value subs @@ -89,6 +92,7 @@ and cbv_stack = let rec shift_value n = function | VAL (k,t) -> VAL (k+n,t) | STACK(k,v,stk) -> STACK(k+n,v,stk) + | OPTIMIZED (o, v) -> OPTIMIZED (o, shift_value n v) (* XXX could rely on optimized values always being closed *) | PROD (na,t,u,s) -> PROD(na,t,u,subs_shft(n,s)) | LETIN (na,b,t,c,s) -> LETIN(na,shift_value n b,t,c,subs_shft(n,s)) | LAMBDA (nlams,ctxt,b,s) -> LAMBDA (nlams,ctxt,b,subs_shft (n,s)) @@ -200,7 +204,7 @@ let strip_appl head stack = | COFIX (cofix,env,app) -> (COFIX(cofix,env,[||]), stack_vect_app app stack) | CONSTRUCT (c,app) -> (CONSTRUCT(c,[||]), stack_vect_app app stack) | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_vect_app app stack) - | LETIN _ | VAL _ | STACK _ | PROD _ | LAMBDA _ | NAT _ | ARRAY _ | SYMBOL _ -> (head, stack) + | OPTIMIZED _ | LETIN _ | VAL _ | STACK _ | PROD _ | LAMBDA _ | NAT _ | ARRAY _ | SYMBOL _ -> (head, stack) let destack head stack = match head with @@ -210,7 +214,7 @@ let destack head stack = | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_vect_app app stack) | STACK (k, v, stk) -> (shift_value k v, stack_concat (shift_stack k stk) stack) | SYMBOL ({ stk } as s) -> (SYMBOL { s with stk=TOP }, stack_concat stk stack) - | LETIN _ | VAL _ | PROD _ | LAMBDA _ | NAT _ | ARRAY _ -> (head, stack) + | OPTIMIZED _ | LETIN _ | VAL _ | PROD _ | LAMBDA _ | NAT _ | ARRAY _ -> (head, stack) let rec fixp_reducible_symb_stk = function | TOP -> true @@ -420,6 +424,7 @@ and reify_value = function (* reduction under binders *) reify_stack (reify_value v) stk | STACK (n,v,stk) -> lift n (reify_stack (reify_value v) stk) + | OPTIMIZED (_, v) -> reify_value v | PROD(na,t,u,env) -> apply_env env (mkProd (na,t,u)) | LETIN(na,b,t,c,env) -> @@ -499,6 +504,26 @@ let cbv_subst_of_rel_context_instance_list mkclos sign args env = | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") in aux env (List.rev sign) args +let is_optimized_constant env cst = + List.find_map (fun (s,o) -> + if Option.equal (Environ.QGlobRef.equal env) + (Some (GlobRef.ConstRef cst)) + (Rocqlib.lib_ref_opt s) + then Some o + else None) + [ + "cbv.add", Add; + "cbv.mul", Mul; + (* tail_mul and mul behave the same on canonical inputs *) + "cbv.tail_mul", Mul; + ] + +let run_optimized_def opt stk = + match opt, stk with + | Add, APP ([NAT n; NAT m], stk) -> Some (NAT (Z.add n m), stk) + | Mul, APP ([NAT n; NAT m], stk) -> Some (NAT (Z.mul n m), stk) + | (Add | Mul), _ -> None + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -670,6 +695,12 @@ and cbv_stack_value info env = function let (envf,redfix) = contract_cofixp env cofix in cbv_stack_term info stk envf redfix + | OPTIMIZED (opt, v), stk -> + begin match run_optimized_def opt stk with + | None -> cbv_stack_value info env (v, stk) + | Some v -> cbv_stack_value info env v + end + (* constructor in a Case -> IOTA *) | (CONSTRUCT(((sp,n),_),[||]), APP(args,CASE(u,pms,_p,br,iv,ci,env,stk))) when red_set info.reds fMATCH -> @@ -755,23 +786,34 @@ and cbv_value_cache info ref = Not_found -> let v = try - let body = match ref with + let body, opt = match ref with | RelKey n -> let open Context.Rel.Declaration in - begin match Environ.lookup_rel n info.env with + let body = + begin match Environ.lookup_rel n info.env with | LocalDef (_, c, _) -> lift n c | LocalAssum _ -> raise Not_found - end + end + in + body, None | VarKey id -> let open Context.Named.Declaration in - begin match Environ.lookup_named id info.env with + let body = + begin match Environ.lookup_named id info.env with | LocalDef (_, c, _) -> c | LocalAssum _ -> raise Not_found - end + end + in + body, None | ConstKey (cst, u) -> - EConstr.Unsafe.to_constr @@ EConstr.constant_value_in info.env info.sigma (cst, EConstr.EInstance.make u) + let body = EConstr.Unsafe.to_constr @@ + EConstr.constant_value_in info.env info.sigma (cst, EConstr.EInstance.make u) + in + let opt = is_optimized_constant info.env cst in + body, opt in let v = cbv_stack_term info TOP (subs_id 0) body in + let v = match opt with None -> v | Some opt -> OPTIMIZED (opt, v) in Declarations.Def v with | Environ.NotEvaluableConst (Environ.IsPrimitive (_u,op)) -> Declarations.Primitive op @@ -978,6 +1020,7 @@ and cbv_norm_value info = function apply_stack info (cbv_norm_value info v) stk | STACK (n,v,stk) -> lift n (apply_stack info (cbv_norm_value info v) stk) + | OPTIMIZED (_, v) -> cbv_norm_value info v | PROD(na,t,u,env) -> mkProd (na,cbv_norm_term info env t,cbv_norm_term info (subs_lift env) u) | LETIN (na,b,t,c,env) -> diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index cb5cc03314e1..c74f0df75b15 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -1,3 +1,54 @@ Register nat as kernel.ind_nat. -Check 200. +(* very important: printing with number notations currently very slow *) +Set Printing All. + +Time Eval cbv in 5000000. +(* without bignat, stack overflows + with bignat, 0.8s + (time seems about linear in n, ie exponential in the size of the decimal representation) +*) + +Time Eval cbv in 1000 * 1000. +(* without bignat, stack overflows + with bignat, 1s *) + +Register Nat.mul as cbv.mul. + +Time Eval cbv in 1000 * 1000. +(* instant *) + +Time Eval cbv in 200 * 200 * 200 * 200 * 200 * 200 * 200 * 200. +(* instant *) + +Register Nat.tail_mul as cbv.tail_mul. +Time Eval cbv in 5000000. +(* instant *) +Time Eval cbv in 50000000. +(* also instant *) +Time Eval cbv in 500000000000000000000000000. +(* still instant *) + +Definition pred n := match n with S k => k | O => O end. + +Check eq_refl 0 : pred (pred 1) = 0. + +Time Eval lazy in pred ltac:(let c := eval cbv in 500000000 in exact c). +(* instant (but big + 1 would stack overflow) *) + +Fixpoint mymul n m := + match n with + | O => O + | S p => m + mymul p m + end. + +Notation "x ** y" := (mymul x y) (at level 41, right associativity). + +Register Nat.add as cbv.add. + +Time Eval cbv in 200 ** 200000000. +(* instant *) + +Time Eval cbv in 200 ** 200 ** 200 ** 200 ** 200 ** 200 ** 200 ** 200. +(* right associativity very important here: it means we have 200 * 7 recursions in mymul + instead of 200 ^ 7 *) From 0493fe0f26916f9dfa5941ba31c73576e5c342ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Fri, 6 Mar 2026 14:38:30 +0100 Subject: [PATCH 03/36] bignat must be registered at declaration time --- checker/checkInductive.ml | 7 +++- checker/values.ml | 5 ++- kernel/cPrimitives.ml | 2 - kernel/cPrimitives.mli | 1 - kernel/declarations.mli | 2 + kernel/declareops.ml | 1 + kernel/discharge.ml | 1 + kernel/entries.mli | 1 + kernel/indtypes.ml | 45 +++++++++++++++++++- kernel/mod_subst.ml | 3 ++ kernel/primred.ml | 25 ++++++----- kernel/primred.mli | 9 ++-- kernel/retroknowledge.ml | 1 + kernel/retroknowledge.mli | 4 ++ kernel/safe_typing.ml | 11 ++--- kernel/typeops.ml | 6 --- tactics/allScheme.ml | 1 + test-suite/success/bignat.v | 83 ++++++++++++++++++++++++++++++++++--- vernac/comInductive.ml | 19 +++++---- vernac/comInductive.mli | 2 + vernac/himsg.ml | 6 ++- vernac/vernacentries.ml | 8 +++- 22 files changed, 193 insertions(+), 50 deletions(-) diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index a1c6e6b83f11..011473319f59 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -105,6 +105,7 @@ let to_entry mind (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = mind_entry_universes; mind_entry_variance; mind_entry_private = mb.mind_private; + mind_entry_is_nat = mb.mind_is_nat; } let check_abstract_uctx a b = @@ -210,7 +211,9 @@ let check_inductive env mind mb = let { mind_packets; mind_finite; mind_hyps; mind_univ_hyps; mind_nparams; mind_nparams_rec; mind_params_ctxt; mind_universes; mind_template; mind_variance; mind_sec_variance; - mind_private; mind_typing_flags; } + mind_private; mind_typing_flags; + mind_is_nat; + } = (* Locally set typing flags for further typechecking *) let env = CheckFlags.set_local_flags mb.mind_typing_flags env in @@ -241,6 +244,8 @@ let check_inductive env mind mb = ignore mind_typing_flags; (* TODO non oracle flags *) + check "mind_is_nat" (Bool.equal mb.mind_is_nat mind_is_nat); + add_mind mind mb env let check_inductive env mind mb : Environ.env = diff --git a/checker/values.ml b/checker/values.ml index fbf3274d5ff2..3d0304f1d0e2 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -483,7 +483,9 @@ let v_ind_pack = v_tuple "mutual_inductive_body" v_opt (v_array v_variance); v_opt (v_array v_variance); v_opt v_bool; - v_typing_flags|] + v_typing_flags; + v_bool; + |] let v_prim_ind = v_enum "prim_ind" 6 (* Number of "Register ... as kernel.ind_..." in Primv_int63.v and PrimFloat.v *) @@ -495,6 +497,7 @@ let v_retro_action = v_sum "retro_action" 0 [| [|v_prim_ind; v_ind|]; [|v_prim_type; v_cst|]; + [|v_ind|] |] let v_retroknowledge = diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 433901e7a76a..830a122ddd2d 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -295,7 +295,6 @@ type 'a prim_type = | PT_array : (Instance.t * ind_or_type) prim_type and 'a prim_ind = - | PIT_nat : unit prim_ind | PIT_bool : unit prim_ind | PIT_carry : ind_or_type prim_ind | PIT_pair : (ind_or_type * ind_or_type) prim_ind @@ -562,7 +561,6 @@ type op_or_type = | OT_const of const let prim_ind_to_string (type a) (p : a prim_ind) = match p with - | PIT_nat -> "nat" | PIT_bool -> "bool" | PIT_carry -> "carry" | PIT_pair -> "pair" diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index c8a1aed16471..c2686ada0160 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -109,7 +109,6 @@ type 'a prim_type = | PT_array : (UVars.Instance.t * ind_or_type) prim_type and 'a prim_ind = - | PIT_nat : unit prim_ind | PIT_bool : unit prim_ind | PIT_carry : ind_or_type prim_ind | PIT_pair : (ind_or_type * ind_or_type) prim_ind diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 02b5b0e2a9fe..b5ed6835bf26 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -301,6 +301,8 @@ type mutual_inductive_body = { mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) mind_typing_flags : typing_flags; (** typing flags at the time of the inductive creation *) + + mind_is_nat : bool; } type mind_specif = mutual_inductive_body * one_inductive_body diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 7dab6c0dca99..c7bc9213c064 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -272,6 +272,7 @@ let subst_mind_body subst mib = mind_sec_variance = mib.mind_sec_variance; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; + mind_is_nat = (assert (not mib.mind_is_nat); false); } let mind_ntypes mib = Array.length mib.mind_packets diff --git a/kernel/discharge.ml b/kernel/discharge.ml index 466a76bb9681..6f8341e05bfb 100644 --- a/kernel/discharge.ml +++ b/kernel/discharge.ml @@ -208,6 +208,7 @@ let cook_inductive info mib = mind_sec_variance; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; + mind_is_nat = (assert (not mib.mind_is_nat); false); } let cook_rel_context info ctx = diff --git a/kernel/entries.mli b/kernel/entries.mli index f59c54d2d833..a4d023faea16 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -66,6 +66,7 @@ type mutual_inductive_entry = { the entry to [None] if to be inferred or [Some v] if to be checked. *) mind_entry_private : bool option; + mind_entry_is_nat : bool; } (** {6 Constants (Definition/Axiom) } *) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index efafbf9c066a..fec8d4f3cded 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -494,7 +494,7 @@ let compute_projections ind ~nparamargs ~nf_lc ~consnrealdecls = Array.of_list (List.rev rs), Array.of_list (List.rev pbs) -let build_inductive env ~sec_univs names prv univs template variance +let build_inductive env ~is_nat ~sec_univs names prv univs template variance paramsctxt kn isrecord isfinite inds nmr recargs not_prim_or_has_eta = let ntypes = Array.length inds in (* Compute the set of used section variables *) @@ -597,11 +597,52 @@ let build_inductive env ~sec_univs names prv univs template variance mind_sec_variance = sec_variance; mind_private = prv; mind_typing_flags = Environ.typing_flags env; + mind_is_nat = is_nat; } (************************************************************************) (************************************************************************) +let check_primitive_nat univs template params finite inds = + let () = match univs with Monomorphic -> () | Polymorphic _ -> + CErrors.user_err Pp.(str "Primitive nat may not be universe polymorphic.") + in + let () = if Option.has_some template then CErrors.user_err Pp.(str "Primitive nat may not be template polymorphic.") in + let () = if not @@ List.is_empty params then CErrors.user_err Pp.(str "Primitive nat may not have parameters.") in + let () = match finite with + | Finite -> () + | CoFinite | BiFinite -> CErrors.user_err Pp.(str "Primitive nat must be inductive.") + in + let (arity,_),(indices,splayed_lc),squashed = match inds with + | [|i|] -> i + | _ -> CErrors.user_err Pp.(str "Primitive nat may not be mutual.") + in + let () = if not @@ CList.is_empty indices then + CErrors.user_err Pp.(str "Primitive nat must not have indices.") + in + let () = if not @@ Sorts.is_set arity.IndTyping.sort then + (* arguably not needed to check this? *) + CErrors.user_err Pp.(str "Primitive nat must be in Set.") + in + let () = if Option.has_some squashed then + CErrors.user_err Pp.(str "Primitive nat may not be squashed.") + in + let c_0, c_S = match splayed_lc with + | [|a;b|] -> a, b + | _ -> CErrors.user_err Pp.(str "Primitive nat must have 2 constructors.") + in + (* no need to check second projection of splayed constructors: no + params, no indices and no mutual means guaranteed to be the + inductive itself. *) + let () = if not @@ CList.is_empty @@ fst c_0 then + CErrors.user_err Pp.(str "Primitive nat first constructor (for 0) may not have arguments.") + in + let () = match fst c_S with + | [LocalAssum (_,t)] when isRelN 1 t -> () + | _ -> CErrors.user_err Pp.(str "Invalid second constructor of primitive nat.") + in + () + let check_inductive env ~sec_univs kn mie = (* First type-check the inductive definition *) let (env_ar_par, univs, template, variance, record, not_prim_reason_or_has_eta, paramsctxt, inds) = @@ -616,11 +657,13 @@ let check_inductive env ~sec_univs kn mie = env_ar_par paramsctxt mie.mind_entry_finite (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) in + let () = if mie.mind_entry_is_nat then check_primitive_nat univs template paramsctxt mie.mind_entry_finite inds in (* Build the inductive packets *) let mib = build_inductive env ~sec_univs names mie.mind_entry_private univs template variance paramsctxt kn record mie.mind_entry_finite inds nmr recargs not_prim_reason_or_has_eta + ~is_nat:mie.mind_entry_is_nat in (* From this point onward, we only care if there is a reason why the primitive projection was not possible *) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index b05bf957ce20..c05f6358f97c 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -401,6 +401,9 @@ let subst_retro_action subst action = | Register_type(prim,c) -> let c' = subst_constant subst c in if c == c' then action else Register_type(prim, c') + | Register_nat ind -> + let ind' = subst_ind subst ind in + if ind == ind' then action else Register_nat ind' let rec map_kn f f' c = let func = map_kn f f' in diff --git a/kernel/primred.ml b/kernel/primred.ml index 719654b9e82e..bd9c6224e9ce 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -5,11 +5,12 @@ open Retroknowledge open Environ open CErrors -type _ action_kind = - | IncompatTypes : _ prim_type -> Constant.t action_kind - | IncompatInd : _ prim_ind -> inductive action_kind +type _ action_error = + | IncompatTypes : _ prim_type -> Constant.t action_error + | IncompatInd : _ prim_ind -> inductive action_error + | IncompatNat : inductive action_error -type exn += IncompatibleDeclarations : 'a action_kind * 'a * 'a -> exn +type exn += IncompatibleDeclarations : 'a action_error * 'a * 'a -> exn let check_same_types typ c1 c2 = if not (Constant.UserOrd.equal c1 c2) @@ -19,6 +20,10 @@ let check_same_inds ind i1 i2 = if not (Ind.UserOrd.equal i1 i2) then raise (IncompatibleDeclarations (IncompatInd ind, i1, i2)) +let check_same_nat i1 i2 = + if not (Ind.UserOrd.equal i1 i2) + then raise (IncompatibleDeclarations (IncompatNat, i1, i2)) + let add_retroknowledge retro action = match action with | Register_type(typ,c) -> @@ -46,12 +51,6 @@ let add_retroknowledge retro action = | Register_ind(pit,ind) -> begin match pit with - | PIT_nat -> - let r = - match retro.retro_nat with - | None -> ind - | Some (ind' as t) -> check_same_inds pit ind ind'; t in - { retro with retro_nat = Some r } | PIT_bool -> let r = match retro.retro_bool with @@ -92,6 +91,12 @@ let add_retroknowledge retro action = check_same_inds pit ind ind'; t in { retro with retro_f_class = Some r } end + | Register_nat ind -> + let r = + match retro.retro_nat with + | None -> ind + | Some (ind' as t) -> check_same_nat ind ind'; t in + { retro with retro_nat = Some r } let add_retroknowledge env action = set_retroknowledge env (add_retroknowledge (Environ.retroknowledge env) action) diff --git a/kernel/primred.mli b/kernel/primred.mli index 25e35d5ae2ae..2834a6c8a3ec 100644 --- a/kernel/primred.mli +++ b/kernel/primred.mli @@ -2,11 +2,12 @@ open Names open Environ (** {5 Reduction of primitives} *) -type _ action_kind = - | IncompatTypes : _ CPrimitives.prim_type -> Constant.t action_kind - | IncompatInd : _ CPrimitives.prim_ind -> inductive action_kind +type _ action_error = + | IncompatTypes : _ CPrimitives.prim_type -> Constant.t action_error + | IncompatInd : _ CPrimitives.prim_ind -> inductive action_error + | IncompatNat : inductive action_error -type exn += IncompatibleDeclarations : 'a action_kind * 'a * 'a -> exn +type exn += IncompatibleDeclarations : 'a action_error * 'a * 'a -> exn (** May raise [IncomtibleDeclarations] *) val add_retroknowledge : env -> Retroknowledge.action -> env diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 68ddbfb27033..28ebd459994d 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -56,3 +56,4 @@ let empty = { type action = | Register_ind : 'a CPrimitives.prim_ind * inductive -> action | Register_type : 'a CPrimitives.prim_type * Constant.t -> action + | Register_nat : inductive -> action diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 25464b474c18..bfa393568f78 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -38,3 +38,7 @@ val empty : retroknowledge type action = | Register_ind : 'a CPrimitives.prim_ind * inductive -> action | Register_type : 'a CPrimitives.prim_type * Constant.t -> action + | Register_nat : inductive -> action + (** Register_nat is not Register_ind because it's done together with + declaring the inductive instead of posthoc with a Register + command. *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 50b5964eb509..5ee83ec35114 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1275,7 +1275,9 @@ let add_mind l mie senv = let senv = push_context_set ~strict:true (levels, uctx) senv in senv in - (kn, why_not_prim_record), add_checked_mind kn mib senv + let senv = add_checked_mind kn mib senv in + let senv = if mib.mind_is_nat then add_retroknowledge (Register_nat (kn,0)) senv else senv in + (kn, why_not_prim_record), senv let add_mind ?typing_flags l mie senv = with_typing_flags ?typing_flags senv ~f:(add_mind l mie) @@ -1774,13 +1776,6 @@ let check_register_ind (type t) ind (r : t CPrimitives.prim_ind) env = "th constructor does not have the expected type") in let check_type_cte pos = check_type pos ind in match r with - | CPrimitives.PIT_nat -> - check_nparams 0; - check_nconstr 2; - check_name 0 "O"; - check_type_cte 0; - check_name 1 "S"; - check_type 1 (Term.mkArrow ind Relevant ind) | CPrimitives.PIT_bool -> check_nparams 0; check_nconstr 2; diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 3f3cc0b67397..a81fbed22eb0 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -969,11 +969,6 @@ let type_of_prim env u t = let float_ty () = type_of_float env in let string_ty () = type_of_string env in let array_ty u a = mkApp(type_of_array env u, [|a|]) in - let nat_ty () = - match (Environ.retroknowledge env).Retroknowledge.retro_nat with - | Some ind -> UM.mkInd ind - | None -> CErrors.user_err Pp.(str"The type bool must be registered before this primitive.") - in let bool_ty () = match (Environ.retroknowledge env).Retroknowledge.retro_bool with | Some ((ind,_),_) -> UM.mkInd ind @@ -1012,7 +1007,6 @@ let type_of_prim env u t = | PT_array -> array_ty (fst t) (tr_type (snd t)) in let tr_ind (tr_type : ind_or_type -> constr) (type t) (i : t prim_ind) (a : t) = match i, a with - | PIT_nat, () -> nat_ty () | PIT_bool, () -> bool_ty () | PIT_carry, t -> carry_ty (tr_type t) | PIT_pair, (t1, t2) -> pair_ty (tr_type t1) (tr_type t2) diff --git a/tactics/allScheme.ml b/tactics/allScheme.ml index e3522d27f309..624a91a5c8b1 100644 --- a/tactics/allScheme.ml +++ b/tactics/allScheme.ml @@ -951,6 +951,7 @@ let generate_all_aux suffix kn u sub_temp mib uparams strpos nuparams = mind_entry_universes = Polymorphic_ind_entry uctx; mind_entry_variance = Some (Array.make ulen None); mind_entry_private = mib.mind_private; + mind_entry_is_nat = false; } in (* DEBUG FUNCTIONS *) diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index c74f0df75b15..b5e48e870a10 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -1,7 +1,77 @@ -Register nat as kernel.ind_nat. +(* TODO tests that declaring a type that doesn't look like nat with + primitive_nat is rejected -(* very important: printing with number notations currently very slow *) -Set Printing All. + and that multiple primitive_nat types are rejected + (or make it supported then test that) *) + +#[primitive_nat] +Inductive N : Set := O | S (_:N). + +Fixpoint add n m {struct n} := + match n with + | O => m + | S k => S (add k m) + end where "a + b" := (add a b) : nat_scope. + +Fixpoint mul n m {struct n} := + match n with + | O => O + | S p => m + p * m + end where "a * b" := (mul a b) : nat_scope. + +Fixpoint tail_add n m := + match n with + | O => m + | S n => tail_add n (S m) + end. + +Fixpoint tail_addmul r n m := + match n with + | O => r + | S n => tail_addmul (tail_add m r) n m + end. + +Definition tail_mul n m := tail_addmul O n m. + +Local Abbreviation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))). +(* Local Abbreviation ten := ltac:(let c := constr:(ten_raw) in let c := eval cbv in c in exact c) (only parsing). *) + +Fixpoint of_uint_acc (d:Decimal.uint)(acc:N) := + match d with + | Decimal.Nil => acc + | Decimal.D0 d => of_uint_acc d (tail_mul ten acc) + | Decimal.D1 d => of_uint_acc d (S (tail_mul ten acc)) + | Decimal.D2 d => of_uint_acc d (S (S (tail_mul ten acc))) + | Decimal.D3 d => of_uint_acc d (S (S (S (tail_mul ten acc)))) + | Decimal.D4 d => of_uint_acc d (S (S (S (S (tail_mul ten acc))))) + | Decimal.D5 d => of_uint_acc d (S (S (S (S (S (tail_mul ten acc)))))) + | Decimal.D6 d => of_uint_acc d (S (S (S (S (S (S (tail_mul ten acc))))))) + | Decimal.D7 d => of_uint_acc d (S (S (S (S (S (S (S (tail_mul ten acc)))))))) + | Decimal.D8 d => of_uint_acc d (S (S (S (S (S (S (S (S (tail_mul ten acc))))))))) + | Decimal.D9 d => of_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul ten acc)))))))))) + end. + +Definition of_uint (d:Decimal.uint) := of_uint_acc d O. + +Definition of_num_uint (d:Number.uint) := + match d with + | Number.UIntDecimal d => Some (of_uint d) + | Number.UIntHexadecimal d => None + end. + +Fixpoint to_little_uint n acc := + match n with + | O => acc + | S n => to_little_uint n (Decimal.Little.succ acc) + end. + +Definition to_uint n := + Decimal.rev (to_little_uint n Decimal.zero). + +(* printing with num notation currently very slow *) +Definition to_num_uint (n:N) : option Number.uint := None. + +Number Notation N of_num_uint to_num_uint (abstract after 5000) : nat_scope. Time Eval cbv in 5000000. (* without bignat, stack overflows @@ -13,7 +83,7 @@ Time Eval cbv in 1000 * 1000. (* without bignat, stack overflows with bignat, 1s *) -Register Nat.mul as cbv.mul. +Register mul as cbv.mul. Time Eval cbv in 1000 * 1000. (* instant *) @@ -21,7 +91,7 @@ Time Eval cbv in 1000 * 1000. Time Eval cbv in 200 * 200 * 200 * 200 * 200 * 200 * 200 * 200. (* instant *) -Register Nat.tail_mul as cbv.tail_mul. +Register tail_mul as cbv.tail_mul. Time Eval cbv in 5000000. (* instant *) Time Eval cbv in 50000000. @@ -36,6 +106,7 @@ Check eq_refl 0 : pred (pred 1) = 0. Time Eval lazy in pred ltac:(let c := eval cbv in 500000000 in exact c). (* instant (but big + 1 would stack overflow) *) +(* for testing non registered mul with registered add *) Fixpoint mymul n m := match n with | O => O @@ -44,7 +115,7 @@ Fixpoint mymul n m := Notation "x ** y" := (mymul x y) (at level 41, right associativity). -Register Nat.add as cbv.add. +Register add as cbv.add. Time Eval cbv in 200 ** 200000000. (* instant *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8cfdc18778b8..4c0a0f444321 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -625,7 +625,7 @@ let variance_of_entry ~cumulative ~variances uctx = assert (lvs <= lus); Some (Array.append variances (Array.make (lus - lvs) None)) -let interp_mutual_inductive_constr ~sigma ~flags ~udecl ~variances ~ctx_params ~indnames ~arities_explicit ~arities ~template_syntax ~constructors ~env_ar ~private_ind = +let interp_mutual_inductive_constr_internal ~sigma ~flags ~udecl ~variances ~ctx_params ~indnames ~arities_explicit ~arities ~template_syntax ~constructors ~env_ar ~private_ind ~is_nat = let { poly; template; @@ -680,10 +680,15 @@ let interp_mutual_inductive_constr ~sigma ~flags ~udecl ~variances ~ctx_params ~ mind_entry_private = if private_ind then Some false else None; mind_entry_universes = univ_entry; mind_entry_variance = variance; + mind_entry_is_nat = is_nat; } in default_dep_elim, mind_ent, ubinders, global_univs +(* wrapper that just sets is_nat:false *) +let interp_mutual_inductive_constr ~sigma ~flags ~udecl ~variances ~ctx_params ~indnames ~arities_explicit ~arities ~template_syntax ~constructors ~env_ar ~private_ind = + interp_mutual_inductive_constr_internal ~sigma ~flags ~udecl ~variances ~ctx_params ~indnames ~arities_explicit ~arities ~template_syntax ~constructors ~env_ar ~private_ind ~is_nat:false + let interp_params ~unconstrained_sorts ~poly env udecl uparamsl paramsl = let sigma, udecl, variances = interp_cumul_univ_decl_opt env udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls, _locs)) = @@ -723,7 +728,7 @@ let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams ~binders:k c = in aux (env_ar_par,k) sigma c -let interp_mutual_inductive_gen env0 ~flags udecl (uparamsl,paramsl,indl) notations ~private_ind = +let interp_mutual_inductive_gen env0 ~flags ?(is_nat=false) udecl (uparamsl,paramsl,indl) notations ~private_ind = check_all_names_different env0 indl; List.iter check_param paramsl; if not (List.is_empty uparamsl) && not (List.is_empty notations) @@ -813,7 +818,7 @@ let interp_mutual_inductive_gen env0 ~flags udecl (uparamsl,paramsl,indl) notati indimpls cimpls in let arities_explicit = List.map (fun ar -> ar.ind_arity_explicit) indl in - let default_dep_elim, mie, binders, ctx = interp_mutual_inductive_constr ~flags ~sigma ~ctx_params ~udecl ~variances ~arities_explicit ~arities ~template_syntax ~constructors ~env_ar ~private_ind ~indnames in + let default_dep_elim, mie, binders, ctx = interp_mutual_inductive_constr_internal ~flags ~sigma ~ctx_params ~udecl ~variances ~arities_explicit ~arities ~template_syntax ~constructors ~env_ar ~private_ind ~indnames ~is_nat in (default_dep_elim, mie, binders, impls, ctx) @@ -909,7 +914,7 @@ let rec count_binder_expr = function | CLocalPattern {CAst.loc} :: _ -> Loc.raise ?loc (Gramlib.Grammar.ParseError "pattern with quote not allowed here") -let interp_mutual_inductive ~env ~flags ?typing_flags udecl indl ~private_ind ~uniform = +let interp_mutual_inductive ~env ~flags ?typing_flags ?is_nat udecl indl ~private_ind ~uniform = let indlocs = List.map (fun ((n,_,_,constructors),_) -> let conslocs = List.map (fun (_,(c,_)) -> c.CAst.loc) constructors in n.CAst.loc, conslocs) @@ -925,15 +930,15 @@ let interp_mutual_inductive ~env ~flags ?typing_flags udecl indl ~private_ind ~u | NonUniformParameters -> ([], params, indl), None in let env = Environ.update_typing_flags ?typing_flags env in - let default_dep_elim, mie, univ_binders, implicits, uctx = interp_mutual_inductive_gen ~flags env udecl indl where_notations ~private_ind in + let default_dep_elim, mie, univ_binders, implicits, uctx = interp_mutual_inductive_gen ~flags ?is_nat env udecl indl where_notations ~private_ind in let open Mind_decl in { mie; default_dep_elim; nuparams; univ_binders; implicits; uctx; where_notations; coercions; indlocs } -let do_mutual_inductive ~flags ?typing_flags udecl indl ~private_ind ~uniform = +let do_mutual_inductive ~flags ?typing_flags ?is_nat udecl indl ~private_ind ~uniform = let open Mind_decl in let env = Global.env () in let { mie; default_dep_elim; univ_binders; implicits; uctx; where_notations; coercions; indlocs} = - interp_mutual_inductive ~flags ~env udecl indl ?typing_flags ~private_ind ~uniform in + interp_mutual_inductive ~flags ~env ?is_nat udecl indl ?typing_flags ~private_ind ~uniform in (* Declare the global universes *) let () = Global.push_context_set uctx in (* Declare the mutual inductive block with its associated schemes *) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 2f7669bc31b2..59f503586d2d 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -30,6 +30,7 @@ type uniform_inductive_flag = val do_mutual_inductive : flags:flags -> ?typing_flags:Declarations.typing_flags + -> ?is_nat:bool -> cumul_univ_decl_expr option -> (one_inductive_expr * notation_declaration list) list -> private_ind:bool @@ -68,6 +69,7 @@ val interp_mutual_inductive : env:Environ.env -> flags:flags -> ?typing_flags:Declarations.typing_flags + -> ?is_nat:bool -> cumul_univ_decl_expr option -> (one_inductive_expr * notation_declaration list) list -> private_ind:bool diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 69aee8d76309..5cb614c10d9d 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1595,7 +1595,7 @@ let explain_inductive_error env = function (* Primitive errors *) -let explain_incompatible_prim_declarations (type a) (act:a Primred.action_kind) (x:a) (y:a) = +let explain_incompatible_prim_declarations (type a) (act:a Primred.action_error) (x:a) (y:a) = let open Primred in let env = Global.env() in (* The newer constant/inductive (either coming from Primitive or a @@ -1615,6 +1615,10 @@ let explain_incompatible_prim_declarations (type a) (act:a Primred.action_kind) let px = try pr_inductive env x with Not_found -> MutInd.print (fst x) in str "Cannot declare " ++ px ++ str " as primitive " ++ str (CPrimitives.prim_ind_to_string ind) ++ str ": " ++ pr_inductive env y ++ str " is already declared." + | IncompatNat -> + let px = try pr_inductive env x with Not_found -> MutInd.print (fst x) in + str "Cannot declare " ++ px ++ str " as primitive nat" ++ + str ": " ++ pr_inductive env y ++ str " is already declared." (* Recursion schemes errors *) let error_not_mutual_in_scheme env ind ind' = diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 226c07c92adf..3768e406f44a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1309,17 +1309,22 @@ let dump_inductive indl_for_glob decl = | Inductive _ -> () end +let is_nat_attr = Attributes.key_value_attribute ~key:"primitive_nat" ~empty:() ~values:[] + let vernac_inductive ~atts kind indl = let open Preprocessed_Mind_decl in + let atts, is_nat = Attributes.parse_with_extra is_nat_attr atts in + let is_nat = match is_nat with None -> false | Some () -> true in let indl_for_glob, decl = preprocess_inductive_decl ~atts kind indl in dump_inductive indl_for_glob decl; match decl with | Record { flags; kind; udecl; primitive_proj; records } -> + let () = if is_nat then CErrors.user_err Pp.(str "\"primitive_nat\" not supported for records.") in let _ : _ list = Record.definition_structure ~flags udecl kind ~primitive_proj records in () | Inductive { flags; udecl; typing_flags; private_ind; uniform; inductives } -> - ComInductive.do_mutual_inductive ~flags udecl inductives ?typing_flags ~private_ind ~uniform + ComInductive.do_mutual_inductive ~flags udecl inductives ?typing_flags ~private_ind ~uniform ~is_nat let preprocess_inductive_decl ~atts kind indl = snd @@ preprocess_inductive_decl ~atts kind indl @@ -2356,7 +2361,6 @@ let vernac_register ~atts qid r = if DirPath.equal (dirpath_of_string "kernel") ns then begin unsupported_attributes atts; let CPrimitives.PIE pind = match Id.to_string id with - | "ind_nat" -> CPrimitives.(PIE PIT_nat) | "ind_bool" -> CPrimitives.(PIE PIT_bool) | "ind_carry" -> CPrimitives.(PIE PIT_carry) | "ind_pair" -> CPrimitives.(PIE PIT_pair) From 7cf4c98a4568ecd4f4c6a05a2ae40dbf0da65b2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Fri, 6 Mar 2026 17:34:58 +0100 Subject: [PATCH 04/36] basic vm support for bignat --- dev/vm_printers.ml | 1 + kernel/byterun/rocq_interp.c | 49 +++++++++++++++++++++++++++ kernel/byterun/rocq_values.c | 19 +++++++++++ kernel/genOpcodeFiles.ml | 2 ++ kernel/genlambda.ml | 65 ++++++++++++++++++++++++++---------- kernel/genlambda.mli | 1 + kernel/nativecode.ml | 1 + kernel/nativeconv.ml | 4 ++- kernel/values.mli | 1 + kernel/vconv.ml | 4 ++- kernel/vm.ml | 2 +- kernel/vmbytecodes.ml | 7 +++- kernel/vmbytecodes.mli | 2 ++ kernel/vmbytegen.ml | 30 +++++++++++++++-- kernel/vmemitcodes.ml | 5 +++ kernel/vmvalues.ml | 9 ++++- pretyping/nativenorm.ml | 1 + pretyping/vnorm.ml | 3 ++ test-suite/success/bignat.v | 22 ++++++++++-- 19 files changed, 200 insertions(+), 28 deletions(-) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 9c6091bbf39a..4b5f88709c20 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -76,6 +76,7 @@ and ppwhd whd = | Vcofix _ -> print_string "cofix" | Vconst i -> print_string "C(";print_int i;print_string")" | Vblock b -> ppvblock b + | Vnat n -> printf "nat(%s)" (Z.to_string n) | Vint64 i -> printf "int64(%LiL)" i | Vfloat64 f -> printf "float64(%.17g)" f | Vstring s -> printf "string(%S)" (Pstring.to_string s) diff --git a/kernel/byterun/rocq_interp.c b/kernel/byterun/rocq_interp.c index 9438fe9b7364..12ef536efe7e 100644 --- a/kernel/byterun/rocq_interp.c +++ b/kernel/byterun/rocq_interp.c @@ -29,6 +29,17 @@ #include "rocq_memory.h" #include "rocq_values.h" +value ml_z_succ(value); +value ml_z_pred(value); + +#ifdef ARCH_SIXTYFOUR +#define Z_MAX_INT 0x3fffffffffffffff +#define Z_MIN_INT (-0x4000000000000000) +#else +#define Z_MAX_INT 0x3fffffff +#define Z_MIN_INT (-0x40000000) +#endif + #if OCAML_VERSION < 41000 extern void caml_minor_collection(void); @@ -1041,6 +1052,20 @@ value rocq_interprete Next; } + Instruct(MAKESUCC) { + print_instr("MAKESUCC"); + if (Is_accu(accu)) { + value block; + Rocq_alloc_small(block, 1, 1); + Field(block, 0) = accu; + accu = block; + } else if (Is_long(accu) && accu < Val_long(Z_MAX_INT)) { + accu = accu + 2; + } else { + accu = ml_z_succ(accu); + } + Next; + } /* Access to components of blocks */ @@ -1062,6 +1087,30 @@ value rocq_interprete Next; } + Instruct(SWITCHNAT) { + print_instr("SWITCHNAT"); + if (Is_long(accu) && Long_val(accu) == 0) { + print_instr("0"); + pc += pc[0]; + } else if (Is_accu(accu)) { + print_instr("accu"); + pc += pc[1]; + } else if (Is_block(accu) && Tag_val(accu) == 1) { + print_instr("S of unclosed"); + pc += pc[2]; + } else if (Is_long(accu)) { + print_instr("small nat"); + /* nonzero nat: cannot underflow */ + *--sp = accu - 2; + pc += pc[3]; + } else { + print_instr("big nat"); + *--sp = ml_z_pred(accu); + pc += pc[3]; + } + Next; + } + Instruct(PUSHFIELDS){ int i; int size = *pc++; diff --git a/kernel/byterun/rocq_values.c b/kernel/byterun/rocq_values.c index 845a703db551..e340f112a6a2 100644 --- a/kernel/byterun/rocq_values.c +++ b/kernel/byterun/rocq_values.c @@ -17,6 +17,10 @@ #include "rocq_memory.h" #include "rocq_values.h" #include + +#define CAML_INTERNALS +#include + /* KIND OF VALUES */ #define Setup_for_gc @@ -165,3 +169,18 @@ value rocq_curry2_1_addr(value) { } #endif + +/* although we could try to hack some ocaml code based on [compare] of + different custom kinds always producing the same thing, it risks + the ocaml compiler making incorrect assumptions that we are calling + [compare] is at sensible types. + + For instance [compare Int64.max_int (Obj.magic v)] gets optimized + assuming that [v] is a int64. +*/ +value rocq_is_int64(value v) { + if (Is_block(v) && Tag_val(v) == Custom_tag) { + return Val_bool(Custom_ops_val(v) == &caml_int64_ops); + } + return Val_bool(0); +} diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index c36242071e72..080ee2eb6aca 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -80,7 +80,9 @@ let opcodes = "MAKEBLOCK2", 1; "MAKEBLOCK3", 1; "MAKEBLOCK4", 1; + "MAKESUCC", 0; "SWITCH", -1; + "SWITCHNAT", 4; "PUSHFIELDS", 1; "GETFIELD0", 0; "GETFIELD1", 0; diff --git a/kernel/genlambda.ml b/kernel/genlambda.ml index 3c1ad926a0de..0d889619039d 100644 --- a/kernel/genlambda.ml +++ b/kernel/genlambda.ml @@ -38,7 +38,8 @@ type 'v node = | Lint of int | Lparray of 'v lambda array * 'v lambda | Lmakeblock of inductive * int * 'v lambda array - (* inductive name, constructor tag, arguments *) +(* inductive name, constructor tag, arguments *) +| Lmakesucc of 'v lambda | Lnat of Z.t | Luint of Uint63.t | Lfloat of Float64.t @@ -163,6 +164,7 @@ let rec pp_lam lam = (str "(makeblock " ++ int tag ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") + | Lmakesucc arg -> hov 1 (str "(makesucc" ++ spc() ++ pp_lam arg ++ str ")") | Lnat i -> str (Z.to_string i) | Luint i -> str (Uint63.to_string i) | Lfloat f -> str (Float64.to_string f) @@ -298,6 +300,9 @@ let map_lam_with_binders g f n lam = | Lmakeblock (inds, tag, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else mknode @@ Lmakeblock (inds, tag,args') + | Lmakesucc arg -> + let arg' = f n arg in + if arg == arg' then lam else mknode @@ Lmakesucc arg' | Lprim(kn,op,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else mknode @@ Lprim(kn,op,args') @@ -340,6 +345,7 @@ let free_rels lam = aux k accu def | Lmakeblock (_, _, args) -> Array.fold_left (fun accu lam -> aux k accu lam) accu args + | Lmakesucc arg -> aux k accu arg | Lprim (_, _, args) -> Array.fold_left (fun accu lam -> aux k accu lam) accu args | Lproj (_, arg) -> @@ -392,7 +398,7 @@ let can_subst lam = match node lam with | Lrel _ | Lvar _ | Lconst _ | Lnat _ | Luint _ | Lval _ | Lsort _ | Lind _ -> true | Levar _ | Lprod _ | Llam _ | Llet _ | Lapp _ | Lcase _ | Lfix _ | Lcofix _ -| Lparray _ | Lmakeblock _ | Lfloat _ | Lstring _ | Lprim _ | Lproj _ -> false +| Lparray _ | Lmakesucc _ | Lmakeblock _ | Lfloat _ | Lstring _ | Lprim _ | Lproj _ -> false | Lint _ -> false (* TODO: allow substitution of integers *) let simplify lam = @@ -488,6 +494,7 @@ let rec occurrence k kind lam = occurrence_args k (occurrence k kind def) args | Lprim(_,_,args) | Lmakeblock(_, _,args) -> occurrence_args k kind args + | Lmakesucc arg -> occurrence k kind arg | Lcase(_, t, a, branches) -> let kind = occurrence k (occurrence k kind t) a in let r = ref kind in @@ -520,7 +527,7 @@ let is_value lam = match node lam with | Lrel _ | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lnat _ | Lint _ | Llam _ | Lfix _ | Lcofix _ | Lfloat _ | Lstring _ -> true | Levar _ | Lprod _ | Llet _ | Lapp _ | Lcase _ -| Lparray _ | Lmakeblock _ | Lprim _ | Lproj _ -> false +| Lparray _ | Lmakesucc _ | Lmakeblock _ | Lprim _ | Lproj _ -> false let rec remove_let subst lam = match lam.node with @@ -550,27 +557,43 @@ let rec get_alias env sigma kn = (* Translation of constructors *) -let make_args start _end = - Array.init (start - _end + 1) (fun i -> mknode @@ Lrel (Anonymous, start - i)) +let make_args start end_ = + Array.init (start - end_ + 1) (fun i -> mknode @@ Lrel (Anonymous, start - i)) -let expand_constructor ind tag nparams arity = +let expand_constructor ~is_nat ind tag nparams arity = let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) let ids = Array.make (nparams + arity) anon in if Int.equal arity 0 then mkLlam ids (mknode @@ (Lint tag)) else - let args = make_args arity 1 in - mknode @@ Llam(ids, mknode @@ Lmakeblock (ind, tag, args)) + let body = if is_nat then + (* NB treating O as a normal 0-arity ctor ie Lint 0 is fine, + so this is only the S case *) + let () = assert (Int.equal arity 1) in + mknode @@ Lmakesucc (mknode @@ Lrel (Anonymous, 1)) + else + let args = make_args arity 1 in + mknode @@ Lmakeblock (ind, tag, args) + in + mknode @@ Llam(ids, body) -let makeblock as_val ind tag nparams arity args = +let makeblock ~is_nat as_val ind tag nparams arity args = let nargs = Array.length args in if nparams > 0 || nargs < arity then - mkLapp (expand_constructor ind tag nparams arity) args + mkLapp (expand_constructor ~is_nat ind tag nparams arity) args else (* The constructor is fully applied *) if arity = 0 then mknode @@ Lint tag + else if is_nat then + let () = assert (Int.equal nargs 1) in + begin match args.(0).node with + | Lnat n -> mknode @@ Lnat (Z.succ n) + | Lint n -> mknode @@ Lnat (Z.succ @@ Z.of_int n) + | _ -> mknode @@ Lmakesucc args.(0) + end else match as_val tag args with | Some v -> mknode @@ Lval v - | None -> mknode @@ Lmakeblock (ind, tag, args) + | None -> + mknode @@ Lmakeblock (ind, tag, args) (* Compilation of primitive *) @@ -608,8 +631,8 @@ module Make (Val : S) = struct (* [nparams] is the number of parameters still expected *) -let makeblock _env ind tag nparams arity args = - makeblock Val.as_value ind tag nparams arity args +let makeblock ~is_nat ind tag nparams arity args = + makeblock ~is_nat Val.as_value ind tag nparams arity args (*i Global environment *) @@ -624,7 +647,12 @@ module Cache = module ConstrTable = Hashtbl.Make(Construct.UserOrd) - type constructor_info = tag * int * int (* nparam nrealargs *) + type constructor_info = { + tag : tag; + nparams : int; + arity : int; + is_nat : bool; + } let get_construct_info cache env c : constructor_info = try ConstrTable.find cache c @@ -635,7 +663,8 @@ module Cache = let () = Val.check_inductive (mind, j) oib in let tag,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in - let r = (tag, nparams, arity) in + let is_nat = oib.mind_is_nat in + let r = { tag; nparams; arity; is_nat } in ConstrTable.add cache c r; r end @@ -800,12 +829,12 @@ and lambda_of_app cache env sigma f args = mkLapp (mknode @@ Lconst (kn, u)) (lambda_of_args cache env sigma 0 args) end | Construct ((ind,_ as c),_) -> - let tag, nparams, arity = Cache.get_construct_info cache env c in + let { Cache.tag; nparams; arity; is_nat } = Cache.get_construct_info cache env c in let nargs = Array.length args in if nparams < nargs then (* got all parameters *) let args = lambda_of_args cache env sigma nparams args in - makeblock env ind tag 0 arity args - else makeblock env ind tag (nparams - nargs) arity empty_args + makeblock ~is_nat ind tag 0 arity args + else makeblock ~is_nat ind tag (nparams - nargs) arity empty_args | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in diff --git a/kernel/genlambda.mli b/kernel/genlambda.mli index edd63a1ebc90..be3dd5d4c222 100644 --- a/kernel/genlambda.mli +++ b/kernel/genlambda.mli @@ -38,6 +38,7 @@ type 'v node = | Lparray of 'v lambda array * 'v lambda | Lmakeblock of inductive * int * 'v lambda array (* inductive name, constructor tag, arguments *) +| Lmakesucc of 'v lambda | Lnat of Z.t | Luint of Uint63.t | Lfloat of Float64.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index e20f41b9cc4d..27741c2dad99 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1539,6 +1539,7 @@ let compile_prim env decl cond paux = MLprimitive (Array_get, [|MLapp (MLglobal knot, fv_args); MLint start|]) | Lnat _ -> failwith "TODO" + | Lmakesucc _ -> failwith "TODO" | Lint tag -> MLprimitive (Mk_int, [|MLint tag|]) diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 3ff5907a6257..70c7e0968414 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -56,6 +56,8 @@ let rec conv_val env pb lvl v1 v2 cu = if Int.equal i1 i2 then cu else raise NotConvertible | Vint64 i1, Vint64 i2 -> if Int64.equal i1 i2 then cu else raise NotConvertible + | Vnat n1, Vnat n2 -> + if Z.equal n1 n2 then cu else raise NotConvertible | Vfloat64 f1, Vfloat64 f2 -> if Float64.(equal (of_float f1) (of_float f2)) then cu else raise NotConvertible @@ -80,7 +82,7 @@ let rec conv_val env pb lvl v1 v2 cu = in aux lvl (n1-1) b1 b2 0 cu | (Vfix e | Vcofix e), _ | _, (Vfix e | Vcofix e) -> Empty.abort e - | (Vaccu _ | Vprod _ | Vconst _ | Vint64 _ | Vfloat64 _ | Vstring _ | Varray _ | Vblock _), _ -> raise NotConvertible + | (Vaccu _ | Vprod _ | Vconst _ | Vnat _ | Vint64 _ | Vfloat64 _ | Vstring _ | Varray _ | Vblock _), _ -> raise NotConvertible and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in diff --git a/kernel/values.mli b/kernel/values.mli index f4ed12594999..bbf03293afcc 100644 --- a/kernel/values.mli +++ b/kernel/values.mli @@ -16,6 +16,7 @@ type ('value, 'vaccu, 'vfun, 'vprod, 'vfix, 'vcofix, 'vblock) kind = | Vcofix of 'vcofix | Vconst of int | Vblock of 'vblock + | Vnat of Z.t | Vint64 of int64 | Vfloat64 of float | Vstring of Pstring.t diff --git a/kernel/vconv.ml b/kernel/vconv.ml index d675d352a8f2..3174151ef3d8 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -86,6 +86,8 @@ and conv_whd env pb k whd1 whd2 cu = done; !rcu else raise NotConvertible + | Vnat n1, Vnat n2 -> + if Z.equal n1 n2 then cu else raise NotConvertible | Vint64 i1, Vint64 i2 -> if Int64.equal i1 i2 then cu else raise NotConvertible | Vfloat64 f1, Vfloat64 f2 -> @@ -105,7 +107,7 @@ and conv_whd env pb k whd1 whd2 cu = (* on the fly eta expansion *) conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu - | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconst _, _ | Vint64 _, _ + | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconst _, _ | Vnat _, _ | Vint64 _, _ | Vfloat64 _, _ | Vstring _, _ | Varray _, _ | Vblock _, _ | Vaccu _, _ -> raise NotConvertible diff --git a/kernel/vm.ml b/kernel/vm.ml index c46bc1b71d03..0c5d4ece13d9 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -163,7 +163,7 @@ let rec apply_stack a stk v = let apply_whd k whd = let v = val_of_rel k in match whd with - | Vprod _ | Vconst _ | Vblock _ | Vint64 _ | Vfloat64 _ | Vstring _ | Varray _ -> + | Vprod _ | Vconst _ | Vblock _ | Vnat _ | Vint64 _ | Vfloat64 _ | Vstring _ | Varray _ -> assert false | Vfun f -> reduce_fun k f | Vfix(f, None) -> diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index 0c1e8904ccdd..b84fbfe09b9c 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -65,8 +65,10 @@ type instruction = | Ksubstinstance of UVars.Instance.t | Kconst of structured_constant | Kmakeblock of int * tag + | Kmakesucc | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array + | Kswitchnat of Label.t * Label.t * Label.t * Label.t (* 0, accu, S, nonzero Z.t *) | Kpushfields of int | Kfield of int | Ksetfield of int @@ -152,6 +154,7 @@ let rec pp_instr i = str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> str "makeblock " ++ int n ++ str ", " ++ int m + | Kmakesucc -> str "makesucc" | Kmakeswitchblock(lblt,lbls,_,sz) -> str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ pp_lbl lbls ++ str ", " ++ int sz @@ -159,7 +162,9 @@ let rec pp_instr i = hv 1 (str "switch " ++ prlist_with_sep spc pp_lbl (Array.to_list lblc) ++ str " | " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblb)) + prlist_with_sep spc pp_lbl (Array.to_list lblb)) + | Kswitchnat (l0,lAcc,lS,lZ) -> + hv 1 (str "switchnat " ++ prlist_with_sep spc pp_lbl [l0;lAcc;lS;lZ]) | Kpushfields n -> str "pushfields " ++ int n | Kfield n -> str "field " ++ int n | Ksetfield n -> str "setfield " ++ int n diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index f7554601c1a4..79bc46b3e58c 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -63,8 +63,10 @@ type instruction = | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from ** the top of the stack *) + | Kmakesucc | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) + | Kswitchnat of Label.t * Label.t * Label.t * Label.t (* 0, accu, S, nonzero Z.t *) | Kpushfields of int | Kfield of int (** accu = accu[n] *) | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index ea0bfb52b7ff..e0832ea449c0 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -569,7 +569,13 @@ let rec compile_lam env cenv lam sz cont = match node lam with | Lrel(_, i) -> pos_rel i cenv sz :: cont - | Lnat _ -> failwith "TODO" + | Lnat n -> + if Obj.is_int (Obj.repr n) then + compile_structured_constant cenv (Const_b0 (Obj.magic n : int)) sz cont + else compile_structured_constant cenv (Const_val (Obj.magic n)) sz cont + + | Lmakesucc v -> + compile_lam env cenv v sz (Kmakesucc :: cont) | Lint i -> compile_structured_constant cenv (Const_b0 i) sz cont @@ -710,6 +716,7 @@ let rec compile_lam env cenv lam sz cont = let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env.env in let oib = mib.mind_packets.(snd ind) in + let lbl_nat_s = if mib.mind_is_nat then Some (ref None) else None in let lbl_consts = Array.make oib.mind_nb_constant Label.no in let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *) let nconst = Array.length branches.constant_branches in @@ -720,7 +727,8 @@ let rec compile_lam env cenv lam sz cont = let branch1, cont = make_branch cont in (* Compilation of the return type *) let ret_env = { cenv with max_stack_size = ref 0 } in - let fcode = compile_lam env ret_env t sz [Kpop sz; Kstop] in + let fcode = Kpop sz :: Kstop :: [] in + let fcode = compile_lam env ret_env t sz fcode in let fcode = ensure_stack_capacity ret_env fcode in let lbl_typ,fcode = label_code fcode in let () = push_fun env fcode in @@ -766,6 +774,13 @@ let rec compile_lam env cenv lam sz cont = let code_b = if tag < Obj.last_non_constant_constructor_tag then begin set_max_stack_size cenv (sz_b + arity); + let code_b = match lbl_nat_s with + | None -> code_b + | Some l -> + let lbl, c = label_code code_b in + l := Some lbl; + c + in Kpushfields arity :: code_b end else begin @@ -791,7 +806,16 @@ let rec compile_lam env cenv lam sz cont = in lbl_blocks.(0) <- lbl_accu; - c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: code_accu; + let kswitch = match lbl_nat_s with + | None -> Kswitch(lbl_consts,lbl_blocks) + | Some { contents = None } -> assert false + | Some { contents = Some l } -> + match lbl_consts, lbl_blocks with + | [|l0|], [|lAcc;lS|] -> + Kswitchnat(l0,lAcc,lS,l) + | _ -> assert false + in + c := Klabel lbl_sw :: kswitch :: code_accu; let code_sw = match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index 79ed7cda3b6d..21ba1410074b 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -516,6 +516,7 @@ let emit_instr env = function | Kmakeblock(n, t) -> if 0 < n && n < 4 then (out env(opMAKEBLOCK1 + n - 1); out_int env t) else (out env opMAKEBLOCK; out_int env n; out_int env t) + | Kmakesucc -> out env opMAKESUCC | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> out env opMAKESWITCHBLOCK; out_label env typlbl; out_label env swlbl; @@ -530,6 +531,10 @@ let emit_instr env = function let org = env.out_position in Array.iter (out_label_with_orig env org) tbl_const; Array.iter (out_label_with_orig env org) tbl_block + | Kswitchnat (l0, lAcc, lS, lZ) -> + out env opSWITCHNAT; + let org = env.out_position in + Array.iter (out_label_with_orig env org) [|l0;lAcc;lS;lZ|] | Kpushfields n -> out env opPUSHFIELDS;out_int env n | Kfield n -> diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 71222e8c77d2..c229ad92b3ab 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -368,6 +368,12 @@ external accumulate : unit -> tcode = "rocq_accumulate" external set_bytecode_field : Obj.t -> int -> tcode -> unit = "rocq_set_bytecode_field" let accumulate = accumulate () +external is_int64 : values -> bool = "rocq_is_int64" + +let nat_or_int64 v = + if is_int64 v then Vint64 (Obj.magic v) + else Vnat (Obj.magic v) + let whd_val (v: values) = let o = Obj.repr v in if Obj.is_int o then Vconst (Obj.obj o) @@ -385,7 +391,7 @@ let whd_val (v: values) = | VCfix -> Vfix (Obj.obj o, None) | VCfix_partial -> Vfix (Obj.obj (Obj.field o 2), Some (Obj.obj o)) | VCaccu -> Vaccu (Aid (RelKey (int_tcode (fun_code o) 1)), []) - else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) + else if Int.equal tag Obj.custom_tag then nat_or_int64 v else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else if Int.equal tag Obj.string_tag then Vstring (Obj.magic v) else @@ -661,6 +667,7 @@ and pr_kind w = | Vcofix _ -> str "Vcofix" | Vconst i -> str "Vconst(" ++ int i ++ str ")" | Vblock _b -> str "Vblock" + | Vnat n -> Format.sprintf "Vnat(%s)" (Z.to_string n) |> str | Vint64 i -> i |> Format.sprintf "Vint64(%LiL)" |> str | Vfloat64 f -> str "Vfloat64(" ++ str (Float64.(to_string (of_float f))) ++ str ")" | Vstring s -> Pstring.to_string s |> Format.sprintf "Vstring(%S)" |> str diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index c983c941768a..e5afe59a8207 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -207,6 +207,7 @@ let rec nf_val env sigma v typ = let body = nf_val env sigma (f (mk_rel_accu lvl)) codom in mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env sigma n typ + | Vnat n -> mkNat n | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vfloat64 f -> f |> Float64.of_float |> mkFloat | Vstring s -> s |> mkString diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 631c09c72da5..22dff217954d 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -86,6 +86,8 @@ let construct_of_constr const env sigma tag typ = match Constr.kind t with | Ind ((mind,_ as ind), u as indu) -> let mib,mip = lookup_mind_specif env ind in + if mib.mind_is_nat && const then mkNat (Z.of_int tag), mkIndU indu + else let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in @@ -182,6 +184,7 @@ and nf_whd env sigma whd typ = let capp,ctyp = construct_of_constr_block env sigma tag typ in let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) + | Vnat n -> mkNat n | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vfloat64 f -> f |> Float64.of_float |> mkFloat | Vstring s -> s |> mkString diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index b5e48e870a10..5ed98efd9392 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -33,8 +33,8 @@ Fixpoint tail_addmul r n m := Definition tail_mul n m := tail_addmul O n m. -Local Abbreviation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))). -(* Local Abbreviation ten := ltac:(let c := constr:(ten_raw) in let c := eval cbv in c in exact c) (only parsing). *) +Local Abbreviation ten_raw := (S (S (S (S (S (S (S (S (S (S O)))))))))). +Local Abbreviation ten := ltac:(let c := constr:(ten_raw) in let c := eval cbv in c in exact c) (only parsing). Fixpoint of_uint_acc (d:Decimal.uint)(acc:N) := match d with @@ -123,3 +123,21 @@ Time Eval cbv in 200 ** 200000000. Time Eval cbv in 200 ** 200 ** 200 ** 200 ** 200 ** 200 ** 200 ** 200. (* right associativity very important here: it means we have 200 * 7 recursions in mymul instead of 200 ^ 7 *) + +Definition vmtwo := Eval vm_compute in 1 + 1. +Check eq_refl : vmtwo = 2. +Check eq_refl 4 <: vmtwo + 2 = 4. + +(* 4611686018427387903 = int63 max_int *) +Definition vmbig := Eval vm_compute in 2 + 4611686018427387903. +Check eq_refl : vmbig = 4611686018427387905. +Check eq_refl vmbig <: vmbig = 4611686018427387905. +Check eq_refl (S vmbig) <: S vmbig = 4611686018427387906. + +Check eq_refl 0 <: pred (pred 1) = 0. + +Check eq_refl 4611686018427387900 : 4611686018427387900 = pred (pred (pred 4611686018427387903)). +Check eq_refl 4611686018427387900 <: 4611686018427387900 = pred (pred (pred 4611686018427387903)). + +Check eq_refl 4611686018427387900 : 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). +Check eq_refl 4611686018427387900 <: 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). From 430abf504ea07d1d8faa7f1c8fcf025edf501143 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 13:59:00 +0100 Subject: [PATCH 05/36] handle primitive nat in match patterns --- interp/constrintern.ml | 12 ++++++++++++ test-suite/success/bignat.v | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index bd07afd0a18b..957eb191c48d 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1784,6 +1784,16 @@ type global_reference_test = { test_kind : ?loc:Loc.t -> GlobRef.t -> unit } +let rcp_of_nat ?loc env n = + assert (Z.leq Z.zero n); + let ind = Option.get (Environ.retroknowledge env).retro_nat in + let ctor_S = GlobRef.ConstructRef (ind,2) in + let rec aux acc n = + if Z.equal n Z.zero then acc + else aux (RCPatCstr (ctor_S, [DAst.make ?loc acc])) (Z.pred n) + in + aux (RCPatCstr (ConstructRef (ind,1), [])) n + let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) @@ -1815,12 +1825,14 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = List.iter (check_allowed_ref_in_pat test_kind_inner) l | _ -> raise Not_found end + | GNat n -> () | _ -> raise Not_found)) in (* Interpret a primitive notation (part of Glob_ops.cases_pattern_of_glob_constr) *) let rec rcp_of_glob scopes x = DAst.(map_with_loc (fun ?loc -> function | GVar id -> RCPatAtom (Some (CAst.make ?loc id,scopes)) | GHole _ -> RCPatAtom None | GRef (g,_) -> RCPatCstr (g, in_patargs ?loc scopes g ~expanded:true ~no_impl:false [] []) + | GNat n -> rcp_of_nat ?loc genv n | GApp (r, l) -> begin match DAst.get r with | GRef (g,_) -> diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index 5ed98efd9392..3fb873af2aae 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -99,7 +99,7 @@ Time Eval cbv in 50000000. Time Eval cbv in 500000000000000000000000000. (* still instant *) -Definition pred n := match n with S k => k | O => O end. +Definition pred n := match n with S k => k | 0 => O end. Check eq_refl 0 : pred (pred 1) = 0. From 50acfd7884953015bf0e126a9a80084cd1bb1ec3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:11:05 +0100 Subject: [PATCH 06/36] Fix zupdate in nat stack producing conversion error --- kernel/cClosure.ml | 4 ++-- test-suite/success/bignat.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 44877a9a6b03..411f3eff201d 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -1462,8 +1462,8 @@ and knht info e t stk = | None -> ({ mark = Red; term = FProj (p, r, mk_clos e c) }, stk) | Some s -> knht info e c (s :: stk) end - | Construct _ -> knh info (mk_clos e t) stk - | (Ind _|Const _|Var _|Meta _ | Sort _ | Nat _|Int _|Float _|String _) -> (mk_clos e t, stk) + | Construct _ | Nat _ -> knh info (mk_clos e t) stk + | (Ind _|Const _|Var _|Meta _ | Sort _|Int _|Float _|String _) -> (mk_clos e t, stk) | CoFix cfx -> { mark = Cstr; term = FCoFix (cfx,e) }, stk | Lambda _ -> { mark = Cstr ; term = mk_lambda e t }, stk diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index 3fb873af2aae..cef0a60017a2 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -99,7 +99,7 @@ Time Eval cbv in 50000000. Time Eval cbv in 500000000000000000000000000. (* still instant *) -Definition pred n := match n with S k => k | 0 => O end. +Definition pred n := match n with S k => k | 0 => 0 end. Check eq_refl 0 : pred (pred 1) = 0. From 2056d74ceb6bbe09a45774988cba94bf73e57a76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:11:28 +0100 Subject: [PATCH 07/36] handle printing prim nat in debugger --- interp/notation.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/interp/notation.ml b/interp/notation.ml index 7af6ea202e35..c03a75050f97 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -342,6 +342,9 @@ let glob_prim_constr_key c = match DAst.get c with end | GProj ((cst,_), _, _) -> Some (canonical_gr (GlobRef.ConstRef cst)) | GNat n -> + if !Flags.in_debugger && Option.is_empty (Global.env () |> Environ.retroknowledge).retro_nat + then None + else let c = Environ.ctor_of_nat (Global.env()) n in Some (canonical_gr (GlobRef.ConstructRef c)) | _ -> None From 69d7e649375fda4d9c6dc2022b051bed630096da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:26:43 +0100 Subject: [PATCH 08/36] remove unused constr_pattern_eq --- pretyping/patternops.ml | 62 ---------------------------------------- pretyping/patternops.mli | 2 -- 2 files changed, 64 deletions(-) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index e0505086982f..9eea7d009cc1 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -21,68 +21,6 @@ open Mod_subst open Pattern open Environ -let case_info_pattern_eq env i1 i2 = - i1.cip_style == i2.cip_style && - Option.equal (fun i1 i2 -> QInd.equal env i1 i2) i1.cip_ind i2.cip_ind && - i1.cip_extensible == i2.cip_extensible - -let rec constr_pattern_eq env (p1:constr_pattern) p2 = match p1, p2 with -| PRef r1, PRef r2 -> QGlobRef.equal env r1 r2 -| PVar v1, PVar v2 -> Id.equal v1 v2 -| PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> - Evar.equal ev1 ev2 && List.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) ctx1 ctx2 -| PRel i1, PRel i2 -> - Int.equal i1 i2 -| PApp (t1, arg1), PApp (t2, arg2) -> - constr_pattern_eq env t1 t2 && Array.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) arg1 arg2 -| PSoApp (id1, arg1), PSoApp (id2, arg2) -> - Id.equal id1 id2 && List.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) arg1 arg2 -| PLambda (v1, t1, b1), PLambda (v2, t2, b2) -> - Name.equal v1 v2 && constr_pattern_eq env t1 t2 && constr_pattern_eq env b1 b2 -| PProd (v1, t1, b1), PProd (v2, t2, b2) -> - Name.equal v1 v2 && constr_pattern_eq env t1 t2 && constr_pattern_eq env b1 b2 -| PLetIn (v1, b1, t1, c1), PLetIn (v2, b2, t2, c2) -> - Name.equal v1 v2 && constr_pattern_eq env b1 b2 && - Option.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) t1 t2 && constr_pattern_eq env c1 c2 -| PSort s1, PSort s2 -> UnivGen.QualityOrSet.equal s1 s2 -| PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2 -| PIf (t1, l1, r1), PIf (t2, l2, r2) -> - constr_pattern_eq env t1 t2 && constr_pattern_eq env l1 l2 && constr_pattern_eq env r1 r2 -| PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) -> - case_info_pattern_eq env info1 info2 && - Option.equal (fun (nas1, p1) (nas2, p2) -> Array.equal Name.equal nas1 nas2 && constr_pattern_eq env p1 p2) p1 p2 && - constr_pattern_eq env r1 r2 && - List.equal (fun p1 p2 -> pattern_eq env p1 p2) l1 l2 -| PFix ((ln1,i1),f1), PFix ((ln2,i2),f2) -> - Array.equal Int.equal ln1 ln2 && Int.equal i1 i2 && rec_declaration_eq env f1 f2 -| PCoFix (i1,f1), PCoFix (i2,f2) -> - Int.equal i1 i2 && rec_declaration_eq env f1 f2 -| PProj (p1, t1), PProj (p2, t2) -> - QProjection.equal env p1 p2 && constr_pattern_eq env t1 t2 -| PInt i1, PInt i2 -> - Uint63.equal i1 i2 -| PFloat f1, PFloat f2 -> - Float64.equal f1 f2 -| PString s1, PString s2 -> - Pstring.equal s1 s2 -| PArray (t1, def1, ty1), PArray (t2, def2, ty2) -> - Array.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) t1 t2 && constr_pattern_eq env def1 def2 - && constr_pattern_eq env ty1 ty2 -| PExtra e, _ -> Util.Empty.abort e -| (PRef _ | PVar _ | PEvar _ | PRel _ | PApp _ | PSoApp _ - | PLambda _ | PProd _ | PLetIn _ | PSort _ | PMeta _ - | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _ | PInt _ - | PFloat _ | PString _ | PArray _), _ -> false -(** FIXME: fixpoint and cofixpoint should be relativized to pattern *) - -and pattern_eq env (i1, j1, p1) (i2, j2, p2) = - Int.equal i1 i2 && Array.equal Name.equal j1 j2 && constr_pattern_eq env p1 p2 - -and rec_declaration_eq env (n1, c1, r1) (n2, c2, r2) = - Array.equal Name.equal n1 n2 && - Array.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) c1 c2 && - Array.equal (fun c1 c2 -> constr_pattern_eq env c1 c2) r1 r2 - let rec occurn_pattern : 'a. _ -> 'a constr_pattern_r -> _ = fun (type a) n (p:a constr_pattern_r) -> match p with | PRel p -> Int.equal n p diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 23771290e59a..acbf0e2cd1b8 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -15,8 +15,6 @@ open Pattern (** {5 Functions on patterns} *) -val constr_pattern_eq : Environ.env -> constr_pattern -> constr_pattern -> bool - val subst_pattern : Environ.env -> Evd.evar_map -> substitution -> constr_pattern -> constr_pattern val subst_uninstantiated_pattern : Environ.env -> Evd.evar_map -> substitution -> uninstantiated_pattern -> uninstantiated_pattern From 0c1e1a4aeb634ce25cbb81a443a2eb4f55498799 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:33:22 +0100 Subject: [PATCH 09/36] reorganize app/proj constr_matching code a bit --- pretyping/constr_matching.ml | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 2b3aca33f545..19b8ae8f6897 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -312,23 +312,6 @@ let matches_core env sigma allow_bound_rels (binding_vars, pat) c = | _ -> raise PatternMatchingFailure end - | PApp (c1, arg1), App (c2, arg2) -> - begin match c1, EConstr.kind sigma c2 with - | PRef (GlobRef.ConstRef r), Proj (pr,_,c) when not (Environ.QConstant.equal env r (Projection.constant pr)) -> - raise PatternMatchingFailure - | PProj (pr1,c1), Proj (pr,_,c) -> - let () = if not (Int.equal (Array.length arg1) (Array.length arg2) && Environ.QProjection.equal env pr1 pr) then raise PatternMatchingFailure in - Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 - | _, Proj (pr,_,c) -> - begin match Retyping.expand_projection env sigma pr c (Array.to_list arg2) with - | term -> sorec ctx env subst p term - | exception Retyping.RetypeError _ -> raise PatternMatchingFailure - end - | _ -> - let () = if not (Int.equal (Array.length arg1) (Array.length arg2)) then raise PatternMatchingFailure in - Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 - end - | PApp (c, args), Proj (pr, _, c2) -> begin match c with | PRef (GlobRef.ConstRef c1) when not (Environ.QConstant.equal env c1 (Projection.constant pr)) -> @@ -344,6 +327,25 @@ let matches_core env sigma allow_bound_rels (binding_vars, pat) c = if Environ.QProjection.equal env p1 p2 then sorec ctx env subst c1 c2 else raise PatternMatchingFailure + | PApp (c1, arg1), App (c2, arg2) when isProj sigma c2 -> + let (pr, _, c) = destProj sigma c2 in + begin match c1 with + | PRef (GlobRef.ConstRef r) when not (Environ.QConstant.equal env r (Projection.constant pr)) -> + raise PatternMatchingFailure + | PProj (pr1,c1) -> + let () = if not (Int.equal (Array.length arg1) (Array.length arg2) && Environ.QProjection.equal env pr1 pr) then raise PatternMatchingFailure in + Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 + | _ -> + begin match Retyping.expand_projection env sigma pr c (Array.to_list arg2) with + | term -> sorec ctx env subst p term + | exception Retyping.RetypeError _ -> raise PatternMatchingFailure + end + end + + | PApp (c1, arg1), App (c2, arg2) -> + let () = if not (Int.equal (Array.length arg1) (Array.length arg2)) then raise PatternMatchingFailure in + Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 + | PProd (na1, c1, d1), Prod (na2, c2, d2) -> sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 From 3044bc2f1b625f0d4413b26bf5175d0ff7212a96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:43:26 +0100 Subject: [PATCH 10/36] Handle primitive nat in tactic patterns (constr_matching) --- interp/constrextern.ml | 1 + pretyping/constr_matching.ml | 28 +++++++++++++++++++++++++++- pretyping/pattern.mli | 1 + pretyping/patternops.ml | 9 +++++---- 4 files changed, 34 insertions(+), 5 deletions(-) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 6c077fd98d1f..b62da847e6a6 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1515,6 +1515,7 @@ let rec glob_of_pat | PSort (Qual (QConstant QProp)) -> GSort Glob_ops.glob_Prop_sort | PSort (Qual (QConstant QType | QVar _)) -> GSort Glob_ops.glob_Type_sort | PSort Set -> GSort Glob_ops.glob_Set_sort + | PNat n -> GNat n | PInt i -> GInt i | PFloat f -> GFloat f | PString s -> GString s diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 19b8ae8f6897..257c3066ae79 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -342,6 +342,32 @@ let matches_core env sigma allow_bound_rels (binding_vars, pat) c = end end + | PNat n1, Nat n2 -> + if Z.equal n1 n2 then subst + else raise PatternMatchingFailure + + | PNat n, Construct ((ind,1),_) -> + if Z.equal n Z.zero && Environ.is_nat env ind then subst + else raise PatternMatchingFailure + + | PNat n, App (c2, arg2) -> + if Array.length arg2 <> 1 then raise PatternMatchingFailure + else begin match kind sigma c2 with + | Construct ((ind,2),_) when Environ.is_nat env ind -> + sorec ctx env subst (PNat (Z.pred n)) arg2.(0) + | _ -> raise PatternMatchingFailure + end + + | PRef (ConstructRef (ind,1)), Nat n -> + if Z.equal n Z.zero && Environ.is_nat env ind then subst + else raise PatternMatchingFailure + + | PApp (PRef (ConstructRef (ind,2)), arg1), Nat n -> + if Z.equal n Z.zero || Array.length arg1 <> 1 || + not (Environ.is_nat env ind) then + raise PatternMatchingFailure + else sorec ctx env subst arg1.(0) (mkNat (Z.pred n)) + | PApp (c1, arg1), App (c2, arg2) -> let () = if not (Int.equal (Array.length arg1) (Array.length arg2)) then raise PatternMatchingFailure in Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 @@ -462,7 +488,7 @@ let matches_core env sigma allow_bound_rels (binding_vars, pat) c = | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PIf _ | PCase _ - | PFix _ | PCoFix _| PEvar _ | PInt _ | PFloat _ + | PFix _ | PCoFix _| PEvar _ | PNat _ | PInt _ | PFloat _ | PString _ | PArray _), _ -> raise PatternMatchingFailure | PExtra e, _ -> Util.Empty.abort e diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 793ad2f512c4..9af7dc47b403 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -38,6 +38,7 @@ type 'i constr_pattern_r = (int * Name.t array * 'i constr_pattern_r) list (** index of constructor, nb of args *) | PFix of (int array * int) * (Name.t array * 'i constr_pattern_r array * 'i constr_pattern_r array) | PCoFix of int * (Name.t array * 'i constr_pattern_r array * 'i constr_pattern_r array) + | PNat of Z.t | PInt of Uint63.t | PFloat of Float64.t | PString of Pstring.t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 9eea7d009cc1..0306a5b31429 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -41,7 +41,7 @@ let rec occurn_pattern : 'a. _ -> 'a constr_pattern_r -> _ (List.exists (fun (_, nas, p) -> occurn_pattern (Array.length nas + n) p) br) | PMeta _ | PSoApp _ -> true | PEvar (_,args) -> List.exists (occurn_pattern n) args - | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ | PString _ -> false + | PVar _ | PRef _ | PSort _ | PNat _ | PInt _ | PFloat _ | PString _ -> false | PFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl | PCoFix (_,(_,tl,bl)) -> @@ -67,7 +67,7 @@ let rec head_pattern_bound (t:constr_pattern) = -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern - | PCoFix _ | PInt _ | PFloat _ | PString _ | PArray _ -> + | PCoFix _ | PNat _ | PInt _ | PFloat _ | PString _ | PArray _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") | PExtra e -> Util.Empty.abort e @@ -195,7 +195,7 @@ let map_pattern_with_binders_gen (type a b) g f fgen l : a constr_pattern_r -> b | PEvar (ev,ps) -> PEvar (ev, List.map (f l) ps) | PExtra x -> fgen l x (* Non recursive *) - | (PVar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PInt _ + | (PVar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PNat _ | PInt _ | PFloat _ | PString _ as x) -> x let map_pattern_with_binders (type a) g f l (p:a constr_pattern_r) : a constr_pattern_r = @@ -223,6 +223,7 @@ let rec subst_pattern_gen | PVar _ | PEvar _ | PRel _ + | PNat _ | PInt _ | PFloat _ | PString _ -> pat @@ -526,7 +527,7 @@ let rec pat_of_raw metas vars : _ -> _ constr_pattern_r = DAst.with_loc_val (fun let names = Array.map (fun id -> Name id) ids in PCoFix (n, (names, tl, cl)) - | GNat _ -> failwith "TODO" + | GNat n -> PNat n | GInt i -> PInt i | GFloat f -> PFloat f From ab669996129c20d8c95a63d79eadda6966745d1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:46:14 +0100 Subject: [PATCH 11/36] handle primitive nats in notations (xxx should match between representations) --- interp/constrintern.ml | 2 +- interp/notation_ops.ml | 7 +++++-- interp/notation_term.mli | 1 + 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 957eb191c48d..8185821ccc77 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -880,7 +880,7 @@ let rec adjust_env env = function | NCast (c,_,_) -> adjust_env env c | NApp _ -> restart_no_binders env | NVar _ | NRef _ | NHole _ | NGenarg _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NProj _ | NInt _ | NFloat _ | NString _ | NArray _ + | NRec _ | NSort _ | NProj _ | NNat _ | NInt _ | NFloat _ | NString _ | NArray _ | NList _ | NBinderList _ -> env (* to be safe, but restart should be ok *) let subst_var loc intern_pat intern ntnvars binders (terms, binderopt, _terminopt) (renaming, env) id = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index c4225372ce9b..be7dc27ce660 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -255,6 +255,7 @@ let compare_notation_constr lt var_eq_hole (vars1,vars2) t1 t2 = aux vars renaming c1 c2; if not (Option.equal cast_kind_eq k1 k2) then raise_notrace Exit; aux vars renaming t1 t2 + | NNat n1, NNat n2 when Z.equal n1 n2 -> () | NInt i1, NInt i2 when Uint63.equal i1 i2 -> () | NFloat f1, NFloat f2 when Float64.equal f1 f2 -> () | NArray(t1,def1,ty1), NArray(t2,def2,ty2) -> @@ -263,7 +264,7 @@ let compare_notation_constr lt var_eq_hole (vars1,vars2) t1 t2 = aux vars renaming ty1 ty2 | (NRef _ | NVar _ | NApp _ | NProj _ | NHole _ | NGenarg _ | NList _ | NLambda _ | NProd _ | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NCast _ | NInt _ | NFloat _ | NString _ | NArray _), _ -> raise_notrace Exit in + | NRec _ | NSort _ | NCast _ | NNat _ | NInt _ | NFloat _ | NString _ | NArray _), _ -> raise_notrace Exit in try let _ = aux (vars1,vars2) [] t1 t2 in if not lt then @@ -466,6 +467,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat | NHole x -> GHole x | NGenarg arg -> GGenarg arg | NRef (x,u) -> GRef (x,u) + | NNat n -> GNat n | NInt i -> GInt i | NFloat f -> GFloat f | NString s -> GString s @@ -700,7 +702,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = if Option.is_empty k then forgetful := { !forgetful with forget_volatile_cast = true }; NCast (aux c, k, aux t) | GSort s -> NSort s - | GNat _ -> failwith "TODO" + | GNat n -> NNat n | GInt i -> NInt i | GFloat f -> NFloat f | GString s -> NString s @@ -909,6 +911,7 @@ let rec subst_notation_constr subst bound raw = NRec (fk,idl,dll',tl',bl') | NSort _ -> raw + | NNat _ -> raw | NInt _ -> raw | NFloat _ -> raw | NString _ -> raw diff --git a/interp/notation_term.mli b/interp/notation_term.mli index c7af11993011..0f92d427d53c 100644 --- a/interp/notation_term.mli +++ b/interp/notation_term.mli @@ -44,6 +44,7 @@ type notation_constr = notation_constr array * notation_constr array | NSort of glob_sort | NCast of notation_constr * Constr.cast_kind option * notation_constr + | NNat of Z.t | NInt of Uint63.t | NFloat of Float64.t | NString of Pstring.t From d10f76f085eaa5e4689ba9498037c3b153f39887 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 14:54:25 +0100 Subject: [PATCH 12/36] handle primitive nat in reductionops --- pretyping/reductionops.ml | 40 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7e80104d758f..008d0fc50cdf 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -707,6 +707,14 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = let ctx = expand_branch env sigma u pms (ind, i) br in applist (it_mkLambda_or_LetIn (snd br) ctx, args) +let get_nat_branch n br = + if Z.equal n Z.zero then + let _nas, br = br.(0) in + br + else + let _nas, br = br.(1) in + let n = Z.pred n in + Vars.subst1 (mkNat n) br exception PatternFailure @@ -927,7 +935,20 @@ let rec whd_state_gen flags ?metas env sigma = |_, _ -> fold () else fold () - | Nat _ -> failwith "TODO" + | Nat n -> + let use_match = RedFlags.red_set flags RedFlags.fMATCH in + let use_fix = RedFlags.red_set flags RedFlags.fFIX in + if use_match || use_fix then + match stack with + |(Stack.Case (_,_,_,_,_,br)::s') when use_match -> + let r = get_nat_branch n br in + whrec (r, s') + |(Stack.Fix (f,s')::s'') when use_fix -> + let out_sk = s' @ (Stack.append_app [|x|] s'') in + whrec (reduce_and_refold_fix env sigma f out_sk) + |(Stack.App _| Proj _ | Primitive _)::_ -> assert false + | _ -> fold () + else fold () | CoFix cofix -> if RedFlags.red_set flags RedFlags.fCOFIX then @@ -1017,7 +1038,22 @@ let local_whd_state_gen flags ?metas env sigma = |_, _ -> s else s - | Nat _ -> failwith "TODO" + | Nat n -> + let use_match = RedFlags.red_set flags RedFlags.fMATCH in + let use_fix = RedFlags.red_set flags RedFlags.fFIX in + begin match stack with + |(Stack.Case (_,_,_,_,_,br) :: s') -> + if use_match then + let r = get_nat_branch n br in + whrec (r, s') + else s + |(Stack.Fix (f,s')::s'') -> + if use_fix then + whrec (contract_fix sigma f, s' @ (Stack.append_app [|x|] s'')) + else s + |(Stack.App _ | Proj _ | Primitive _)::_ -> assert false + | [] -> s + end | CoFix cofix -> if RedFlags.red_set flags RedFlags.fCOFIX then From b36d262837133ac3eb050be0642563ae52bea7a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:01:48 +0100 Subject: [PATCH 13/36] values update --- checker/values.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/checker/values.ml b/checker/values.ml index 3d0304f1d0e2..7ad3ab36c417 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -243,6 +243,9 @@ let v_proj = v_tuple "projection" [|v_proj_repr; v_bool|] let v_uint63 = if Sys.word_size == 64 then v_int else v_int64 +(* TODO *) +let v_z = v_any + let v_constr = fix (fun v_constr -> let v_prec = @@ -275,7 +278,8 @@ let v_case_return = v_tuple_c ("case_return", [|v_tuple_c ("case_return'", [|v_a [|v_uint63|]; (* v_int *) [|v_float64|]; (* Float *) [|v_string|]; (* v_string *) - [|v_instance;v_array v_constr;v_constr;v_constr|] (* v_array *) + [|v_instance;v_array v_constr;v_constr;v_constr|]; (* v_array *) + [|v_z|]; (* nat *) |])) let v_rdecl = v_sum "rel_declaration" 0 From e04e7c6e61584ffb2e6e8b6a8bbf989bfa285811 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:04:56 +0100 Subject: [PATCH 14/36] handle primitive nat in small inversion --- pretyping/cases.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 5ccaaed54436..c437bbec7a9a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1855,6 +1855,7 @@ let build_inversion_problem ~program_mode loc env sigma tms t = let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_right_map reveal_pattern l acc in DAst.make (PatCstr (cstr,l,Anonymous)), acc + | Nat n -> reveal_pattern (EConstr.unfold_nat !!env n) acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with From b3597f268ca37afbb89230f8e4d9fee66379a842 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:09:07 +0100 Subject: [PATCH 15/36] handle primitive nat in cbn --- tactics/cbn.ml | 55 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 1 deletion(-) diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 58238b6db499..78218f2b999c 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -561,6 +561,14 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = in Vars.substl subst (snd br) +let get_nat_branch n br = + if Z.equal n Z.zero then + let _nas, br = br.(0) in + br + else + let _nas, br = br.(1) in + let n = Z.pred n in + Vars.subst1 (mkNat n) br exception PatternFailure @@ -916,7 +924,52 @@ let rec whd_state_gen ?csts flags env sigma = |_, _ -> fold () else fold () - | Nat _ -> failwith "TODO" + | Nat n -> + let use_match = RedFlags.red_set flags RedFlags.fMATCH in + let use_fix = RedFlags.red_set flags RedFlags.fFIX in + if use_match || use_fix then + match stack with + | (Stack.Case((_,_,_,_,_,br),_)::s') when use_match -> + let r = get_nat_branch n br in + whrec Cst_stack.empty (r, s') + | (Stack.Fix (f,s',cst_l)::s'') when use_fix -> + let out_sk = s' @ (Stack.append_app [|x|] s'') in + reduce_and_refold_fix whrec env sigma cst_l f out_sk + | (Stack.Cst {const;curr;remains;volatile;params=s';cst_l} :: s'') -> + begin match remains with + | [] -> + (match const with + | Stack.Cst_const const -> + (match constant_opt_value_in env const with + | None -> fold () + | Some body -> + let const = (fst const, EInstance.make (snd const)) in + let body = EConstr.of_constr body in + let cst_l = Cst_stack.add_cst ~volatile (mkConstU const) cst_l in + whrec cst_l (body, s' @ (Stack.append_app [|x|] s''))) + | Stack.Cst_proj (p,r) -> + let stack = s' @ (Stack.append_app [|x|] s'') in + match Stack.strip_n_app 0 stack with + | None -> assert false + | Some (_,arg,s'') -> + whrec Cst_stack.empty (arg, Stack.Proj (p,r,cst_l) :: s'')) + | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with + | None -> fold () + | Some (bef,arg,s''') -> + let cst_l = Stack.Cst + { const; + curr=next; + volatile; + remains=remains'; + params=s' @ (Stack.append_app [|x|] bef); + cst_l; + } + in + whrec Cst_stack.empty (arg, cst_l :: s''') + end + | (Stack.App _ | Proj _ | Primitive _)::_ -> assert false + | _ -> fold () + else fold () | CoFix cofix -> if RedFlags.red_set flags RedFlags.fCOFIX then From 2aabb8ddbcf91e42da8204ac71294b3f63fea843 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:11:19 +0100 Subject: [PATCH 16/36] handle primitive nats in hint patterns --- tactics/hints.ml | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/tactics/hints.ml b/tactics/hints.ml index ed38521a7071..beb5fdda06bf 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -41,23 +41,23 @@ type debug = Debug | Info | Off exception Bound -let rec head_bound sigma t = match EConstr.kind sigma t with -| Prod (_, _, b) -> head_bound sigma b -| LetIn (_, _, _, b) -> head_bound sigma b -| App (c, _) -> head_bound sigma c -| Case (_, _, _, _, _, c, _) -> head_bound sigma c +let rec head_bound env sigma t = match EConstr.kind sigma t with +| Prod (_, _, b) -> head_bound env sigma b +| LetIn (_, _, _, b) -> head_bound env sigma b +| App (c, _) -> head_bound env sigma c +| Case (_, _, _, _, _, c, _) -> head_bound env sigma c | Ind (ind, _) -> GlobRef.IndRef ind | Const (c, _) -> GlobRef.ConstRef c | Construct (c, _) -> GlobRef.ConstructRef c | Var id -> GlobRef.VarRef id | Proj (p, _, _) -> GlobRef.ConstRef (Projection.constant p) -| Cast (c, _, _) -> head_bound sigma c -| Nat n -> failwith "TODO" +| Cast (c, _, _) -> head_bound env sigma c +| Nat n -> ConstructRef (Environ.ctor_of_nat env n) | Evar _ | Rel _ | Meta _ | Sort _ | Fix _ | Lambda _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> raise Bound -let head_constr sigma c = - try head_bound sigma c +let head_constr env sigma c = + try head_bound env sigma c with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ (co)inductive type, (co)inductive type constructor, or projection.") @@ -885,7 +885,7 @@ let make_exact_entry env sigma info ?name (c, cty, ctx) = | Prod _ -> failwith "make_exact_entry" | _ -> let hd = - try head_bound sigma cty + try head_bound env sigma cty with Bound -> failwith "make_exact_entry" in let pri = match info.hint_priority with None -> 0 | Some p -> p in @@ -912,7 +912,7 @@ let make_apply_entry env sigma hnf info ?name (c, cty, ctx) = let ce = Clenv.mk_clenv_from env sigma' (c,cty) in let c' = Clenv.clenv_type (* ~reduce:false *) ce in let hd = - try head_bound (Clenv.clenv_evd ce) c' + try head_bound env (Clenv.clenv_evd ce) c' with Bound -> failwith "make_apply_entry" in let miss, hyps = Clenv.clenv_missing ce in let nmiss = List.length miss in @@ -1028,7 +1028,7 @@ let make_trivial env sigma r = let c,ctx = fresh_global_or_constr env sigma (IsGlobRef r) in let sigma = merge_context_set_opt sigma ctx in let t = hnf_constr env sigma (Retyping.get_type_of env sigma c) in - let hd = head_constr sigma t in + let hd = head_constr env sigma t in let h = { rhint_term = c; rhint_type = t; rhint_uctx = ctx; rhint_arty = 0 } in (Some hd, { pri=1; @@ -1210,7 +1210,7 @@ let subst_autohint (subst, obj) = match t with | None -> gr' | Some t -> - (try head_bound Evd.empty (EConstr.of_constr t.UVars.univ_abstracted_value) + (try head_bound (Global.env()) Evd.empty (EConstr.of_constr t.UVars.univ_abstracted_value) with Bound -> gr') in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in From 053f1eb805d62d6b1f48f60b03fe8f437bbfd7a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:21:36 +0100 Subject: [PATCH 17/36] handle primitive nats in simpl --- pretyping/tacred.ml | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 0b174425dbbc..326ba75cb940 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -437,7 +437,7 @@ let compute_constant_coelimination infos env sigma ref u = assert (List.is_empty args); let open Context.Rel.Declaration in srec (push_rel (LocalAssum (id,t)) env) ((id,t)::all_abs) lastref lastu g - | Construct _ -> + | Construct _ | Nat _ -> let c = it_mkLambda (applist (c', args)) all_abs in CoEliminationConstruct c | Int _ | Float _ | String _ | Array _ (* reduced by primitives *) -> @@ -598,7 +598,7 @@ let contract_cofix env sigma f (bodynum,(_names,_types,bodies as typedbodies) as bodies.(bodynum) let reducible_construct sigma c = match EConstr.kind sigma c with -| Construct _ | CoFix _ (* reduced by case *) +| Nat _ | Construct _ | CoFix _ (* reduced by case *) | Int _ | Float _ | String _ | Array _ (* reduced by primitives *) -> true | _ -> false @@ -824,7 +824,7 @@ and reduce_params infos env sigma stack l = let arg = List.nth stack i in let* rarg = whd_construct_stack infos env sigma arg in match EConstr.kind sigma (fst rarg) with - | Construct _ | Int _ | Float _ | String _ | Array _ -> + | Nat _ | Construct _ | Int _ | Float _ | String _ | Array _ -> redp (List.assign stack i (applist rarg)) l | _ -> NotReducible in @@ -922,7 +922,7 @@ and reduce_fix infos env sigma f fix stack = | Some (recargnum,recarg) -> let* (recarg'hd,_ as recarg') = whd_construct_stack infos env sigma recarg in match EConstr.kind sigma recarg'hd with - | Construct _ -> + | Construct _ | Nat _ -> let stack' = List.assign stack recargnum (applist recarg') in Reduced (contract_fix env sigma f fix, stack') | _ -> NotReducible @@ -957,6 +957,16 @@ and reduce_case infos env sigma (ci, u, pms, p, iv, c, lf) = let ctx = EConstr.expand_branch env sigma u pms cstr br in let br = it_mkLambda_or_LetIn (snd br) ctx in Reduced (applist (br, real_cargs)) + | Nat n -> + if Z.equal n Z.zero then + let _, br = lf.(0) in + Reduced br + else + let br = lf.(1) in + let cstr = Environ.ctor_of_nat env n in + let ctx = EConstr.expand_branch env sigma u pms cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + Reduced (applist (br, [mkNat (Z.pred n)])) | CoFix (bodynum,(names,_,_) as cofix) -> let cofix_def = contract_cofix env sigma f cofix in (* If the cofix_def does not reduce to a constructor, do we From a36ad8722f58377a1d375e4837b45964014254c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:23:56 +0100 Subject: [PATCH 18/36] re-fix 21683 --- kernel/inductive.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 39a3286c7272..de393230ef38 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -1534,10 +1534,9 @@ let check_one_fix cache ?evars renv recpos trees def = let c = whd_all ?evars renv.env (lift n recArg) in let hd, _ = decompose_app_list c in match kind hd with - (* XXX Nat? *) - | Construct _ -> Some (contract_fix fix, absorbed_stack) + | Construct _ | Nat _ -> Some (contract_fix fix, absorbed_stack) | CoFix _ | Ind _ | Lambda _ | Prod _ | LetIn _ - | Sort _ | Nat _ | Int _ | Float _ | String _ + | Sort _ | Int _ | Float _ | String _ | Array _ -> assert false | Rel _ | Var _ | Const _ | App _ | Case _ | Fix _ | Proj _ | Cast _ | Meta _ | Evar _ -> None) From fd4fab9ae97064fc917a559ee6992b5af789f662 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:31:35 +0100 Subject: [PATCH 19/36] handle primitive nat in tactic unification --- pretyping/unification.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ef2d3950bff4..6fde4a489d7e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1313,6 +1313,15 @@ let rec unify_0_with_initial_metas (subst : subst0) conv_at_top env pb flags m n || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2 + | Nat n1, Nat n2 when Z.equal n1 n2 -> substn + + | Nat n1, (Construct _ | App _) -> + let curm = EConstr.unfold_nat env n1 in + unirec_rec curenvnb pb opt substn ~nargs curm curn + | (Construct _ | App _), Nat n2 -> + let curn = EConstr.unfold_nat env n2 in + unirec_rec curenvnb pb opt substn ~nargs curm curn + | App (f1,l1), App (f2,l2) -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 From 78eb9ccb17d0323571408f6f1f7d5c1a114b4ff8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:40:50 +0100 Subject: [PATCH 20/36] handle primitive nat in notation in match pattern --- interp/constrintern.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 8185821ccc77..1b653b7f80e7 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2001,6 +2001,9 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = | NRef (g,_) -> ensure_kind test_kind ?loc g; DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g ~expanded:true ~no_impl:false [] args) + | NNat n -> + ensure_kind test_kind ?loc (ConstructRef (Environ.ctor_of_nat genv n)); + DAst.make ?loc @@ rcp_of_nat ?loc genv n | NApp (NRef (g,_),ntnpl) -> ensure_kind test_kind ?loc g; let ntnpl = List.map (in_not test_kind_inner loc scopes fullsubst []) ntnpl in From 37079edc2546467a3e342bfe6a9f2e119b7fc1e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 15:55:27 +0100 Subject: [PATCH 21/36] handle primitive nat in discriminate --- tactics/equality.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tactics/equality.ml b/tactics/equality.ml index 9aa1d715b553..44a65b25d7b6 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -945,6 +945,11 @@ let find_positions env sigma ~keep_proofs ~no_discr ~eqsort ~goalsort t1 t2 = (* if we cannot eliminate to Type, we cannot discriminate but we may still try to project *) project env posn allowed_elim_on_sort (applist (hd1,args1)) (applist (hd2,args2)) + | Nat n1, Nat n2 -> + if Z.equal n1 n2 then [] + else findrec posn s (EConstr.unfold_nat env n1) (EConstr.unfold_nat env n2) + | Nat n1, _ -> findrec posn s (EConstr.unfold_nat env n1) (applist (hd2,args2)) + | _, Nat n2 -> findrec posn s (applist (hd1,args1)) (EConstr.unfold_nat env n2) | Int i1, Int i2 -> if Uint63.equal i1 i2 then [] else raise (DiscrFound (List.rev posn, DInt (i1, i2))) From 714f1e4bfa49c885e56d829648bc238a3f22b123 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 16:11:40 +0100 Subject: [PATCH 22/36] handle postprocessing in number nota involving primitive nat --- interp/primNotations.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/interp/primNotations.ml b/interp/primNotations.ml index 74bd8a7088df..8b5a674c6c76 100644 --- a/interp/primNotations.ml +++ b/interp/primNotations.ml @@ -334,9 +334,24 @@ let rec constr_of_glob to_post post env sigma g = if List.exists (function ToPostHole _ -> false | _ -> true) a then raise NotAValidPrimToken; constr_of_globref env sigma r end + | GNat n -> + let ctor = GlobRef.ConstructRef (Environ.ctor_of_nat env n) in + let o = List.find_opt (fun (_,r',_) -> Environ.QGlobRef.equal env ctor r') post in + begin match o with + | None -> sigma, mkNat n + | Some _ -> + let ctor = DAst.make ?loc:g.loc @@ GRef (ctor, None) in + let g = if Z.equal n Z.zero then ctor + else DAst.make ?loc:g.loc @@ GApp (ctor, [DAst.make ?loc:g.loc @@ GNat (Z.pred n)]) + in + constr_of_glob to_post post env sigma g + end | Glob_term.GApp (gc, gcl) -> let o = match DAst.get gc with | Glob_term.GRef (r, _) -> List.find_opt (fun (_,r',_) -> Environ.QGlobRef.equal env r r') post + | GNat n -> + let r = GlobRef.ConstructRef (Environ.ctor_of_nat env n) in + List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post | _ -> None in begin match o with | None -> @@ -365,7 +380,6 @@ let rec constr_of_glob to_post post env sigma g = let sigma,cl = aux sigma a gcl in sigma,mkApp (c, Array.of_list cl) end - | Glob_term.GNat n -> sigma, mkNat n | Glob_term.GInt i -> sigma, mkInt i | Glob_term.GFloat f -> sigma, mkFloat f | Glob_term.GString s -> sigma, mkString s @@ -458,7 +472,10 @@ let rec postprocess env token_kind ?loc ty to_post post g = let o = match DAst.get g' with | Glob_term.GRef (r, None) -> - List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post + List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post + | GNat n -> + let r = GlobRef.ConstructRef (Environ.ctor_of_nat env n) in + List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post | _ -> None in match o with None -> g | Some (_, r, a) -> let rec f n a gl = match a, gl with From 8590ed5f71bf78c231e63c25b1acd9bdbb213985 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 16:38:15 +0100 Subject: [PATCH 23/36] fix detying case with evars in debugger --- pretyping/detyping.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index b60510988b3e..9f90f9b58cfb 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -338,6 +338,7 @@ let computable sigma (nas, ccl) = sinon on perd la réciprocité de la synthèse (qui, lui, engendrera un prédicat non dépendant) *) + not !Flags.in_debugger && noccur_between sigma 1 (Array.length nas) ccl let lookup_name_as_displayed env sigma t s = From 05bf3d207f3737d32171bfcbf2d802a1b9a5babb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 16:38:27 +0100 Subject: [PATCH 24/36] Handle inverting from primitive nat in evarsolve --- pretyping/evarsolve.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index e197def7a93b..4076eb430641 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -727,12 +727,16 @@ type esubst = { (** Reverse map of indices in [ealias] containing the corresponding alias *) } -let make_constructor_subst sigma sign args = +let make_constructor_subst env sigma sign args = let rec fold decls args accu = match decls, SList.view args with | _ :: _, None | [], Some _ -> assert false | [], None -> accu | LocalAssum ({ binder_name = id }, _) :: decls, Some (Some a, args) -> let accu = fold decls args accu in + let a = match EConstr.kind sigma a with + | Nat n -> EConstr.unfold_nat env n + | _ -> a + in let a', args = decompose_app sigma a in begin match EConstr.kind sigma a' with | Construct (cstr, _) -> @@ -1644,7 +1648,7 @@ let rec invert_definition unify flags choose imitate_defs let progress = ref false in let aliases = make_alias_map env evd in let subst = make_projectable_subst aliases evd sign argsv in - let cstr_subst = make_constructor_subst evd sign argsv in + let cstr_subst = make_constructor_subst env evd sign argsv in (* Projection *) let project_variable t = @@ -1762,6 +1766,10 @@ let rec invert_definition unify flags choose imitate_defs | _ -> progress := true; match + let t = match EConstr.kind !evdref t with + | Nat n -> EConstr.unfold_nat env n + | _ -> t + in let c,args = decompose_app !evdref t in match EConstr.kind !evdref c with | Construct (cstr,u) when noccur_between !evdref 1 k t -> From 306b9dd51318404faca8b1881404fcdfdec1af84 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 17:18:53 +0100 Subject: [PATCH 25/36] Nat constr contains the inductive, support multiple primitive nat types the main motivation is actually to be able to compare between representations in constr_equal --- checker/values.ml | 2 +- dev/top_printers.ml | 6 +++--- engine/eConstr.ml | 4 ++-- engine/eConstr.mli | 4 ++-- engine/namegen.ml | 4 ++-- interp/constrextern.ml | 5 +++-- interp/constrintern.ml | 15 ++++++++------- interp/notation.ml | 7 ++----- interp/notation_ops.ml | 6 +++--- interp/notation_term.mli | 2 +- interp/primNotations.ml | 28 +++++++++++++++------------- kernel/cClosure.ml | 20 ++++++++++---------- kernel/cClosure.mli | 4 ++-- kernel/constr.ml | 32 +++++++++++++++++++++++--------- kernel/constr.mli | 7 +++++-- kernel/conversion.ml | 20 +++++++++----------- kernel/environ.ml | 13 ++----------- kernel/environ.mli | 3 +-- kernel/genlambda.ml | 2 +- kernel/hConstr.ml | 4 ++-- kernel/mod_subst.ml | 3 --- kernel/primred.ml | 10 ---------- kernel/retroknowledge.ml | 3 --- kernel/retroknowledge.mli | 5 ----- kernel/safe_typing.ml | 1 - kernel/typeops.ml | 12 +++++++----- kernel/typeops.mli | 2 +- plugins/extraction/extraction.ml | 5 ++++- plugins/ltac2/tac2core.ml | 2 +- pretyping/cases.ml | 2 +- pretyping/cbv.ml | 24 ++++++++++++------------ pretyping/constr_matching.ml | 24 ++++++++++++------------ pretyping/detyping.ml | 2 +- pretyping/evarconv.ml | 8 ++++---- pretyping/evarsolve.ml | 4 ++-- pretyping/glob_ops.ml | 2 +- pretyping/glob_term.mli | 2 +- pretyping/keys.ml | 5 ++--- pretyping/nativenorm.ml | 4 +++- pretyping/pattern.mli | 2 +- pretyping/patternops.ml | 4 ++-- pretyping/pretyping.ml | 14 +++++--------- pretyping/pretyping.mli | 2 +- pretyping/reductionops.ml | 12 ++++++------ pretyping/retyping.ml | 2 +- pretyping/tacred.ml | 6 +++--- pretyping/typing.ml | 9 +++++---- pretyping/typing.mli | 2 +- pretyping/unification.ml | 12 ++++++------ pretyping/vnorm.ml | 6 ++++-- tactics/autorewrite.ml | 2 +- tactics/btermdn.ml | 2 +- tactics/cbn.ml | 8 ++++---- tactics/equality.ml | 10 +++++----- tactics/hints.ml | 26 +++++++++++++------------- 55 files changed, 208 insertions(+), 219 deletions(-) diff --git a/checker/values.ml b/checker/values.ml index 7ad3ab36c417..44bbf43fdff4 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -279,7 +279,7 @@ let v_case_return = v_tuple_c ("case_return", [|v_tuple_c ("case_return'", [|v_a [|v_float64|]; (* Float *) [|v_string|]; (* v_string *) [|v_instance;v_array v_constr;v_constr;v_constr|]; (* v_array *) - [|v_z|]; (* nat *) + [|v_ind;v_z|]; (* nat *) |])) let v_rdecl = v_sum "rel_declaration" 0 diff --git a/dev/top_printers.ml b/dev/top_printers.ml index c3982318303a..17b4cd6f8174 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -402,7 +402,7 @@ let constr_display csr = ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"," ^(array_display bl)^")" - | Nat n -> "Nat("^Z.to_string n^")" + | Nat (ind,n) -> "Nat("^(MutInd.to_string (fst ind))^Z.to_string n^")" | Int i -> "Int("^(Uint63.to_string i)^")" | Float f -> @@ -564,8 +564,8 @@ let print_pure_constr csr = print_cut(); done in print_string"{"; print_fix (); print_string"}" - | Nat n -> - print_string ("Nat("^(Z.to_string n)^")") + | Nat (ind,n) -> + print_string ("Nat("^MutInd.to_string (fst ind)^(Z.to_string n)^")") | Int i -> print_string ("Int("^(Uint63.to_string i)^")") | Float f -> diff --git a/engine/eConstr.ml b/engine/eConstr.ml index e718d1d78834..cc0b259b3427 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -209,7 +209,7 @@ let mkCoFix f = of_kind (CoFix f) let mkProj (p, r, c) = of_kind (Proj (p, r, c)) let mkArrow t1 r t2 = of_kind (Prod (make_annot Anonymous r, t1, t2)) let mkArrowR t1 t2 = mkArrow t1 ERelevance.relevant t2 -let mkNat n = of_kind (Nat n) +let mkNat ind n = of_kind (Nat (ind,n)) let mkInt i = of_kind (Int i) let mkFloat f = of_kind (Float f) let mkString s = of_kind (String s) @@ -660,7 +660,7 @@ let contract_case env _sigma (ci, (p,r), iv, c, bl) = let bl = of_branches bl in (ci, u, pms, p, iv, c, bl) -let unfold_nat env n = of_constr @@ Environ.unfold_nat env n +let unfold_nat ind n = of_constr @@ unfold_nat ind n let iter_with_full_binders env sigma g f n c = let open Context.Rel.Declaration in diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 28489b92bd12..85a3fe271637 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -179,7 +179,7 @@ val mkFix : (t, t, ERelevance.t) pfixpoint -> t val mkCoFix : (t, t, ERelevance.t) pcofixpoint -> t val mkArrow : t -> ERelevance.t -> t -> t val mkArrowR : t -> t -> t -val mkNat : Z.t -> t +val mkNat : inductive -> Z.t -> t val mkInt : Uint63.t -> t val mkFloat : Float64.t -> t val mkString : Pstring.t -> t @@ -464,7 +464,7 @@ val expand_branch : Environ.env -> Evd.evar_map -> val contract_case : Environ.env -> Evd.evar_map -> (t,t,ERelevance.t) Inductive.pexpanded_case -> case -val unfold_nat : Environ.env -> Z.t -> constr +val unfold_nat : inductive -> Z.t -> constr (** {5 Extra} *) diff --git a/engine/namegen.ml b/engine/namegen.ml index 78c176f90185..feda6633cb66 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -119,7 +119,7 @@ let head_name sigma c = (* Find the head constant of a constr if any *) | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) | Cast (c,_,_) | App (c,_) -> hdrec c | Proj (kn,_,_) -> Some (Constant.label (Projection.constant kn)) - | Nat n -> Some (Nametab.basename_of_global (ConstructRef (ctor_of_nat (Global.env()) n))) + | Nat (ind,n) -> Some (Nametab.basename_of_global (ConstructRef (ctor_of_nat ind n))) | Const _ | Ind _ | Construct _ | Var _ as c -> Some (Nametab.basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> @@ -157,7 +157,7 @@ let hdchar env sigma c = | Const (kn,_) -> lowercase_first_char (Constant.label kn) | Ind (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.IndRef x)) with Not_found when !Flags.in_debugger -> "zz") | Construct (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.ConstructRef x)) with Not_found when !Flags.in_debugger -> "zz") - | Nat n -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.ConstructRef (ctor_of_nat env n))) with _ when !Flags.in_debugger -> "zz") + | Nat (ind,n) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.ConstructRef (ctor_of_nat ind n))) with _ when !Flags.in_debugger -> "zz") | Var id -> lowercase_first_char id | Sort s -> sort_hdchar (ESorts.kind sigma s) | Rel n -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index b62da847e6a6..435fa6884aee 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1041,7 +1041,8 @@ let rec extern depth0 inctx scopes (eenv:extern_env) r = let c = extern depth true (fst scopes,(scl, snd (snd scopes))) eenv c in CCast (c, k, c') - | GNat n -> + | GNat (_,n) -> + (* XXX should use the inductive!! *) extern_prim_token_delimiter_if_required (Number NumTok.(Signed.of_bigint CHex n)) "nat" "nat_scope" (snd scopes) @@ -1515,7 +1516,7 @@ let rec glob_of_pat | PSort (Qual (QConstant QProp)) -> GSort Glob_ops.glob_Prop_sort | PSort (Qual (QConstant QType | QVar _)) -> GSort Glob_ops.glob_Type_sort | PSort Set -> GSort Glob_ops.glob_Set_sort - | PNat n -> GNat n + | PNat (ind,n) -> GNat (ind,n) | PInt i -> GInt i | PFloat f -> GFloat f | PString s -> GString s diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1b653b7f80e7..9ec6fa504efc 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1784,9 +1784,8 @@ type global_reference_test = { test_kind : ?loc:Loc.t -> GlobRef.t -> unit } -let rcp_of_nat ?loc env n = +let rcp_of_nat ?loc ind n = assert (Z.leq Z.zero n); - let ind = Option.get (Environ.retroknowledge env).retro_nat in let ctor_S = GlobRef.ConstructRef (ind,2) in let rec aux acc n = if Z.equal n Z.zero then acc @@ -1825,14 +1824,14 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = List.iter (check_allowed_ref_in_pat test_kind_inner) l | _ -> raise Not_found end - | GNat n -> () + | GNat _ -> () | _ -> raise Not_found)) in (* Interpret a primitive notation (part of Glob_ops.cases_pattern_of_glob_constr) *) let rec rcp_of_glob scopes x = DAst.(map_with_loc (fun ?loc -> function | GVar id -> RCPatAtom (Some (CAst.make ?loc id,scopes)) | GHole _ -> RCPatAtom None | GRef (g,_) -> RCPatCstr (g, in_patargs ?loc scopes g ~expanded:true ~no_impl:false [] []) - | GNat n -> rcp_of_nat ?loc genv n + | GNat (ind,n) -> rcp_of_nat ?loc ind n | GApp (r, l) -> begin match DAst.get r with | GRef (g,_) -> @@ -2001,9 +2000,11 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = | NRef (g,_) -> ensure_kind test_kind ?loc g; DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g ~expanded:true ~no_impl:false [] args) - | NNat n -> - ensure_kind test_kind ?loc (ConstructRef (Environ.ctor_of_nat genv n)); - DAst.make ?loc @@ rcp_of_nat ?loc genv n + | NNat (ind,n) -> + (* test_kind should return the same on all constructors of nat + so no need to call multiple times *) + ensure_kind test_kind ?loc (ConstructRef (ctor_of_nat ind n)); + DAst.make ?loc @@ rcp_of_nat ?loc ind n | NApp (NRef (g,_),ntnpl) -> ensure_kind test_kind ?loc g; let ntnpl = List.map (in_not test_kind_inner loc scopes fullsubst []) ntnpl in diff --git a/interp/notation.ml b/interp/notation.ml index c03a75050f97..7239d1513035 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -341,11 +341,8 @@ let glob_prim_constr_key c = match DAst.get c with | _ -> None end | GProj ((cst,_), _, _) -> Some (canonical_gr (GlobRef.ConstRef cst)) - | GNat n -> - if !Flags.in_debugger && Option.is_empty (Global.env () |> Environ.retroknowledge).retro_nat - then None - else - let c = Environ.ctor_of_nat (Global.env()) n in + | GNat (ind,n) -> + let c = Constr.ctor_of_nat ind n in Some (canonical_gr (GlobRef.ConstructRef c)) | _ -> None diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index be7dc27ce660..0e71e6d89eb3 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -255,7 +255,7 @@ let compare_notation_constr lt var_eq_hole (vars1,vars2) t1 t2 = aux vars renaming c1 c2; if not (Option.equal cast_kind_eq k1 k2) then raise_notrace Exit; aux vars renaming t1 t2 - | NNat n1, NNat n2 when Z.equal n1 n2 -> () + | NNat (ind1,n1), NNat (ind2,n2) when Z.equal n1 n2 && Ind.CanOrd.equal ind1 ind2 -> () | NInt i1, NInt i2 when Uint63.equal i1 i2 -> () | NFloat f1, NFloat f2 when Float64.equal f1 f2 -> () | NArray(t1,def1,ty1), NArray(t2,def2,ty2) -> @@ -467,7 +467,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat | NHole x -> GHole x | NGenarg arg -> GGenarg arg | NRef (x,u) -> GRef (x,u) - | NNat n -> GNat n + | NNat (ind,n) -> GNat (ind,n) | NInt i -> GInt i | NFloat f -> GFloat f | NString s -> GString s @@ -702,7 +702,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = if Option.is_empty k then forgetful := { !forgetful with forget_volatile_cast = true }; NCast (aux c, k, aux t) | GSort s -> NSort s - | GNat n -> NNat n + | GNat (ind,n) -> NNat (ind,n) | GInt i -> NInt i | GFloat f -> NFloat f | GString s -> NString s diff --git a/interp/notation_term.mli b/interp/notation_term.mli index 0f92d427d53c..f5a8999da923 100644 --- a/interp/notation_term.mli +++ b/interp/notation_term.mli @@ -44,7 +44,7 @@ type notation_constr = notation_constr array * notation_constr array | NSort of glob_sort | NCast of notation_constr * Constr.cast_kind option * notation_constr - | NNat of Z.t + | NNat of inductive * Z.t | NInt of Uint63.t | NFloat of Float64.t | NString of Pstring.t diff --git a/interp/primNotations.ml b/interp/primNotations.ml index 8b5a674c6c76..b4f7407a5fe5 100644 --- a/interp/primNotations.ml +++ b/interp/primNotations.ml @@ -187,7 +187,7 @@ type 'a token_kind = | TConst of Constant.t * 'a list | TInd of inductive * 'a list | TConstruct of constructor * 'a list -| TNat of Z.t +| TNat of inductive * Z.t | TInt of Uint63.t | TFloat of Float64.t | TString of Pstring.t @@ -217,7 +217,7 @@ let kind c = | Float f -> TFloat f | String s -> TString s | Array (_, t, u, v) -> TArray (t, u, v) - | Nat n -> TNat n + | Nat (ind,n) -> TNat (ind,n) | Rel _ | Meta _ | Evar _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Case _ | Fix _ | CoFix _ -> TOther @@ -301,7 +301,9 @@ let rec check_glob env sigma g c = try List.fold_left2_map (check_glob env) sigma gcl (Array.to_list gc'a) with Invalid_argument _ -> raise NotAValidPrimToken in sigma, mkApp (c, Array.of_list cl) - | Glob_term.GNat n, Constr.Nat n' when Z.equal n n' -> sigma, mkNat n + | Glob_term.GNat (ind,n), Constr.Nat (ind',n') + when Z.equal n n' && Environ.QInd.equal env ind ind' -> + sigma, mkNat ind n | Glob_term.GInt i, Constr.Int i' when Uint63.equal i i' -> sigma, mkInt i | Glob_term.GFloat f, Constr.Float f' when Float64.equal f f' -> sigma, mkFloat f | Glob_term.GString s, Constr.String s' when Pstring.equal s s' -> sigma, mkString s @@ -334,23 +336,23 @@ let rec constr_of_glob to_post post env sigma g = if List.exists (function ToPostHole _ -> false | _ -> true) a then raise NotAValidPrimToken; constr_of_globref env sigma r end - | GNat n -> - let ctor = GlobRef.ConstructRef (Environ.ctor_of_nat env n) in + | GNat (ind,n) -> + let ctor = GlobRef.ConstructRef (ctor_of_nat ind n) in let o = List.find_opt (fun (_,r',_) -> Environ.QGlobRef.equal env ctor r') post in begin match o with - | None -> sigma, mkNat n + | None -> sigma, mkNat ind n | Some _ -> let ctor = DAst.make ?loc:g.loc @@ GRef (ctor, None) in let g = if Z.equal n Z.zero then ctor - else DAst.make ?loc:g.loc @@ GApp (ctor, [DAst.make ?loc:g.loc @@ GNat (Z.pred n)]) + else DAst.make ?loc:g.loc @@ GApp (ctor, [DAst.make ?loc:g.loc @@ GNat (ind, Z.pred n)]) in constr_of_glob to_post post env sigma g end | Glob_term.GApp (gc, gcl) -> let o = match DAst.get gc with | Glob_term.GRef (r, _) -> List.find_opt (fun (_,r',_) -> Environ.QGlobRef.equal env r r') post - | GNat n -> - let r = GlobRef.ConstructRef (Environ.ctor_of_nat env n) in + | GNat (ind,n) -> + let r = GlobRef.ConstructRef (ctor_of_nat ind n) in List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post | _ -> None in begin match o with @@ -408,7 +410,7 @@ let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.ConstRef c, None)) | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.IndRef ind, None)) | Var id -> DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) - | Nat n -> DAst.make ?loc (Glob_term.GNat n) + | Nat (ind,n) -> DAst.make ?loc (Glob_term.GNat (ind,n)) | Int i -> DAst.make ?loc (Glob_term.GInt i) | Float f -> DAst.make ?loc (Glob_term.GFloat f) | String s -> DAst.make ?loc (Glob_term.GString s) @@ -444,7 +446,7 @@ let rec glob_of_token token_kind ?loc env sigma c = match TokenValue.kind c with let ce = DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) in let cel = List.map (glob_of_token token_kind ?loc env sigma) l in mkGApp ?loc ce cel - | TNat n -> DAst.make ?loc (GNat n) + | TNat (ind,n) -> DAst.make ?loc (GNat (ind,n)) | TInt i -> DAst.make ?loc (Glob_term.GInt i) | TFloat f -> DAst.make ?loc (Glob_term.GFloat f) | TString s -> DAst.make ?loc (Glob_term.GString s) @@ -473,8 +475,8 @@ let rec postprocess env token_kind ?loc ty to_post post g = match DAst.get g' with | Glob_term.GRef (r, None) -> List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post - | GNat n -> - let r = GlobRef.ConstructRef (Environ.ctor_of_nat env n) in + | GNat (ind,n) -> + let r = GlobRef.ConstructRef (ctor_of_nat ind n) in List.find_opt (fun (r',_,_) -> Environ.QGlobRef.equal env r r') post | _ -> None in match o with None -> g | Some (_, r, a) -> diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 411f3eff201d..6d423453c844 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -96,7 +96,7 @@ and fterm = | FProd of Name.t binder_annot * fconstr * constr * usubs | FLetIn of Name.t binder_annot * fconstr * fconstr * constr * usubs | FEvar of Evar.t * constr list * usubs * evar_repack - | FNat of Z.t + | FNat of inductive * Z.t | FInt of Uint63.t | FFloat of Float64.t | FString of Pstring.t @@ -323,7 +323,7 @@ let destFLambda clos_fun t = (usubst_binder e na,clos_fun e ty,{mark=t.mark;term=FLambda(n-1,tys,b,usubs_lift e)}) | _ -> assert false -let mkFNat n = {mark = Cstr; term = FNat n} +let mkFNat ind n = {mark = Cstr; term = FNat (ind, n)} (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) @@ -338,7 +338,7 @@ let mk_clos (e:usubs) t = | Meta _ -> {mark = Ntrl; term = FAtom t } | Ind kn -> {mark = Ntrl; term = FInd (usubst_punivs e kn) } | Construct kn -> {mark = Cstr; term = FConstruct (usubst_punivs e kn,[||]) } - | Nat n -> mkFNat n + | Nat (ind,n) -> mkFNat ind n | Int i -> {mark = Cstr; term = FInt i} | Float f -> {mark = Cstr; term = FFloat f} | String s -> {mark = Cstr; term = FString s} @@ -598,8 +598,8 @@ let rec to_constr lfts v = repack (ev, List.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a - | FNat n -> - Constr.mkNat n + | FNat (ind,n) -> + Constr.mkNat ind n | FInt i -> Constr.mkInt i | FFloat f -> @@ -945,14 +945,14 @@ let get_branch infos ci pms cterm br e = let ext = push (Array.length args - 1) [] ctx in (br, usubs_consv (Array.rev_of_list ext) e) -let get_nat_branch n br e = +let get_nat_branch ind n br e = if Z.equal n Z.zero then let _nas, br = br.(0) in br, e else let _nas, br = br.(1) in - let n = Z.sub n Z.one in - br, usubs_cons {mark = Cstr; term = FNat n} e + let n = Z.pred n in + br, usubs_cons (mkFNat ind n) e let has_valid_relevance u ind_relevance flds = let ind_relevance = UVars.subst_instance_relevance u ind_relevance in @@ -1957,7 +1957,7 @@ let rec knr info tab ~pat_state m stk = knr_ret info tab ~pat_state (mk_irrelevant, skip_irrelevant_stack info stk) else knr_ret info tab ~pat_state (m, stk) - | FNat n -> + | FNat (ind,n) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then @@ -1966,7 +1966,7 @@ let rec knr info tab ~pat_state m stk = | (ZcaseT(ci,_,_,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); (* instance on the case and instance on the constructor are compatible by typing *) - let (br, e) = get_nat_branch n br e in + let (br, e) = get_nat_branch ind n br e in knit info tab ~pat_state e br s | (Zfix(fx,par)::s) when use_fix -> let stk' = par @ append_stack [|m|] s in diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 0e9b079878bd..487099407e0f 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -48,7 +48,7 @@ type fterm = | FProd of Name.t binder_annot * fconstr * constr * usubs | FLetIn of Name.t binder_annot * fconstr * fconstr * constr * usubs | FEvar of Evar.t * constr list * usubs * evar_repack - | FNat of Z.t + | FNat of inductive * Z.t | FInt of Uint63.t | FFloat of Float64.t | FString of Pstring.t @@ -109,7 +109,7 @@ val inject : constr -> fconstr val mk_clos : usubs -> constr -> fconstr val mk_clos_vect : usubs -> constr array -> fconstr array -val mkFNat : Z.t -> fconstr +val mkFNat : inductive -> Z.t -> fconstr val zip : fconstr -> stack -> fconstr diff --git a/kernel/constr.ml b/kernel/constr.ml index 4c418d411725..5920d5c697b7 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -112,7 +112,7 @@ type ('constr, 'types, 'sort, 'univs, 'r) kind_of_term = | Float of Float64.t | String of Pstring.t | Array of 'univs * 'constr array * 'constr * 'types - | Nat of Z.t + | Nat of inductive * Z.t (* constr is the fixpoint of the previous type. *) type t = T of (t, t, Sorts.t, Instance.t, Sorts.relevance) kind_of_term [@@unboxed] @@ -361,7 +361,7 @@ let of_kind = function | Sort Sorts.SProp -> mkSProp | Sort Sorts.Prop -> mkProp | Sort Sorts.Set -> mkSet -| Nat i as k -> assert (Z.leq Z.zero i); T k +| Nat (_,i) as k -> assert (Z.leq Z.zero i); T k | k -> T k (* Construct a type *) @@ -457,7 +457,15 @@ let mkRef (gr,u) = let open GlobRef in match gr with | ConstructRef c -> mkConstructU (c,u) | VarRef x -> mkVar x -let mkNat i = of_kind @@ Nat i +let mkNat ind i = of_kind @@ Nat (ind,i) + +let ctor_of_nat natind i = + let ctor = if Z.equal i Z.zero then 1 else 2 in + natind, ctor + +let unfold_nat natind n = + if Z.equal n Z.zero then mkConstruct (natind, 1) + else mkApp (mkConstruct (natind, 2), [|mkNat natind (Z.sub n Z.one)|]) (* Constructs a primitive integer *) let mkInt i = of_kind @@ Int i @@ -908,7 +916,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq_evars eq le | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 - | Nat i1, Nat i2 -> Z.equal i1 i2 (* XXX nat vs constructor? *) + | Nat (ind1,i1), Nat (ind2,i2) -> Z.equal i1 i2 && Ind.CanOrd.equal ind1 ind2 (* XXX nat vs constructor? *) | Int i1, Int i2 -> Uint63.equal i1 i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -1079,7 +1087,9 @@ let constr_ord_int f t1 t2 = | CoFix _, _ -> -1 | _, CoFix _ -> 1 | Proj (p1,_r1,c1), Proj (p2,_r2,c2) -> compare [(Projection.CanOrd.compare, p1, p2); (f, c1, c2)] | Proj _, _ -> -1 | _, Proj _ -> 1 - | Nat i1, Nat i2 -> Z.compare i1 i2 + | Nat (ind1,i1), Nat (ind2,i2) -> + let c = Ind.CanOrd.compare ind1 ind2 in + if c <> 0 then c else Z.compare i1 i2 | Nat _, _ -> -1 | _, Nat _ -> 1 | Int i1, Int i2 -> Uint63.compare i1 i2 | Int _, _ -> -1 | _, Int _ -> 1 @@ -1186,7 +1196,7 @@ let hasheq_kind t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 - | Nat i1, Nat i2 -> Z.equal i1 i2 + | Nat (ind1,i1), Nat (ind2,i2) -> ind1 == ind2 && Z.equal i1 i2 | Int i1, Int i2 -> i1 == i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -1263,7 +1273,7 @@ let rec hash t = | String s -> combinesmall 20 (Pstring.hash s) | Array(u,t,def,ty) -> combinesmall 21 (combine4 (Instance.hash u) (hash_term_array t) (hash def) (hash ty)) - | Nat i -> combinesmall 22 (Z.hash i) + | Nat (ind,i) -> combinesmall 22 (combine (Ind.CanOrd.hash ind) (Z.hash i)) and hash_invert = function | NoInvert -> 0 @@ -1455,7 +1465,9 @@ let rec hash_term (t : t) : int * (constr,constr,_,_,_) kind_of_term = let hty, ty = sh_rec ty in let h = combine4 hu ht hdef hty in (combinesmall 21 h, Array(u,t,def,ty)) - | Nat i as t -> combinesmall 22 (Z.hash i), t + | Nat (ind,i) -> + let hind, ind = hcons_ind ind in + combinesmall 22 (combine hind (Z.hash i)), Nat (ind, i) and sh_invert civ iv = match civ, iv with | NoInvert, NoInvert -> 0, NoInvert @@ -1605,7 +1617,9 @@ let rec debug_print c = Name.print na.binder_name ++ str":" ++ debug_print ty ++ cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ str"}") - | Nat i -> str "Nat(" ++ str (Z.to_string i) ++ str ")" + | Nat (ind,i) -> + str "Nat(" ++ MutInd.print (fst ind) ++ pr_comma () ++ int (snd ind) ++ pr_comma() ++ + str (Z.to_string i) ++ str ")" | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" | Float i -> str"Float("++str (Float64.to_string i) ++ str")" | String s -> str"String("++str (Printf.sprintf "%S" (Pstring.to_string s)) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index 502ec4852264..99123fdbf25b 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -74,7 +74,10 @@ val mkVar : Id.t -> constr val mkInt : Uint63.t -> constr (** Construct an optimized nat. Must be >= 0. *) -val mkNat : Z.t -> constr +val mkNat : inductive -> Z.t -> constr + +val ctor_of_nat : inductive -> Z.t -> constructor +val unfold_nat : inductive -> Z.t -> constr (** Constructs an array *) val mkArray : UVars.Instance.t * constr array * constr * types -> constr @@ -294,7 +297,7 @@ type ('constr, 'types, 'sort, 'univs, 'r) kind_of_term = | Array of 'univs * 'constr array * 'constr * 'types (** [Array (u,vals,def,t)] is an array of [vals] in type [t] with default value [def]. [u] is a universe containing [t]. *) - | Nat of Z.t + | Nat of inductive * Z.t (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative diff --git a/kernel/conversion.ml b/kernel/conversion.ml index 04b8628ee93a..d9abb08e912a 100644 --- a/kernel/conversion.ml +++ b/kernel/conversion.ml @@ -317,7 +317,7 @@ let rec compare_under e1 c1 e2 c2 = end | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 - | Nat i1, Nat i2 -> Z.equal i1 i2 (* XXX also try to fast check nat vs constructor? *) + | Nat (ind1,i1), Nat (ind2,i2) -> Z.equal i1 i2 && Ind.CanOrd.equal ind1 ind2 (* XXX also try to fast check nat vs constructor? *) | Int i1, Int i2 -> Uint63.equal i1 i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -679,35 +679,33 @@ and eqwhnf cv_pb l2r infos (lft1, (hd1, v1) as appr1) (lft2, (hd2, v2) as appr2) eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible - | FNat n1, FNat n2 -> + | FNat (ind1,n1), FNat (ind2,n2) -> let () = assert_reduced_constructor v1 in let () = assert_reduced_constructor v2 in - if Z.equal n1 n2 then cuniv + if Z.equal n1 n2 && Ind.CanOrd.equal ind1 ind2 then cuniv else raise NotConvertible (* XXX should we expect reduction to turn fconstruct into fnat when possible? *) - | FNat n1, FConstruct (((ind2,j2),_),args2) -> + | FNat (ind1,n1), FConstruct (((ind2,j2),_),args2) -> let () = assert_reduced_constructor v1 in let () = assert_reduced_constructor v2 in - let natind = Option.get (Environ.retroknowledge @@ info_env infos.cnv_inf).retro_nat in - if not (Ind.CanOrd.equal natind ind2) then raise NotConvertible + if not (Ind.CanOrd.equal ind1 ind2) then raise NotConvertible else if Z.equal n1 Z.zero then if Int.equal j2 1 && Array.is_empty args2 then cuniv else raise NotConvertible else if Int.equal j2 2 && Int.equal (Array.length args2) 1 then - ccnv CONV l2r infos lft1 lft2 (mkFNat (Z.sub n1 Z.one)) args2.(0) cuniv + ccnv CONV l2r infos lft1 lft2 (mkFNat ind1 (Z.sub n1 Z.one)) args2.(0) cuniv else raise NotConvertible - | FConstruct (((ind1,j1),_),args1), FNat n2 -> + | FConstruct (((ind1,j1),_),args1), FNat (ind2,n2) -> let () = assert_reduced_constructor v1 in let () = assert_reduced_constructor v2 in - let natind = Option.get (Environ.retroknowledge @@ info_env infos.cnv_inf).retro_nat in - if not (Ind.CanOrd.equal ind1 natind) then raise NotConvertible + if not (Ind.CanOrd.equal ind1 ind2) then raise NotConvertible else if Z.equal n2 Z.zero then if Int.equal j1 1 && Array.is_empty args1 then cuniv else raise NotConvertible else if Int.equal j1 2 && Int.equal (Array.length args1) 1 then - ccnv CONV l2r infos lft1 lft2 args1.(0) (mkFNat (Z.sub n2 Z.one)) cuniv + ccnv CONV l2r infos lft1 lft2 args1.(0) (mkFNat ind2 (Z.sub n2 Z.one)) cuniv else raise NotConvertible (* Eta expansion of records *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 9f7bc4ab8cf3..5845fd0df49e 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -1130,17 +1130,8 @@ end module QGlobRef = HackQ(GlobRef)(GlobRef.Map_env) let is_nat env ind = - Option.equal (QInd.equal env) (Some ind) env.retroknowledge.retro_nat - -let ctor_of_nat env i = - let natind = Option.get (retroknowledge env).retro_nat in - let ctor = if Z.equal i Z.zero then 1 else 2 in - natind, ctor - -let unfold_nat env n = - let natind = Option.get (retroknowledge env).retro_nat in - if Z.equal n Z.zero then UnsafeMonomorphic.mkConstruct (natind, 1) - else mkApp (UnsafeMonomorphic.mkConstruct (natind, 2), [|mkNat (Z.sub n Z.one)|]) + let mib = lookup_mind (fst ind) env in + mib.mind_is_nat let rec constant_dependencies_with_cache env cache kn = match DepCache.get kn cache with diff --git a/kernel/environ.mli b/kernel/environ.mli index bd86ef0fd682..bee7766e8240 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -498,9 +498,8 @@ val retroknowledge : env -> Retroknowledge.retroknowledge val constant_depends_on : env -> Constant.t -> Constant.t -> bool (** {5 Internals} *) + val is_nat : env -> inductive -> bool -val ctor_of_nat : env -> Z.t -> constructor -val unfold_nat : env -> Z.t -> constr module Internal : sig (** Makes the qvars treated as above prop. diff --git a/kernel/genlambda.ml b/kernel/genlambda.ml index 0d889619039d..89e4b3ff6d0f 100644 --- a/kernel/genlambda.ml +++ b/kernel/genlambda.ml @@ -795,7 +795,7 @@ let rec lambda_of_constr cache env sigma c = let lbodies = lambda_of_args cache env sigma 0 rec_bodies in mknode @@ Lcofix(init, (names, ltypes, lbodies)) - | Nat i -> mknode @@ Lnat i + | Nat (_,i) -> mknode @@ Lnat i | Int i -> mknode @@ Luint i diff --git a/kernel/hConstr.ml b/kernel/hConstr.ml index 8290e3efce0a..c1f50c61aa17 100644 --- a/kernel/hConstr.ml +++ b/kernel/hConstr.ml @@ -285,7 +285,7 @@ let hash_kind = let open Hashset.Combine in function | Float f -> combinesmall 19 (Float64.hash f) | String s -> combinesmall 20 (Pstring.hash s) | Array (u,t,def,ty) -> combinesmall 21 (combine4 (UVars.Instance.hash u) (hash_array hash t) def.hash ty.hash) - | Nat i -> combinesmall 22 (Z.hash i) + | Nat (ind,i) -> combinesmall 22 (combine (Ind.UserOrd.hash ind) (Z.hash i)) let kind_to_constr = function | Rel n -> mkRel n @@ -316,7 +316,7 @@ let kind_to_constr = function | Float f -> mkFloat f | String s -> mkString s | Array (u,t,def,ty) -> mkArray (u,Array.map self t,def.self,ty.self) - | Nat i -> mkNat i + | Nat (ind,i) -> mkNat ind i let of_kind_nohashcons = function | App (c, [||]) -> c diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index c05f6358f97c..b05bf957ce20 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -401,9 +401,6 @@ let subst_retro_action subst action = | Register_type(prim,c) -> let c' = subst_constant subst c in if c == c' then action else Register_type(prim, c') - | Register_nat ind -> - let ind' = subst_ind subst ind in - if ind == ind' then action else Register_nat ind' let rec map_kn f f' c = let func = map_kn f f' in diff --git a/kernel/primred.ml b/kernel/primred.ml index bd9c6224e9ce..4a23b226e6ec 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -20,10 +20,6 @@ let check_same_inds ind i1 i2 = if not (Ind.UserOrd.equal i1 i2) then raise (IncompatibleDeclarations (IncompatInd ind, i1, i2)) -let check_same_nat i1 i2 = - if not (Ind.UserOrd.equal i1 i2) - then raise (IncompatibleDeclarations (IncompatNat, i1, i2)) - let add_retroknowledge retro action = match action with | Register_type(typ,c) -> @@ -91,12 +87,6 @@ let add_retroknowledge retro action = check_same_inds pit ind ind'; t in { retro with retro_f_class = Some r } end - | Register_nat ind -> - let r = - match retro.retro_nat with - | None -> ind - | Some (ind' as t) -> check_same_nat ind ind'; t in - { retro with retro_nat = Some r } let add_retroknowledge env action = set_retroknowledge env (add_retroknowledge (Environ.retroknowledge env) action) diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 28ebd459994d..9b92c7fa9018 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -36,7 +36,6 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) - retro_nat : inductive option; } let empty = { @@ -50,10 +49,8 @@ let empty = { retro_cmp = None; retro_f_cmp = None; retro_f_class = None; - retro_nat = None; } type action = | Register_ind : 'a CPrimitives.prim_ind * inductive -> action | Register_type : 'a CPrimitives.prim_type * Constant.t -> action - | Register_nat : inductive -> action diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index bfa393568f78..9202cd9e7ee3 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -30,7 +30,6 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) - retro_nat : inductive option; } val empty : retroknowledge @@ -38,7 +37,3 @@ val empty : retroknowledge type action = | Register_ind : 'a CPrimitives.prim_ind * inductive -> action | Register_type : 'a CPrimitives.prim_type * Constant.t -> action - | Register_nat : inductive -> action - (** Register_nat is not Register_ind because it's done together with - declaring the inductive instead of posthoc with a Register - command. *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 5ee83ec35114..2d3bc83a8c91 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1276,7 +1276,6 @@ let add_mind l mie senv = senv in let senv = add_checked_mind kn mib senv in - let senv = if mib.mind_is_nat then add_retroknowledge (Register_nat (kn,0)) senv else senv in (kn, why_not_prim_record), senv let add_mind ?typing_flags l mie senv = diff --git a/kernel/typeops.ml b/kernel/typeops.ml index a81fbed22eb0..7bd2f59d1bac 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -316,10 +316,11 @@ let type_of_prim_type _env u (type a) (prim : a CPrimitives.prim_type) = match p | _ -> anomaly Pp.(str"universe instance for array type should have length 1") end -let type_of_nat env = -match (Environ.retroknowledge env).Retroknowledge.retro_nat with - | Some c -> UnsafeMonomorphic.mkInd c - | None -> CErrors.user_err Pp.(str"The type nat must be registered before this construction can be typechecked.") +let type_of_nat env ind n = + assert (Z.leq Z.zero n); + let mib = Environ.lookup_mind (fst ind) env in + assert mib.mind_is_nat; + UnsafeMonomorphic.mkInd ind let type_of_int env = match (Environ.retroknowledge env).Retroknowledge.retro_int63 with @@ -839,7 +840,8 @@ and execute_aux tbl env cstr = fix_ty (* Primitive types *) - | Nat n -> assert (Z.leq Z.zero n); type_of_nat env + | Nat (ind,n) -> + type_of_nat env ind n | Int _ -> type_of_int env | Float _ -> type_of_float env | String _ -> type_of_string env diff --git a/kernel/typeops.mli b/kernel/typeops.mli index a0fbf475c269..091ba9eefa45 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -77,7 +77,7 @@ val check_hyps_inclusion : env -> ?evars:CClosure.evar_handler -> (** Types for primitives *) -val type_of_nat : env -> types +val type_of_nat : env -> inductive -> Z.t -> types val type_of_int : env -> types val type_of_float : env -> types val type_of_string : env -> types diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index ec2a9cc2adc0..84fae8b44675 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -757,7 +757,10 @@ let rec extract_term table env sg mle mlt c args = 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 - | Nat n -> assert (args = []); extract_term table env sg mle mlt (EConstr.unfold_nat env n) [] + | Nat (ind,n) -> + (* XXX extraction option to use zarith *) + assert (args = []); + extract_term table env sg mle mlt (EConstr.unfold_nat ind n) [] | Int i -> assert (args = []); MLuint i | Float f -> assert (args = []); MLfloat f | String s -> assert (args = []); MLstring s diff --git a/plugins/ltac2/tac2core.ml b/plugins/ltac2/tac2core.ml index 51ac5b241fb9..57bd37101e62 100644 --- a/plugins/ltac2/tac2core.ml +++ b/plugins/ltac2/tac2core.ml @@ -586,7 +586,7 @@ let () = Tac2ffi.of_constr def; Tac2ffi.of_constr ty; |] - | Nat n -> failwith "TODO" + | Nat _ -> failwith "TODO" let () = define "constr_make" (valexpr @-> eret constr) @@ fun knd env sigma -> diff --git a/pretyping/cases.ml b/pretyping/cases.ml index c437bbec7a9a..1ecd4b2bb518 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1855,7 +1855,7 @@ let build_inversion_problem ~program_mode loc env sigma tms t = let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_right_map reveal_pattern l acc in DAst.make (PatCstr (cstr,l,Anonymous)), acc - | Nat n -> reveal_pattern (EConstr.unfold_nat !!env n) acc + | Nat (ind,n) -> reveal_pattern (EConstr.unfold_nat ind n) acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 5783f6fed5da..d8801d96f162 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -55,7 +55,7 @@ type cbv_value = | COFIX of cofixpoint * cbv_value subs * cbv_value array | CONSTRUCT of constructor UVars.puniverses * cbv_value array | PRIMITIVE of CPrimitives.t * pconstant * cbv_value array - | NAT of Z.t + | NAT of inductive * Z.t | ARRAY of UVars.Instance.t * cbv_value Parray.t * cbv_value | SYMBOL of { cst: Constant.t UVars.puniverses; unfoldfix: bool; rules: Declarations.machine_rewrite_rule list; stk: cbv_stack } @@ -443,7 +443,7 @@ and reify_value = function (* reduction under binders *) mkApp(mkConstructU c, Array.map reify_value args) | PRIMITIVE(op,c,args) -> mkApp(mkConstU c, Array.map reify_value args) - | NAT n -> mkNat n + | NAT (ind,n) -> mkNat ind n | ARRAY (u,t,ty) -> let t, def = Parray.to_array t in mkArray(u, Array.map reify_value t, reify_value def, reify_value ty) @@ -520,8 +520,8 @@ let is_optimized_constant env cst = let run_optimized_def opt stk = match opt, stk with - | Add, APP ([NAT n; NAT m], stk) -> Some (NAT (Z.add n m), stk) - | Mul, APP ([NAT n; NAT m], stk) -> Some (NAT (Z.mul n m), stk) + | Add, APP ([NAT (ind,n); NAT (_,m)], stk) -> Some (NAT (ind,Z.add n m), stk) + | Mul, APP ([NAT (ind,n); NAT (_,m)], stk) -> Some (NAT (ind,Z.mul n m), stk) | (Add | Mul), _ -> None (* The main recursive functions @@ -608,8 +608,8 @@ let rec norm_head info env t stack = | CoFix cofix -> (COFIX(cofix,env,[||]), stack) | Construct ((ind,j),_ as c) -> if Environ.is_nat info.env ind then match j, stack with - | 1, _ -> NAT Z.zero, stack - | 2, APP ([NAT n], stack) -> NAT (Z.succ n), stack + | 1, _ -> NAT (ind,Z.zero), stack + | 2, APP ([NAT (ind,n)], stack) -> NAT (ind,Z.succ n), stack | 2, _ -> (CONSTRUCT(c, [||]), stack) | _ -> assert false else (CONSTRUCT(c, [||]), stack) @@ -623,7 +623,7 @@ let rec norm_head info env t stack = (cbv_stack_term info TOP env def) in (ARRAY (u,t,ty), stack) - | Nat n -> (NAT n, stack) + | Nat (ind,n) -> (NAT (ind,n), stack) (* neutral cases *) | (Sort _ | Meta _ | Ind _ | Int _ | Float _ | String _) -> (VAL(0, t), stack) @@ -729,12 +729,12 @@ and cbv_stack_value info env = function cbv_stack_term info stk env (snd br.(n-1)) (* unlike CONSTRUCT this is the only NAT case (no APP/PROJ at the head of the stack by typing) *) - | NAT n, CASE (_,_,_,br,_,_,env,stk) when red_set info.reds fMATCH -> + | NAT (ind,n), CASE (_,_,_,br,_,_,env,stk) when red_set info.reds fMATCH -> if Z.equal n Z.zero then let _, br = br.(0) in cbv_stack_term info stk env br else - let env = subs_cons (NAT (Z.pred n)) env in + let env = subs_cons (NAT (ind,Z.pred n)) env in let _, br = br.(1) in cbv_stack_term info stk env br @@ -747,8 +747,8 @@ and cbv_stack_value info env = function (* may be reduced later by application *) | (FIX(fix,env,[||]), APP(appl,TOP)) -> FIX(fix,env,Array.of_list appl) | (COFIX(cofix,env,[||]), APP(appl,TOP)) -> COFIX(cofix,env,Array.of_list appl) - | CONSTRUCT (((ind,2),_),[||]), APP([NAT n], TOP) when Environ.is_nat info.env ind -> - NAT (Z.succ n) + | CONSTRUCT (((ind,2),_),[||]), APP([NAT (_,n)], TOP) when Environ.is_nat info.env ind -> + NAT (ind,Z.succ n) | (CONSTRUCT(c,[||]), APP(appl,TOP)) -> CONSTRUCT(c,Array.of_list appl) (* primitive apply to arguments *) @@ -1051,7 +1051,7 @@ and cbv_norm_value info = function mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) | PRIMITIVE(op,c,args) -> mkApp(mkConstU c,Array.map (cbv_norm_value info) args) - | NAT n -> mkNat n + | NAT (ind,n) -> mkNat ind n | ARRAY (u,t,ty) -> let ty = cbv_norm_value info ty in let t, def = Parray.to_array t in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 257c3066ae79..60bc67177abd 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -342,31 +342,31 @@ let matches_core env sigma allow_bound_rels (binding_vars, pat) c = end end - | PNat n1, Nat n2 -> - if Z.equal n1 n2 then subst + | PNat (ind1,n1), Nat (ind2,n2) -> + if Z.equal n1 n2 && Environ.QInd.equal env ind1 ind2 then subst else raise PatternMatchingFailure - | PNat n, Construct ((ind,1),_) -> - if Z.equal n Z.zero && Environ.is_nat env ind then subst + | PNat (ind,n), Construct ((ind',1),_) -> + if Z.equal n Z.zero && Environ.QInd.equal env ind ind' then subst else raise PatternMatchingFailure - | PNat n, App (c2, arg2) -> + | PNat (ind,n), App (c2, arg2) -> if Array.length arg2 <> 1 then raise PatternMatchingFailure else begin match kind sigma c2 with - | Construct ((ind,2),_) when Environ.is_nat env ind -> - sorec ctx env subst (PNat (Z.pred n)) arg2.(0) + | Construct ((ind',2),_) when Environ.QInd.equal env ind ind' -> + sorec ctx env subst (PNat (ind,Z.pred n)) arg2.(0) | _ -> raise PatternMatchingFailure end - | PRef (ConstructRef (ind,1)), Nat n -> - if Z.equal n Z.zero && Environ.is_nat env ind then subst + | PRef (ConstructRef (ind,1)), Nat (ind',n) -> + if Z.equal n Z.zero && Environ.QInd.equal env ind ind' then subst else raise PatternMatchingFailure - | PApp (PRef (ConstructRef (ind,2)), arg1), Nat n -> + | PApp (PRef (ConstructRef (ind,2)), arg1), Nat (ind',n) -> if Z.equal n Z.zero || Array.length arg1 <> 1 || - not (Environ.is_nat env ind) then + not (Environ.QInd.equal env ind ind') then raise PatternMatchingFailure - else sorec ctx env subst arg1.(0) (mkNat (Z.pred n)) + else sorec ctx env subst arg1.(0) (mkNat ind' (Z.pred n)) | PApp (c1, arg1), App (c2, arg2) -> let () = if not (Int.equal (Array.length arg1) (Array.length arg2)) then raise PatternMatchingFailure in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 9f90f9b58cfb..1127bc74e2f4 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -915,7 +915,7 @@ and detype_r d flags avoid env sigma t = avoid env sigma case | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef - | Nat n -> GNat n + | Nat (ind,n) -> GNat (ind,n) | Int i -> GInt i | Float f -> GFloat f | String s -> GString s diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2f98aa6b78ec..9f1eb503c5ea 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1340,14 +1340,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | Array _, Array _ -> rigids env evd sk1 term1 sk2 term2 - | Nat n1, Construct _ -> - let term1 = EConstr.unfold_nat env n1 in + | Nat (ind1,n1), Construct _ -> + let term1 = EConstr.unfold_nat ind1 n1 in let term1, pred1 = decompose_app evd term1 in let sk1 = Stack.append_app pred1 sk1 in rigids env evd sk1 term1 sk2 term2 - | Construct _, Nat n2 -> - let term2 = EConstr.unfold_nat env n2 in + | Construct _, Nat (ind2,n2) -> + let term2 = EConstr.unfold_nat ind2 n2 in let term2, pred2 = decompose_app evd term2 in let sk2 = Stack.append_app pred2 sk2 in rigids env evd sk1 term1 sk2 term2 diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4076eb430641..46d63f3eef2b 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -734,7 +734,7 @@ let make_constructor_subst env sigma sign args = | LocalAssum ({ binder_name = id }, _) :: decls, Some (Some a, args) -> let accu = fold decls args accu in let a = match EConstr.kind sigma a with - | Nat n -> EConstr.unfold_nat env n + | Nat (ind,n) -> EConstr.unfold_nat ind n | _ -> a in let a', args = decompose_app sigma a in @@ -1767,7 +1767,7 @@ let rec invert_definition unify flags choose imitate_defs progress := true; match let t = match EConstr.kind !evdref t with - | Nat n -> EConstr.unfold_nat env n + | Nat (ind,n) -> EConstr.unfold_nat ind n | _ -> t in let c,args = decompose_app !evdref t in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 925864142346..686fc4ba5eb7 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -217,7 +217,7 @@ let mk_glob_constr_eq f g c1 c2 = match DAst.get c1, DAst.get c2 with GlobRef.(CanOrd.equal (ConstRef cst1) (ConstRef cst2)) && Option.equal instance_eq u1 u2 && List.equal f args1 args2 && f c1 c2 - | GNat i1, GNat i2 -> Z.equal i1 i2 + | GNat (ind1,i1), GNat (ind2,i2) -> Z.equal i1 i2 && Ind.CanOrd.equal ind1 ind2 | GInt i1, GInt i2 -> Uint63.equal i1 i2 | GFloat f1, GFloat f2 -> Float64.equal f1 f2 | GString s1, GString s2 -> Pstring.equal s1 s2 diff --git a/pretyping/glob_term.mli b/pretyping/glob_term.mli index 2eebe6f9cb71..37d42e9cf637 100644 --- a/pretyping/glob_term.mli +++ b/pretyping/glob_term.mli @@ -116,7 +116,7 @@ type 'a glob_constr_r = | GGenarg of GenConstr.glb | GCast of 'a glob_constr_g * Constr.cast_kind option * 'a glob_constr_g | GProj of (Constant.t * glob_instance option) * 'a glob_constr_g list * 'a glob_constr_g - | GNat of Z.t + | GNat of inductive * Z.t | GInt of Uint63.t | GFloat of Float64.t | GString of Pstring.t diff --git a/pretyping/keys.ml b/pretyping/keys.ml index bb900c5d6d20..e088305227e1 100644 --- a/pretyping/keys.ml +++ b/pretyping/keys.ml @@ -85,8 +85,7 @@ let equiv_keys k k' = let mkKGlob env gr = KGlob (Environ.QGlobRef.canonize env gr) -let mkKNat env i = - let natind = Option.get (Environ.retroknowledge env).retro_nat in +let mkKNat env natind i = let ctor = if Z.equal i Z.zero then 1 else 2 in mkKGlob env (ConstructRef (natind, ctor)) @@ -133,7 +132,7 @@ let constr_key env kind c = | Const (c, _) -> mkKGlob env (GlobRef.ConstRef c) | Ind (i, u) -> mkKGlob env (GlobRef.IndRef i) | Construct (c,u) -> mkKGlob env (GlobRef.ConstructRef c) - | Nat i -> mkKNat env i + | Nat (ind,i) -> mkKNat env ind i | Var id -> mkKGlob env (GlobRef.VarRef id) | App (f, _) -> aux f | Proj (p, _, _) -> mkKGlob env (GlobRef.ConstRef (Projection.constant p)) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index e5afe59a8207..97d6cd75603c 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -207,7 +207,9 @@ let rec nf_val env sigma v typ = let body = nf_val env sigma (f (mk_rel_accu lvl)) codom in mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env sigma n typ - | Vnat n -> mkNat n + | Vnat n -> + let (ind,_),_ = find_rectype_a env sigma (EConstr.of_constr typ) in + mkNat ind n | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vfloat64 f -> f |> Float64.of_float |> mkFloat | Vstring s -> s |> mkString diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 9af7dc47b403..19981e48ac04 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -38,7 +38,7 @@ type 'i constr_pattern_r = (int * Name.t array * 'i constr_pattern_r) list (** index of constructor, nb of args *) | PFix of (int array * int) * (Name.t array * 'i constr_pattern_r array * 'i constr_pattern_r array) | PCoFix of int * (Name.t array * 'i constr_pattern_r array * 'i constr_pattern_r array) - | PNat of Z.t + | PNat of inductive * Z.t | PInt of Uint63.t | PFloat of Float64.t | PString of Pstring.t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 0306a5b31429..6fbb7e774c31 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -158,7 +158,7 @@ let pattern_of_constr ~broken env sigma t = let env' = Array.fold_left2 push env lna tl in PCoFix (ln,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, Array.map (pattern_of_constr env') bl)) - | Nat n -> pattern_of_constr env (Environ.unfold_nat env n) (* XXX optimized Nat pattern *) + | Nat (ind,n) -> pattern_of_constr env (unfold_nat ind n) (* XXX optimized Nat pattern *) | Int i -> PInt i | Float f -> PFloat f | String s -> PString s @@ -527,7 +527,7 @@ let rec pat_of_raw metas vars : _ -> _ constr_pattern_r = DAst.with_loc_val (fun let names = Array.map (fun id -> Name id) ids in PCoFix (n, (names, tl, cl)) - | GNat n -> PNat n + | GNat (ind,n) -> PNat (ind,n) | GInt i -> PInt i | GFloat f -> PFloat f diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 988e6cb442bb..b795869ea40f 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -630,7 +630,7 @@ type pretyper = { pretype_hole : pretyper -> Evar_kinds.glob_evar_kind -> unsafe_judgment pretype_fun; pretype_genarg : pretyper -> GenConstr.glb -> unsafe_judgment pretype_fun; pretype_cast : pretyper -> glob_constr * cast_kind option * glob_constr -> unsafe_judgment pretype_fun; - pretype_nat : pretyper -> Z.t -> unsafe_judgment pretype_fun; + pretype_nat : pretyper -> inductive -> Z.t -> unsafe_judgment pretype_fun; pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; pretype_string : pretyper -> Pstring.t -> unsafe_judgment pretype_fun; @@ -676,8 +676,8 @@ let eval_pretyper self ~flags tycon env sigma t = self.pretype_genarg self arg ?loc ~flags tycon env sigma | GCast (c, k, t) -> self.pretype_cast self (c, k, t) ?loc ~flags tycon env sigma - | GNat n -> - self.pretype_nat self n ?loc ~flags tycon env sigma + | GNat (ind,n) -> + self.pretype_nat self ind n ?loc ~flags tycon env sigma | GInt n -> self.pretype_int self n ?loc ~flags tycon env sigma | GFloat f -> @@ -1573,12 +1573,8 @@ let pretype_type self c ?loc ~flags valcon (env : GlobEnv.t) sigma = match DAst. ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v e end - let pretype_nat self n ?loc ~flags tycon env sigma = - let resj = - try Typing.judge_of_nat !!env n - with Invalid_argument _ -> - user_err ?loc (str "Type of int63 should be registered first.") - in + let pretype_nat self ind n ?loc ~flags tycon env sigma = + let resj = Typing.judge_of_nat !!env ind n in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~flags env sigma resj tycon let pretype_int self i = diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index aa81968d2761..19d18efb9b0b 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -201,7 +201,7 @@ type pretyper = { pretype_hole : pretyper -> Evar_kinds.glob_evar_kind -> unsafe_judgment pretype_fun; pretype_genarg : pretyper -> GenConstr.glb -> unsafe_judgment pretype_fun; pretype_cast : pretyper -> glob_constr * Constr.cast_kind option * glob_constr -> unsafe_judgment pretype_fun; - pretype_nat : pretyper -> Z.t -> unsafe_judgment pretype_fun; + pretype_nat : pretyper -> inductive -> Z.t -> unsafe_judgment pretype_fun; pretype_int : pretyper -> Uint63.t -> unsafe_judgment pretype_fun; pretype_float : pretyper -> Float64.t -> unsafe_judgment pretype_fun; pretype_string : pretyper -> Pstring.t -> unsafe_judgment pretype_fun; diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 008d0fc50cdf..5b087fe990a7 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -707,14 +707,14 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = let ctx = expand_branch env sigma u pms (ind, i) br in applist (it_mkLambda_or_LetIn (snd br) ctx, args) -let get_nat_branch n br = +let get_nat_branch ind n br = if Z.equal n Z.zero then let _nas, br = br.(0) in br else let _nas, br = br.(1) in let n = Z.pred n in - Vars.subst1 (mkNat n) br + Vars.subst1 (mkNat ind n) br exception PatternFailure @@ -935,13 +935,13 @@ let rec whd_state_gen flags ?metas env sigma = |_, _ -> fold () else fold () - | Nat n -> + | Nat (ind,n) -> let use_match = RedFlags.red_set flags RedFlags.fMATCH in let use_fix = RedFlags.red_set flags RedFlags.fFIX in if use_match || use_fix then match stack with |(Stack.Case (_,_,_,_,_,br)::s') when use_match -> - let r = get_nat_branch n br in + let r = get_nat_branch ind n br in whrec (r, s') |(Stack.Fix (f,s')::s'') when use_fix -> let out_sk = s' @ (Stack.append_app [|x|] s'') in @@ -1038,13 +1038,13 @@ let local_whd_state_gen flags ?metas env sigma = |_, _ -> s else s - | Nat n -> + | Nat (ind,n) -> let use_match = RedFlags.red_set flags RedFlags.fMATCH in let use_fix = RedFlags.red_set flags RedFlags.fFIX in begin match stack with |(Stack.Case (_,_,_,_,_,br) :: s') -> if use_match then - let r = get_nat_branch n br in + let r = get_nat_branch ind n br in whrec (r, s') else s |(Stack.Fix (f,s')::s'') -> diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 941df4f06401..eb94faeb65d5 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -274,7 +274,7 @@ let retype ?metas ?(polyprop=true) sigma = with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) - | Nat _ -> EConstr.of_constr (Typeops.type_of_nat env) + | Nat (ind,n) -> EConstr.of_constr (Typeops.type_of_nat env ind n) | Int _ -> EConstr.of_constr (Typeops.type_of_int env) | Float _ -> EConstr.of_constr (Typeops.type_of_float env) | String _ -> EConstr.of_constr (Typeops.type_of_string env) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 326ba75cb940..5d6b4204e72e 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -957,16 +957,16 @@ and reduce_case infos env sigma (ci, u, pms, p, iv, c, lf) = let ctx = EConstr.expand_branch env sigma u pms cstr br in let br = it_mkLambda_or_LetIn (snd br) ctx in Reduced (applist (br, real_cargs)) - | Nat n -> + | Nat (ind,n) -> if Z.equal n Z.zero then let _, br = lf.(0) in Reduced br else let br = lf.(1) in - let cstr = Environ.ctor_of_nat env n in + let cstr = ctor_of_nat ind n in let ctx = EConstr.expand_branch env sigma u pms cstr br in let br = it_mkLambda_or_LetIn (snd br) ctx in - Reduced (applist (br, [mkNat (Z.pred n)])) + Reduced (applist (br, [mkNat ind (Z.pred n)])) | CoFix (bodynum,(names,_,_) as cofix) -> let cofix_def = contract_cofix env sigma f cofix in (* If the cofix_def does not reduce to a constructor, do we diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 3dfbd0223514..df2e605e92cd 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -450,13 +450,14 @@ let type_of_constructor env sigma ((ind,_ as ctor),u) = let sigma = Evd.add_poly_constraints ~src:UState.Internal sigma csts in sigma, (EConstr.of_constr (rename_type env ty (GR.ConstructRef ctor))) -let type_of_nat env = EConstr.of_constr (Typeops.type_of_nat env) +let type_of_nat env ind n = EConstr.of_constr (Typeops.type_of_nat env ind n) let type_of_int env = EConstr.of_constr (Typeops.type_of_int env) -let judge_of_nat env n = +let judge_of_nat env ind n = if not @@ Z.leq Z.zero n then CErrors.user_err Pp.(str "Optimized nat should be >= 0."); - { uj_val = mkNat n; uj_type = type_of_nat env } + if not (Environ.is_nat env ind) then CErrors.user_err Pp.(str "Optimized nat at non-nat type."); + { uj_val = mkNat ind n; uj_type = type_of_nat env ind n } let judge_of_int env v = { uj_val = mkInt v; uj_type = type_of_int env } @@ -662,7 +663,7 @@ let rec execute env sigma cstr = let sigma, tj = type_judgment env sigma tj in judge_of_cast env sigma cj k tj - | Nat n -> sigma, judge_of_nat env n + | Nat (ind,n) -> sigma, judge_of_nat env ind n | Int i -> sigma, judge_of_int env i diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 5904b3d7fc06..afdfff0d92c4 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -60,7 +60,7 @@ val judge_of_abstraction : Environ.env -> evar_map -> Name.t -> val judge_of_product : Environ.env -> evar_map -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment val judge_of_projection : env -> evar_map -> Projection.t -> unsafe_judgment -> unsafe_judgment -val judge_of_nat : Environ.env -> Z.t -> unsafe_judgment +val judge_of_nat : Environ.env -> inductive -> Z.t -> unsafe_judgment val judge_of_int : Environ.env -> Uint63.t -> unsafe_judgment val judge_of_float : Environ.env -> Float64.t -> unsafe_judgment val judge_of_string : Environ.env -> Pstring.t -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 6fde4a489d7e..096b51e68698 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1313,13 +1313,13 @@ let rec unify_0_with_initial_metas (subst : subst0) conv_at_top env pb flags m n || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2 - | Nat n1, Nat n2 when Z.equal n1 n2 -> substn + | Nat (ind1,n1), Nat (ind2,n2) when Z.equal n1 n2 && Environ.QInd.equal env ind1 ind2 -> substn - | Nat n1, (Construct _ | App _) -> - let curm = EConstr.unfold_nat env n1 in + | Nat (ind1,n1), (Construct _ | App _) -> + let curm = EConstr.unfold_nat ind1 n1 in unirec_rec curenvnb pb opt substn ~nargs curm curn - | (Construct _ | App _), Nat n2 -> - let curn = EConstr.unfold_nat env n2 in + | (Construct _ | App _), Nat (ind2,n2) -> + let curn = EConstr.unfold_nat ind2 n2 in unirec_rec curenvnb pb opt substn ~nargs curm curn | App (f1,l1), App (f2,l2) -> @@ -2547,7 +2547,7 @@ let w_unify_to_subterm_all ~metas env evd ?(flags=default_unify_flags ()) (op,cl let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) - | Nat n -> matchrec (EConstr.unfold_nat env n) (* XXX seems very bad performance wise *) + | Nat (ind,n) -> matchrec (EConstr.unfold_nat ind n) (* XXX seems very bad performance wise *) | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec (Array.map snd lf)) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 22dff217954d..b0ab1677a781 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -86,7 +86,7 @@ let construct_of_constr const env sigma tag typ = match Constr.kind t with | Ind ((mind,_ as ind), u as indu) -> let mib,mip = lookup_mind_specif env ind in - if mib.mind_is_nat && const then mkNat (Z.of_int tag), mkIndU indu + if mib.mind_is_nat && const then mkNat ind (Z.of_int tag), mkIndU indu else let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in @@ -184,7 +184,9 @@ and nf_whd env sigma whd typ = let capp,ctyp = construct_of_constr_block env sigma tag typ in let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) - | Vnat n -> mkNat n + | Vnat n -> + let ((ind,_),_) = find_rectype_a env sigma (EConstr.of_constr typ) in + mkNat ind n | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vfloat64 f -> f |> Float64.of_float |> mkFloat | Vstring s -> s |> mkString diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 2d8f3932e5f5..29a4253ff364 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -212,7 +212,7 @@ struct (* UnsafeMonomorphic is fine because the term will only be used by pat_of_constr which ignores universes *) pat_of_constr (mkApp (UnsafeMonomorphic.mkConst (Projection.constant p), [|c|])) - | Nat n -> pat_of_constr (Environ.unfold_nat env n) (* optimized Nat? *) + | Nat (ind,n) -> pat_of_constr (unfold_nat ind n) (* optimized Nat? *) | Int i -> Some (DInt i, []) | Float f -> Some (DFloat f, []) | String s -> Some (DString s, []) diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index d069a6903c81..e004c3887ed3 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -226,7 +226,7 @@ let constr_val_discr env sigma ts t : constr_res = | (Label _ | Nothing) as res -> Label(CaseLabel, PartialConstr res :: stack) | Everything -> Everything end - | Nat n -> decomp stack (EConstr.unfold_nat env n) (* XXX optimized Nat? *) + | Nat (ind,n) -> decomp stack (EConstr.unfold_nat ind n) (* XXX optimized Nat? *) | Rel _ | Meta _ | LetIn _ | Fix _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> Nothing in diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 78218f2b999c..cf694080a01f 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -561,14 +561,14 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = in Vars.substl subst (snd br) -let get_nat_branch n br = +let get_nat_branch ind n br = if Z.equal n Z.zero then let _nas, br = br.(0) in br else let _nas, br = br.(1) in let n = Z.pred n in - Vars.subst1 (mkNat n) br + Vars.subst1 (mkNat ind n) br exception PatternFailure @@ -924,13 +924,13 @@ let rec whd_state_gen ?csts flags env sigma = |_, _ -> fold () else fold () - | Nat n -> + | Nat (ind,n) -> let use_match = RedFlags.red_set flags RedFlags.fMATCH in let use_fix = RedFlags.red_set flags RedFlags.fFIX in if use_match || use_fix then match stack with | (Stack.Case((_,_,_,_,_,br),_)::s') when use_match -> - let r = get_nat_branch n br in + let r = get_nat_branch ind n br in whrec Cst_stack.empty (r, s') | (Stack.Fix (f,s',cst_l)::s'') when use_fix -> let out_sk = s' @ (Stack.append_app [|x|] s'') in diff --git a/tactics/equality.ml b/tactics/equality.ml index 44a65b25d7b6..2b6dcd78d9ac 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -945,11 +945,11 @@ let find_positions env sigma ~keep_proofs ~no_discr ~eqsort ~goalsort t1 t2 = (* if we cannot eliminate to Type, we cannot discriminate but we may still try to project *) project env posn allowed_elim_on_sort (applist (hd1,args1)) (applist (hd2,args2)) - | Nat n1, Nat n2 -> - if Z.equal n1 n2 then [] - else findrec posn s (EConstr.unfold_nat env n1) (EConstr.unfold_nat env n2) - | Nat n1, _ -> findrec posn s (EConstr.unfold_nat env n1) (applist (hd2,args2)) - | _, Nat n2 -> findrec posn s (applist (hd1,args1)) (EConstr.unfold_nat env n2) + | Nat (ind1,n1), Nat (ind2,n2) -> + if Z.equal n1 n2 && Environ.QInd.equal env ind1 ind2 then [] + else findrec posn s (EConstr.unfold_nat ind1 n1) (EConstr.unfold_nat ind2 n2) + | Nat (ind1,n1), _ -> findrec posn s (EConstr.unfold_nat ind1 n1) (applist (hd2,args2)) + | _, Nat (ind2,n2) -> findrec posn s (applist (hd1,args1)) (EConstr.unfold_nat ind2 n2) | Int i1, Int i2 -> if Uint63.equal i1 i2 then [] else raise (DiscrFound (List.rev posn, DInt (i1, i2))) diff --git a/tactics/hints.ml b/tactics/hints.ml index beb5fdda06bf..3e08dc30c3c3 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -41,23 +41,23 @@ type debug = Debug | Info | Off exception Bound -let rec head_bound env sigma t = match EConstr.kind sigma t with -| Prod (_, _, b) -> head_bound env sigma b -| LetIn (_, _, _, b) -> head_bound env sigma b -| App (c, _) -> head_bound env sigma c -| Case (_, _, _, _, _, c, _) -> head_bound env sigma c +let rec head_bound sigma t = match EConstr.kind sigma t with +| Prod (_, _, b) -> head_bound sigma b +| LetIn (_, _, _, b) -> head_bound sigma b +| App (c, _) -> head_bound sigma c +| Case (_, _, _, _, _, c, _) -> head_bound sigma c | Ind (ind, _) -> GlobRef.IndRef ind | Const (c, _) -> GlobRef.ConstRef c | Construct (c, _) -> GlobRef.ConstructRef c | Var id -> GlobRef.VarRef id | Proj (p, _, _) -> GlobRef.ConstRef (Projection.constant p) -| Cast (c, _, _) -> head_bound env sigma c -| Nat n -> ConstructRef (Environ.ctor_of_nat env n) +| Cast (c, _, _) -> head_bound sigma c +| Nat (ind,n) -> ConstructRef (ctor_of_nat ind n) | Evar _ | Rel _ | Meta _ | Sort _ | Fix _ | Lambda _ | CoFix _ | Int _ | Float _ | String _ | Array _ -> raise Bound -let head_constr env sigma c = - try head_bound env sigma c +let head_constr sigma c = + try head_bound sigma c with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ (co)inductive type, (co)inductive type constructor, or projection.") @@ -885,7 +885,7 @@ let make_exact_entry env sigma info ?name (c, cty, ctx) = | Prod _ -> failwith "make_exact_entry" | _ -> let hd = - try head_bound env sigma cty + try head_bound sigma cty with Bound -> failwith "make_exact_entry" in let pri = match info.hint_priority with None -> 0 | Some p -> p in @@ -912,7 +912,7 @@ let make_apply_entry env sigma hnf info ?name (c, cty, ctx) = let ce = Clenv.mk_clenv_from env sigma' (c,cty) in let c' = Clenv.clenv_type (* ~reduce:false *) ce in let hd = - try head_bound env (Clenv.clenv_evd ce) c' + try head_bound (Clenv.clenv_evd ce) c' with Bound -> failwith "make_apply_entry" in let miss, hyps = Clenv.clenv_missing ce in let nmiss = List.length miss in @@ -1028,7 +1028,7 @@ let make_trivial env sigma r = let c,ctx = fresh_global_or_constr env sigma (IsGlobRef r) in let sigma = merge_context_set_opt sigma ctx in let t = hnf_constr env sigma (Retyping.get_type_of env sigma c) in - let hd = head_constr env sigma t in + let hd = head_constr sigma t in let h = { rhint_term = c; rhint_type = t; rhint_uctx = ctx; rhint_arty = 0 } in (Some hd, { pri=1; @@ -1210,7 +1210,7 @@ let subst_autohint (subst, obj) = match t with | None -> gr' | Some t -> - (try head_bound (Global.env()) Evd.empty (EConstr.of_constr t.UVars.univ_abstracted_value) + (try head_bound Evd.empty (EConstr.of_constr t.UVars.univ_abstracted_value) with Bound -> gr') in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in From f39a944a44092f1fdadabbec197b7ca7f2bc1c0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 17:40:16 +0100 Subject: [PATCH 26/36] Constr.equal & co compare primitive and ctor representation of nat as equal --- kernel/constr.ml | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/kernel/constr.ml b/kernel/constr.ml index 5920d5c697b7..4f6391acaddb 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -910,13 +910,32 @@ let eq_invert eq iv1 iv2 = let eq_under_context eq (_nas1, p1) (_nas2, p2) = eq p1 p2 +let eq_nat_gen ind n kind c = + let rec aux n c = + match kind_nocast_gen kind c with + | Nat (ind',n') -> Z.equal n n' && Ind.CanOrd.equal ind ind' + | Construct ((ind',1),_) -> Z.equal n Z.zero && Ind.CanOrd.equal ind ind' + | App (hd, [|a|]) -> + begin match kind_nocast_gen kind hd with + | Construct ((ind',2),_) -> + Ind.CanOrd.equal ind ind' && + aux (Z.pred n) a + | _ -> false + end + | _ -> false + in + aux n c + let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq_evars eq leq nargs t1 t2 = match kind_nocast_gen kind1 t1, kind_nocast_gen kind2 t2 with | Cast _, _ | _, Cast _ -> assert false (* kind_nocast *) | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 - | Nat (ind1,i1), Nat (ind2,i2) -> Z.equal i1 i2 && Ind.CanOrd.equal ind1 ind2 (* XXX nat vs constructor? *) + | Nat (ind1,n1), Nat (ind2,n2) -> + Z.equal n1 n2 && Ind.CanOrd.equal ind1 ind2 + | Nat (ind1,n1), _ -> eq_nat_gen ind1 n1 kind2 t2 + | _, Nat (ind2,n2) -> eq_nat_gen ind2 n2 kind1 t1 | Int i1, Int i2 -> Uint63.equal i1 i2 | Float f1, Float f2 -> Float64.equal f1 f2 | String s1, String s2 -> Pstring.equal s1 s2 @@ -955,7 +974,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq_evars eq le eq 0 def1 def2 && eq 0 ty1 ty2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _ | Nat _ | Int _ | Float _ | String _ | Array _), _ -> false + | CoFix _ | Int _ | Float _ | String _ | Array _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, From 424b3058b274bdb3e7a7b1dc83e3b3dff0ce2b5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 17:45:26 +0100 Subject: [PATCH 27/36] handle primitive nat in canonical structures --- pretyping/structures.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pretyping/structures.ml b/pretyping/structures.ml index a5dfb660ada1..fd3294d03030 100644 --- a/pretyping/structures.ml +++ b/pretyping/structures.ml @@ -190,6 +190,7 @@ let rec of_constr sigma t = | Prod (_,_,_) -> Prod_cs, None, [t] | Proj (p, _, c) -> Proj_cs (Names.Projection.repr p), None, [c] | Sort s -> Sort_cs (EConstr.ESorts.quality_or_set sigma s), None, [] + | Nat (ind,n) -> of_constr sigma (EConstr.unfold_nat ind n) | _ -> Const_cs (fst @@ EConstr.destRef sigma t) , None, [] let print = function From 75ad9b51bf241e959f264c37179904e93109a3d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 13:59:05 +0100 Subject: [PATCH 28/36] handle primitive nat in zify/micromega --- engine/eConstr.ml | 7 +++++++ engine/eConstr.mli | 2 ++ kernel/constr.ml | 7 +++++++ kernel/constr.mli | 2 ++ plugins/micromega/coq_micromega.ml | 6 +++--- plugins/micromega/zify.ml | 13 +++++++++---- 6 files changed, 30 insertions(+), 7 deletions(-) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index cc0b259b3427..74e1c7363f84 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -351,6 +351,13 @@ let destRef sigma c = let open GlobRef in match kind sigma c with | Construct (c,u) -> ConstructRef c, u | _ -> raise DestKO +let kind_nonat sigma c = + match kind sigma c with + | Nat (ind,n) -> + if Z.equal n Z.zero then Construct (in_punivs (ind,1)) + else App (of_kind (Construct (in_punivs (ind,2))), [|of_kind (Nat (ind,Z.pred n))|]) + | k -> k + let decompose_app sigma c = match kind sigma c with | App (f,cl) -> (f, cl) diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 85a3fe271637..884870bc266a 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -117,6 +117,8 @@ val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t, ERelevance.t) Cons val kind_upto : Evd.evar_map -> Constr.t -> (Constr.t, Constr.t, Sorts.t, UVars.Instance.t, Sorts.relevance) Constr.kind_of_term +val kind_nonat : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t, ERelevance.t) Constr.kind_of_term + val to_constr : ?abort_on_undefined_evars:bool -> Evd.evar_map -> t -> Constr.t (** Returns the evar-normal form of the argument. Note that this function is supposed to be called when the original term has not diff --git a/kernel/constr.ml b/kernel/constr.ml index 4f6391acaddb..1f9b141a0f80 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -151,6 +151,13 @@ let rec kind_nocast_gen kind c = let kind_nocast c = kind_nocast_gen kind c +let kind_nonat c = + match kind c with + | Nat (ind,n) -> + if Z.equal n Z.zero then Construct (in_punivs (ind,1)) + else App (T (Construct (in_punivs (ind,2))), [|T (Nat (ind,Z.pred n))|]) + | k -> k + (**********************************************************************) (* Non primitive term destructors *) (**********************************************************************) diff --git a/kernel/constr.mli b/kernel/constr.mli index 99123fdbf25b..27e5d13b1b3a 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -311,6 +311,8 @@ val kind_nocast_gen : ('v -> ('v, 'v, 'sort, 'univs, 'r) kind_of_term) -> val kind_nocast : constr -> (constr, types, Sorts.t, UVars.Instance.t, Sorts.relevance) kind_of_term +val kind_nonat : constr -> (constr, types, Sorts.t, UVars.Instance.t, Sorts.relevance) kind_of_term + (** {6 Simple case analysis} *) val isRel : constr -> bool val isRelN : int -> constr -> bool diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 8748033a0063..8cdf565034c6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -329,7 +329,7 @@ exception ParseError (* A simple but useful getter function *) let get_left_construct sigma term = - match EConstr.kind sigma term with + match EConstr.kind_nonat sigma term with | Construct ((_, i), _) -> (i, [||]) | App (l, rst) -> ( match EConstr.kind sigma l with @@ -387,7 +387,7 @@ let dump_n x = *) let is_declared_term env evd t = - match EConstr.kind evd t with + match EConstr.kind_nonat evd t with | Const _ | Construct _ -> ( (* Restrict typeclass resolution to trivial cases *) let typ = Retyping.get_type_of env evd t in @@ -400,7 +400,7 @@ let is_declared_term env evd t = | _ -> false let rec is_ground_term env evd term = - match EConstr.kind evd term with + match EConstr.kind_nonat evd term with | App (c, args) -> is_declared_term env evd c && Array.for_all (is_ground_term env evd) args | Const _ | Construct _ -> is_declared_term env evd term diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 77a4efdd0746..de57b9971edb 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -93,6 +93,10 @@ let rec find_option pred l = | [] -> raise Not_found | e :: l -> ( match pred e with Some r -> r | None -> find_option pred l ) +(* Nat handling is quite adhoc, could probably be improved *) +let destRef_nonat evd h = + EConstr.(destRef evd (of_kind @@ kind_nonat evd h)) + module ConstrMap = struct open Names.GlobRef @@ -104,11 +108,11 @@ module ConstrMap = struct let empty = Map.empty let find evd h m = - match Map.find (fst (EConstr.destRef evd h)) m with + match Map.find (fst (destRef_nonat evd h)) m with | e :: _ -> e | [] -> assert false - let find_all evd h m = Map.find (fst (EConstr.destRef evd h)) m + let find_all evd h m = Map.find (fst (destRef_nonat evd h)) m let fold f m acc = Map.fold @@ -512,6 +516,7 @@ module ECstOp = struct let isConstruct evd c = match EConstr.kind evd c with | Construct _ | Int _ | Float _ -> true + | Nat (_,n) -> Z.equal n Z.zero | _ -> false let mk_elt evd i a = @@ -641,7 +646,7 @@ module MakeTable (E : Elt) : S = struct let safe_ref evd c = try - fst (EConstr.destRef evd c) + fst (destRef_nonat evd c) with DestKO -> CErrors.user_err Pp.(str "Add Zify "++str E.name ++ str ": the term "++ gl_pr_constr c ++ str " should be a global reference") @@ -1056,7 +1061,7 @@ let is_arrow env evd a p1 p2 = The function also transforms (x -> y) as (arrow x y) *) let get_operator barrow env evd e = let e' = EConstr.whd_evar evd e in - match EConstr.kind evd e' with + match EConstr.kind_nonat evd e' with | Prod (a, p1, p2) -> if barrow && is_arrow env evd a p1 p2 then (arrow, [|p1; p2|], false) else raise Not_found From 50409e41a7c14fed1988933c0ba62270fd8031d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 14:18:31 +0100 Subject: [PATCH 29/36] Handle primitive nat in unify to subterm --- engine/termops.ml | 2 +- pretyping/unification.ml | 2 +- test-suite/success/bignat.v | 7 +++++++ 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/engine/termops.ml b/engine/termops.ml index 85b8fdb454be..f0a543fbd21a 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -544,7 +544,7 @@ let map_left2 f a g b = let map_constr_with_binders_left_to_right env sigma g f l c = let open RelDecl in let open EConstr in - match EConstr.kind sigma c with + match EConstr.kind_nonat sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _) -> c | Cast (b,k,t) -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 096b51e68698..5c7b68301fcb 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -2328,7 +2328,7 @@ let get_max_rel_array sigma v = Array.fold_left (fun accu c -> max accu (get_max let anorec = AOther [||] -let rec make sigma c0 = match EConstr.kind sigma c0 with +let rec make sigma c0 = match EConstr.kind_nonat sigma c0 with | (Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Nat _ | Int _ | Float _ | String _) -> { proj = c0; self = anorec; data = 0 } | Rel n -> diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index cef0a60017a2..54c4b61d93c2 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -141,3 +141,10 @@ Check eq_refl 4611686018427387900 <: 4611686018427387900 = pred (pred (pred 4611 Check eq_refl 4611686018427387900 : 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). Check eq_refl 4611686018427387900 <: 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). + +Goal forall n:N, 0 = n -> 1 = S n. +Proof. + intros n H. + rewrite H. + reflexivity. +Qed. From 896556d86e81e04eb5544cf33c27d1ae7f3e5698 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Mon, 9 Mar 2026 17:56:11 +0100 Subject: [PATCH 30/36] make Datatypes.nat use the optimized representation --- theories/Corelib/Init/Datatypes.v | 1 + 1 file changed, 1 insertion(+) diff --git a/theories/Corelib/Init/Datatypes.v b/theories/Corelib/Init/Datatypes.v index b4c97e94e3a6..f9defd5bf2c2 100644 --- a/theories/Corelib/Init/Datatypes.v +++ b/theories/Corelib/Init/Datatypes.v @@ -184,6 +184,7 @@ Register BoolSpecF as core.BoolSpec.BoolSpecF. Numbers in [nat] can be denoted using a decimal notation; e.g. [3%nat] abbreviates [S (S (S O))] *) +#[primitive_nat] Inductive nat : Set := | O : nat | S : nat -> nat. From 9dbae371006a7684e8d41818c31db5873d6bb01f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 14:35:00 +0100 Subject: [PATCH 31/36] bignat overlay --- dev/ci/user-overlays/21729-SkySkimmer-bignat.sh | 1 + 1 file changed, 1 insertion(+) create mode 100644 dev/ci/user-overlays/21729-SkySkimmer-bignat.sh diff --git a/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh b/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh new file mode 100644 index 000000000000..f687102d54b3 --- /dev/null +++ b/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/SkySkimmer/coq-elpi bignat 21729 From 6caf04004ffecc873711ab10282cf66ec0b07e8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 14:36:09 +0100 Subject: [PATCH 32/36] bignat bench overlay --- dev/bench/bench.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/bench/bench.sh b/dev/bench/bench.sh index 5dd12ce0d7e9..2aaa342214fa 100755 --- a/dev/bench/bench.sh +++ b/dev/bench/bench.sh @@ -54,7 +54,7 @@ check_variable () { # example: coq-hott.dev git+https://github.com/some-user/coq-hott#some-branch # (make sure to include the version for the opam package, note that just https won't work) -: "${new_opam_override_urls:=}" +: "${new_opam_override_urls:=rocq-elpi.dev git+https://github.com/skyskimmer/coq-elpi#bignat}" : "${old_opam_override_urls:=}" if [ "$CI" ]; then From a7c9de24c36a372dfbdae101c0a4ceea897e9dc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 15:14:33 +0100 Subject: [PATCH 33/36] handle bignat in native compute --- kernel/genlambda.ml | 9 +++++-- kernel/genlambda.mli | 7 ++++- kernel/nativecode.ml | 52 +++++++++++++++++++++++++++---------- kernel/nativevalues.ml | 32 ++++++++++++++++++++++- kernel/nativevalues.mli | 6 +++++ kernel/vmbytegen.ml | 4 +-- pretyping/nativenorm.ml | 3 +++ test-suite/success/bignat.v | 13 ++++++++++ 8 files changed, 107 insertions(+), 19 deletions(-) diff --git a/kernel/genlambda.ml b/kernel/genlambda.ml index 89e4b3ff6d0f..a1e6d62d825a 100644 --- a/kernel/genlambda.ml +++ b/kernel/genlambda.ml @@ -18,7 +18,12 @@ open Constr type reloc_table = (int * int) array -type case_annot = case_info * reloc_table * Declarations.recursivity_kind +type case_annot = { + ci : case_info; + reloc : reloc_table; + finite : Declarations.recursivity_kind; + is_nat : bool; +} type 'v node = | Lrel of Name.t * int @@ -744,7 +749,7 @@ let rec lambda_of_constr cache env sigma c = let oib = mib.mind_packets.(i) in let tbl = oib.mind_reloc_tbl in (* Building info *) - let annot_sw = (ci, tbl, mib.mind_finite) in + let annot_sw = { ci; reloc = tbl; finite = mib.mind_finite; is_nat = mib.mind_is_nat } in (* translation of the argument *) let la = lambda_of_constr cache env sigma a in (* translation of the type *) diff --git a/kernel/genlambda.mli b/kernel/genlambda.mli index be3dd5d4c222..8668c8f87f2e 100644 --- a/kernel/genlambda.mli +++ b/kernel/genlambda.mli @@ -15,7 +15,12 @@ open Constr type reloc_table = (int * int) array -type case_annot = case_info * reloc_table * Declarations.recursivity_kind +type case_annot = { + ci : case_info; + reloc : reloc_table; + finite : Declarations.recursivity_kind; + is_nat : bool; +} type 'v lambda diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 27741c2dad99..a0c09485c114 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -292,6 +292,9 @@ type primitive = | Lazy | Coq_primitive of CPrimitives.t * bool (* check for accu *) | Mk_empty_instance + | Mk_nat + | Mk_succ + | Force_nat let eq_primitive p1 p2 = match p1, p2 with @@ -333,6 +336,9 @@ let eq_primitive p1 p2 = | Get_symbols, Get_symbols | Lazy, Lazy | Mk_empty_instance, Mk_empty_instance + | Mk_nat, Mk_nat + | Mk_succ, Mk_succ + | Force_nat, Force_nat -> true | Mk_fix (rp1, i1), Mk_fix (rp2, i2) -> Int.equal i1 i2 && eq_rec_pos rp1 rp2 @@ -384,7 +390,10 @@ let eq_primitive p1 p2 = | Get_symbols | Lazy | Coq_primitive _ - | Mk_empty_instance), _ + | Mk_empty_instance + | Mk_nat + | Mk_succ + | Force_nat), _ -> false let primitive_hash = function @@ -436,6 +445,9 @@ let primitive_hash = function | Lazy -> 42 | Mk_empty_instance -> 43 | Mk_string -> 44 + | Mk_nat -> 45 + | Mk_succ -> 46 + | Force_nat -> 47 type mllambda = | MLlocal of lname @@ -450,6 +462,7 @@ type mllambda = (* argument, prefix, accu branch, branches *) | MLconstruct of string * inductive * int * mllambda array (* prefix, inductive name, tag, arguments *) + | MLnat of Z.t | MLint of int | MLuint of Uint63.t | MLfloat of Float64.t @@ -523,6 +536,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = Ind.UserOrd.equal ind1 ind2 && Int.equal tag1 tag2 && Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2 + | MLnat n1, MLnat n2 -> Z.equal n1 n2 | MLint i1, MLint i2 -> Int.equal i1 i2 | MLuint i1, MLuint i2 -> @@ -544,7 +558,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = String.equal s1 s2 && Ind.UserOrd.equal ind1 ind2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ | - MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ | + MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLnat _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ | MLsetref _ | MLsequence _ | MLarray _ | MLisaccu _), _ -> false @@ -637,6 +651,7 @@ let rec hash_mllambda gn n env t = combinesmall 17 (Float64.hash f) | MLstring s -> combinesmall 18 (Pstring.hash s) + | MLnat n -> combinesmall 19 (Z.hash n) and hash_mllambda_letrec gn n env init defs = let hash_def (_,args,ml) = @@ -670,7 +685,7 @@ let fv_lam l = match l with | MLlocal l -> if LNset.mem l bind then fv else LNset.add l fv - | MLglobal _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ -> fv + | MLglobal _ | MLnat _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ -> fv | MLprimitive (_, args) -> let fv_arg arg fv = aux arg bind fv in Array.fold_right fv_arg args fv @@ -1352,12 +1367,12 @@ let compile_prim env decl cond paux = (* Remark: if we do not want to compile the predicate we should a least compute the fv, then store the lambda representation of the predicate (not the mllambda) *) - let annot, finite = - let (ci, tbl, finite) = annot in { + let annot, finite, is_nat = + let { ci; reloc = tbl; finite; is_nat } = annot in { asw_ind = ci.ci_ind; asw_reloc = tbl; asw_prefix = env.env_mind_prefix (fst ci.ci_ind); - }, finite in + }, finite, is_nat in let env_p = restart_env env in let pn = fresh_gpred env.env_cenv l in let mlp = ml_of_lam env_p l p in @@ -1398,10 +1413,13 @@ let compile_prim env decl cond paux = in (* Final result *) let arg = ml_of_lam env l a in - let force = + let arg = if is_nat then MLprimitive (Force_nat, [|arg|]) + else arg + in + let arg = if finite <> CoFinite then arg else mkForceCofix env.env_cenv annot.asw_prefix annot.asw_ind arg in - mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|] + mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|arg|] | Lfix ((rec_pos, inds, start), (ids, tt, tb)) -> (* let type_f fvt = [| type fix |] let norm_f1 fv f1 .. fn params1 = body1 @@ -1538,8 +1556,12 @@ let compile_prim env decl cond paux = let knot = push_global_cofix env.env_cenv knot fv_params (Array.mapi map t_norm_f) in MLprimitive (Array_get, [|MLapp (MLglobal knot, fv_args); MLint start|]) - | Lnat _ -> failwith "TODO" - | Lmakesucc _ -> failwith "TODO" + | Lnat n -> + if Obj.is_int (Obj.repr n) then + MLprimitive (Mk_int, [|MLint (Obj.magic n)|]) + else MLprimitive (Mk_nat, [|MLnat n|]) + + | Lmakesucc v -> MLprimitive (Mk_succ, [|ml_of_lam env l v|]) | Lint tag -> MLprimitive (Mk_int, [|MLint tag|]) @@ -1587,7 +1609,7 @@ let mllambda_of_lambda cenv univ constpref constlazy mindpref auxdefs l t = let can_subst l = match l with - | MLlocal _ | MLint _ | MLuint _ | MLglobal _ -> true + | MLlocal _ | MLnat _ | MLint _ | MLuint _ | MLglobal _ -> true | _ -> false let subst s l = @@ -1596,7 +1618,7 @@ let subst s l = let rec aux l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) - | MLglobal _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ -> l + | MLglobal _ | MLnat _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ -> l | MLprimitive (p, args) -> MLprimitive (p, Array.map aux args) | MLlam(params,body) -> MLlam(params, aux body) | MLletrec(defs,body) -> @@ -1667,7 +1689,7 @@ let optimize gdef l = let rec optimize s l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) - | MLglobal _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ -> l + | MLglobal _ | MLnat _ | MLint _ | MLuint _ | MLfloat _ | MLstring _ -> l | MLprimitive (p, args) -> MLprimitive (p, Array.map (optimize s) args) | MLlam(params,body) -> @@ -1873,6 +1895,7 @@ let pp_mllam fmt l = | MLconstruct(prefix,ind,tag,args) -> Format.fprintf fmt "@[<2>(Obj.magic@ @[<2>(%s%a)@] : Nativevalues.t)@]" (string_of_construct prefix ~constant:false ind tag) pp_cargs args + | MLnat n -> Format.fprintf fmt "%S" (Z.to_bits n) | MLint i -> pp_int fmt i | MLuint i -> Format.fprintf fmt "(%s)" (Uint63.compile i) | MLfloat f -> Format.fprintf fmt "(%s)" (Float64.compile f) @@ -2010,6 +2033,9 @@ let pp_mllam fmt l = | Mk_float -> Format.fprintf fmt "mk_float" | Mk_string -> Format.fprintf fmt "mk_string" | Mk_int -> Format.fprintf fmt "mk_int" + | Mk_nat -> Format.fprintf fmt "mk_nat" + | Mk_succ -> Format.fprintf fmt "mk_succ" + | Force_nat -> Format.fprintf fmt "force_nat" | Val_to_int -> Format.fprintf fmt "val_to_int" | Mk_evar -> Format.fprintf fmt "mk_evar_accu" | MLand -> Format.fprintf fmt "(&&)" diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index fd3a06d759f6..0b83e545fcbe 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -229,6 +229,30 @@ let cast_accu v = (Obj.magic v:accumulator) let mk_int (x : int) = (Obj.magic x : t) [@@ocaml.inline always] +let mk_nat (x:string) = (Obj.magic (Z.of_bits x) : t) + +type native_nat = + | NatAccu of t + | NatZero + | NatSucc of t +[@@warning "-a"] + +let mk_succ (x:t) = + let x = Obj.repr x in + if Obj.is_int x || Obj.tag x = Obj.custom_tag then + Obj.magic (Z.succ (Obj.magic x)) + else Obj.magic (NatSucc (Obj.magic x)) + +let force_nat (x:t) : t = + if Obj.is_int @@ Obj.repr x then + let x : int = Obj.magic x in + if Int.equal x 0 then Obj.magic NatZero + else Obj.magic @@ NatSucc (Obj.magic (pred x)) + else if Obj.tag (Obj.repr x) = Obj.custom_tag then + let x : Z.t = Obj.magic x in + Obj.magic @@ NatSucc (Obj.magic @@ Z.pred x) + else x + (* Rocq's booleans are reversed... *) let mk_bool (b : bool) = (Obj.magic (not b) : t) [@@ocaml.inline always] @@ -252,6 +276,12 @@ let block_tag (b:block) = type kind = (t, accumulator, t -> t, Name.t * t * t, Empty.t, Empty.t, block) Values.kind +external is_int64 : t -> bool = "rocq_is_int64" + +let nat_or_int64 v = + if is_int64 v then Vint64 (Obj.magic v) + else Vnat (Obj.magic v) + let kind_of_value (v:t) = let o = Obj.repr v in if Obj.is_int o then Vconst (Obj.magic v) @@ -264,7 +294,7 @@ let kind_of_value (v:t) = if Int.equal tag prod_tag then Obj.magic w else Varray (Obj.magic v) else Vaccu (Obj.magic v) - else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) + else if Int.equal tag Obj.custom_tag then nat_or_int64 v else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else if Int.equal tag Obj.string_tag then Vstring (Obj.magic v) else if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index e3d9a9082caf..dbd1e73a802a 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -97,6 +97,12 @@ val mk_bool : bool -> t val mk_int : int -> t +val mk_nat : string -> t + +val mk_succ : t -> t + +val force_nat : t -> t + val mk_uint : Uint63.t -> t val mk_float : Float64.t -> t diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index e0832ea449c0..e01112b5bb41 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -712,11 +712,11 @@ let rec compile_lam env cenv lam sz cont = compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) - | Lcase ((ci, rtbl, _), t, a, branches) -> + | Lcase ({ci; reloc = rtbl; finite=_; is_nat}, t, a, branches) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env.env in let oib = mib.mind_packets.(snd ind) in - let lbl_nat_s = if mib.mind_is_nat then Some (ref None) else None in + let lbl_nat_s = if is_nat then Some (ref None) else None in let lbl_consts = Array.make oib.mind_nb_constant Label.no in let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *) let nconst = Array.length branches.constant_branches in diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 97d6cd75603c..c54655a614b1 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -110,6 +110,9 @@ let find_rectype_a env sigma c = let construct_of_constr_notnative const env tag (ind,u) allargs = let mib,mip = lookup_mind_specif env ind in + if mib.mind_is_nat && const then + mkNat ind (Z.of_int tag), mkIndU (ind,EConstr.Unsafe.to_instance u) + else let nparams = mib.mind_nparams in let params = Array.sub allargs 0 nparams in let i = invert_tag const tag mip.mind_reloc_tbl in diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index 54c4b61d93c2..d21f35617516 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -134,13 +134,26 @@ Check eq_refl : vmbig = 4611686018427387905. Check eq_refl vmbig <: vmbig = 4611686018427387905. Check eq_refl (S vmbig) <: S vmbig = 4611686018427387906. +Definition nativetwo := Eval native_compute in 1 + 1. +Check eq_refl : nativetwo = 2. +Check eq_refl 4 <<: nativetwo + 2 = 4. + +(* 4611686018427387903 = int63 max_int *) +Definition nativebig := Eval native_compute in 2 + 4611686018427387903. +Check eq_refl : nativebig = 4611686018427387905. +Check eq_refl nativebig <<: nativebig = 4611686018427387905. +Check eq_refl (S nativebig) <<: S nativebig = 4611686018427387906. + Check eq_refl 0 <: pred (pred 1) = 0. +Check eq_refl 0 <<: pred (pred 1) = 0. Check eq_refl 4611686018427387900 : 4611686018427387900 = pred (pred (pred 4611686018427387903)). Check eq_refl 4611686018427387900 <: 4611686018427387900 = pred (pred (pred 4611686018427387903)). +Check eq_refl 4611686018427387900 <<: 4611686018427387900 = pred (pred (pred 4611686018427387903)). Check eq_refl 4611686018427387900 : 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). Check eq_refl 4611686018427387900 <: 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). +Check eq_refl 4611686018427387900 <<: 4611686018427387900 = pred (pred (pred (pred (pred (pred (3 + 4611686018427387903)))))). Goal forall n:N, 0 = n -> 1 = S n. Proof. From 3369dfab8314800629c0c5bae1546da6b5ca9d4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 18:24:00 +0100 Subject: [PATCH 34/36] fix postprocess some more --- interp/primNotations.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/interp/primNotations.ml b/interp/primNotations.ml index b4f7407a5fe5..55b07209212a 100644 --- a/interp/primNotations.ml +++ b/interp/primNotations.ml @@ -470,7 +470,14 @@ let no_such_prim_token uninterpreted_token_kind ?loc ?errmsg ty = pr_opt (fun errmsg -> surround errmsg) errmsg) let rec postprocess env token_kind ?loc ty to_post post g = - let g', gl = match DAst.get g with Glob_term.GApp (g, gl) -> g, gl | _ -> g, [] in + let g', gl = match DAst.get g with + | Glob_term.GApp (g, gl) -> g, gl + | GNat (ind,n) -> + let r = DAst.make @@ GRef (GlobRef.ConstructRef (ctor_of_nat ind n), None) in + if Z.equal n Z.zero then r, [] + else r, [DAst.make @@ GNat (ind, Z.pred n)] + | _ -> g, [] + in let o = match DAst.get g' with | Glob_term.GRef (r, None) -> From 0217db79781bcdb31c4d64e7d0b35c9be46ae0d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 18:29:08 +0100 Subject: [PATCH 35/36] handle primitive nats in congruence --- plugins/cc/cctac.ml | 3 ++- test-suite/success/bignat.v | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 2e173ac6cf71..8d52a38daf67 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -54,7 +54,8 @@ let whd_in_concl = let sf_of env sigma c = ESorts.kind sigma (snd (sort_of env sigma c)) let rec decompose_term env sigma t = - match EConstr.kind sigma (whd env sigma t) with + (* XXX more efficient Nat handling? *) + match EConstr.kind_nonat sigma (whd env sigma t) with App (f,args)-> let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in diff --git a/test-suite/success/bignat.v b/test-suite/success/bignat.v index d21f35617516..c73464c3f28b 100644 --- a/test-suite/success/bignat.v +++ b/test-suite/success/bignat.v @@ -161,3 +161,7 @@ Proof. rewrite H. reflexivity. Qed. + +Goal 1 = 2 -> False. + congruence. +Qed. From cdb405e447c1b6c5021384a1f24c07692f132e70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Gilbert?= Date: Tue, 10 Mar 2026 18:31:51 +0100 Subject: [PATCH 36/36] more overlays --- dev/bench/bench.sh | 2 +- dev/ci/user-overlays/21729-SkySkimmer-bignat.sh | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/dev/bench/bench.sh b/dev/bench/bench.sh index 2aaa342214fa..0efed1719427 100755 --- a/dev/bench/bench.sh +++ b/dev/bench/bench.sh @@ -54,7 +54,7 @@ check_variable () { # example: coq-hott.dev git+https://github.com/some-user/coq-hott#some-branch # (make sure to include the version for the opam package, note that just https won't work) -: "${new_opam_override_urls:=rocq-elpi.dev git+https://github.com/skyskimmer/coq-elpi#bignat}" +: "${new_opam_override_urls:=rocq-elpi.dev git+https://github.com/skyskimmer/coq-elpi#bignat rocq-equations.dev git+https://github.com/skyskimmer/coq-equations#bignat}" : "${old_opam_override_urls:=}" if [ "$CI" ]; then diff --git a/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh b/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh index f687102d54b3..fc150410fd95 100644 --- a/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh +++ b/dev/ci/user-overlays/21729-SkySkimmer-bignat.sh @@ -1 +1,3 @@ overlay elpi https://github.com/SkySkimmer/coq-elpi bignat 21729 + +overlay equations https://github.com/SkySkimmer/Coq-Equations bignat 21729