From 46454e2d998e420a11b37941ecbe42f09f24160c Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Sun, 23 Apr 2023 03:33:58 -0700 Subject: [PATCH 01/65] Fix monad_map_branches_k name (#953) --- pcuic/theories/PCUICMonadAst.v | 4 ++-- template-coq/theories/MonadAst.v | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/pcuic/theories/PCUICMonadAst.v b/pcuic/theories/PCUICMonadAst.v index 649235aed..00ec117ee 100644 --- a/pcuic/theories/PCUICMonadAst.v +++ b/pcuic/theories/PCUICMonadAst.v @@ -59,6 +59,6 @@ Section with_monad. Definition monad_map_branch_k {term term'} (f : nat -> term -> T term') g k b := @monad_map_branch term term' (f (#|bcontext b| + k)) g b. - Notation map_branches_k f h k brs := - (monad_map (monad_map_branch_k f h k) brs). + Definition monad_map_branches_k {term term'} f h k brs := + (monad_map (@monad_map_branch_k term term' f h k) brs). End with_monad. diff --git a/template-coq/theories/MonadAst.v b/template-coq/theories/MonadAst.v index a7277c039..e5d8a3049 100644 --- a/template-coq/theories/MonadAst.v +++ b/template-coq/theories/MonadAst.v @@ -62,6 +62,6 @@ Section with_monad. Definition monad_map_branches {term B} (f : term -> T B) l := monad_map (monad_map_branch f) l. - Notation monad_map_branches_k f k brs := - (monad_map (fun b => monad_map_branch (f (#|b.(bcontext)| + k)) b) brs). + Definition monad_map_branches_k {term term'} f k brs := + (monad_map (fun b => @monad_map_branch term term' (f (#|b.(bcontext)| + k)) b) brs). End with_monad. From d8f14791ac74e7d1257b4b9cfe1ec7c78586d73e Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Sun, 23 Apr 2023 03:38:12 -0700 Subject: [PATCH 02/65] Add boolean versions of the varieties of `extends` (#954) --- common/_CoqProject.in | 1 + common/theories/Environment.v | 46 ++++++- common/theories/EnvironmentReflect.v | 119 ++++++++++++++++++ common/theories/Universes.v | 59 +++++++-- pcuic/theories/Syntax/PCUICReflect.v | 5 + quotation/theories/ToPCUIC/Common/Universes.v | 4 +- .../theories/ToTemplate/Common/Universes.v | 4 +- template-coq/theories/ReflectAst.v | 6 +- utils/theories/MCOption.v | 27 +++- 9 files changed, 251 insertions(+), 20 deletions(-) create mode 100644 common/theories/EnvironmentReflect.v diff --git a/common/_CoqProject.in b/common/_CoqProject.in index 7e3410b00..6530d5162 100644 --- a/common/_CoqProject.in +++ b/common/_CoqProject.in @@ -11,5 +11,6 @@ theories/MonadBasicAst.v theories/Environment.v theories/Reflect.v theories/EnvironmentTyping.v +theories/EnvironmentReflect.v theories/EnvMap.v theories/Transform.v diff --git a/common/theories/Environment.v b/common/theories/Environment.v index 2f7da713b..fbfc1cf67 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -2,7 +2,7 @@ From Coq Require Import ssreflect ssrbool ssrfun Morphisms Setoid. From MetaCoq.Utils Require Import utils. From MetaCoq.Common Require Import BasicAst Primitive Universes. -From Equations.Prop Require Import Classes. +From Equations.Prop Require Import Classes EqDecInstances. Module Type Term. @@ -28,8 +28,13 @@ End Term. Module Type TermDecide (Import T : Term). #[export] Declare Instance term_eq_dec : EqDec term. + #[export] Hint Extern 0 (ReflectEq term) => exact (@EqDec_ReflectEq term term_eq_dec) : typeclass_instances. End TermDecide. +Module TermDecideReflectInstances (Import T : Term) (Import TDec : TermDecide T). + #[export] Hint Extern 0 (ReflectEq term) => exact (@EqDec_ReflectEq term term_eq_dec) : typeclass_instances. +End TermDecideReflectInstances. + Module Retroknowledge. Record t := mk_retroknowledge { @@ -44,6 +49,20 @@ Module Retroknowledge. option_extends x.(retro_float64) y.(retro_float64). Existing Class extends. + Definition extendsb (x y : t) := + option_extendsb x.(retro_int63) y.(retro_int63) && + option_extendsb x.(retro_float64) y.(retro_float64). + + Lemma extendsT x y : reflect (extends x y) (extendsb x y). + Proof. + rewrite /extends/extendsb; do 2 case: option_extendsT; cbn; constructor; intuition. + Qed. + + Lemma extends_spec x y : extendsb x y <-> extends x y. + Proof. + rewrite /extends/extendsb -!option_extends_spec /is_true !Bool.andb_true_iff //=. + Qed. + #[global] Instance extends_refl x : extends x x. Proof. split; apply option_extends_refl. @@ -54,7 +73,15 @@ Module Retroknowledge. intros x y z [] []; split; cbn; now etransitivity; tea. Qed. + #[export,program] Instance reflect_t : ReflectEq t := { + eqb x y := (x.(retro_int63) == y.(retro_int63)) && + (x.(retro_float64) == y.(retro_float64)) + }. + Next Obligation. + do 2 case: eqb_spec; destruct x, y; cbn; intros; subst; constructor; congruence. + Qed. End Retroknowledge. +Export (hints) Retroknowledge. Module Environment (T : Term). @@ -983,8 +1010,25 @@ Module Type EnvironmentDecide (T : Term) (Import E : EnvironmentSig T). #[export] Declare Instance mutual_inductive_body_eq_dec : EqDec mutual_inductive_body. #[export] Declare Instance constant_body_eq_dec : EqDec constant_body. #[export] Declare Instance global_decl_eq_dec : EqDec global_decl. + #[export] Hint Extern 0 (ReflectEq context) => exact (@EqDec_ReflectEq context context_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq constructor_body) => exact (@EqDec_ReflectEq constructor_body constructor_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq projection_body) => exact (@EqDec_ReflectEq projection_body projection_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq one_inductive_body) => exact (@EqDec_ReflectEq one_inductive_body one_inductive_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq mutual_inductive_body) => exact (@EqDec_ReflectEq mutual_inductive_body mutual_inductive_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq constant_body) => exact (@EqDec_ReflectEq constant_body constant_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq global_decl) => exact (@EqDec_ReflectEq global_decl global_decl_eq_dec) : typeclass_instances. End EnvironmentDecide. +Module EnvironmentDecideReflectInstances (T : Term) (Import E : EnvironmentSig T) (Import EDec : EnvironmentDecide T E). + #[export] Hint Extern 0 (ReflectEq context) => exact (@EqDec_ReflectEq context context_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq constructor_body) => exact (@EqDec_ReflectEq constructor_body constructor_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq projection_body) => exact (@EqDec_ReflectEq projection_body projection_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq one_inductive_body) => exact (@EqDec_ReflectEq one_inductive_body one_inductive_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq mutual_inductive_body) => exact (@EqDec_ReflectEq mutual_inductive_body mutual_inductive_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq constant_body) => exact (@EqDec_ReflectEq constant_body constant_body_eq_dec) : typeclass_instances. + #[export] Hint Extern 0 (ReflectEq global_decl) => exact (@EqDec_ReflectEq global_decl global_decl_eq_dec) : typeclass_instances. +End EnvironmentDecideReflectInstances. + Module Type TermUtils (T: Term) (E: EnvironmentSig T). Import T E. diff --git a/common/theories/EnvironmentReflect.v b/common/theories/EnvironmentReflect.v new file mode 100644 index 000000000..63c5f9571 --- /dev/null +++ b/common/theories/EnvironmentReflect.v @@ -0,0 +1,119 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import ssreflect ssrbool ssrfun Morphisms Setoid. +From MetaCoq.Utils Require Import utils. +From MetaCoq.Common Require Import BasicAst Primitive Universes Environment Reflect. +From Equations.Prop Require Import Classes EqDecInstances. + +Module EnvironmentReflect (T : Term) (Import E : EnvironmentSig T) (Import TDec : TermDecide T) (Import EDec : EnvironmentDecide T E). + + Local Notation extendsb_decls_part Σ Σ' + := (forallb (fun d => let c := d.1 in skipn (#|lookup_envs Σ' c| - #|lookup_envs Σ c|) (lookup_envs Σ' c) == lookup_envs Σ c) (declarations Σ)) (only parsing). + Local Notation strictly_extendsb_decls_part Σ Σ' + := (skipn (#|Σ'.(declarations)| - #|Σ.(declarations)|) Σ'.(declarations) == Σ.(declarations)) (only parsing). + + Lemma extends_decls_partT (Σ Σ' : global_env) + : reflectT (forall c, ∑ decls, lookup_envs Σ' c = decls ++ lookup_envs Σ c) (extendsb_decls_part Σ Σ'). + Proof. + case: (@forallbP _ _ _ _ (fun _ => eqb_specT _ _)) => H; constructor. + all: setoid_rewrite Forall_forall in H. + { move => c. + specialize (fun d => H (c, d)). + cbn [fst] in *. + specialize (fun pf : { d : _ | In (c, d) _ } => H (proj1_sig pf) (proj2_sig pf)). + destruct (lookup_envs Σ c) eqn:H'. + { eexists; rewrite app_nil_r; reflexivity. } + rewrite <- H; clear H. + { eexists; symmetry; apply firstn_skipn. } + unfold lookup_envs in *. + move: H'; elim: (declarations Σ); cbn [lookup_globals] => //= ??. + case: eqb_specT => ?; subst. + all: move => H H'; try destruct (H H'); rdest; eauto. } + { intro H'; apply H; clear H; intros [c ?]; specialize (H' c). + destruct H' as [decls H']. + cbn [fst]. + rewrite H' app_length Nat.add_sub skipn_all_app //. } + Qed. + + Lemma strictly_extends_decls_partT (Σ Σ' : global_env) + : reflectT (∑ Σ'', declarations Σ' = Σ'' ++ declarations Σ) (strictly_extendsb_decls_part Σ Σ'). + Proof. + case: eqb_specT => H; constructor. + { rewrite -H. + eexists; symmetry; apply firstn_skipn. } + { move => [Σ'' H']. + move: H. rewrite H' app_length Nat.add_sub skipn_all_app //. } + Qed. + + Definition extendsb (Σ Σ' : global_env) : bool + := Σ.(universes) ⊂?_cs Σ'.(universes) + && extendsb_decls_part Σ Σ' + && Retroknowledge.extendsb Σ.(retroknowledge) Σ'.(retroknowledge). + + Definition extends_declsb (Σ Σ' : global_env) : bool + := (Σ.(universes) == Σ'.(universes)) + && extendsb_decls_part Σ Σ' + && (Σ.(retroknowledge) == Σ'.(retroknowledge)). + + Definition extends_strictly_on_declsb (Σ Σ' : global_env) : bool + := (Σ.(universes) ⊂?_cs Σ'.(universes)) + && strictly_extendsb_decls_part Σ Σ' + && Retroknowledge.extendsb Σ.(retroknowledge) Σ'.(retroknowledge). + + Definition strictly_extends_declsb (Σ Σ' : global_env) : bool + := (Σ.(universes) == Σ'.(universes)) + && strictly_extendsb_decls_part Σ Σ' + && (Σ.(retroknowledge) == Σ'.(retroknowledge)). + + Lemma extendsT Σ Σ' : reflectT (extends Σ Σ') (extendsb Σ Σ'). + Proof. + rewrite /extends/extendsb. + case: extends_decls_partT; case: Retroknowledge.extendsT; case: ContextSet.subsetP; cbn; + constructor; intuition. + Qed. + + Lemma extends_declsT Σ Σ' : reflectT (extends_decls Σ Σ') (extends_declsb Σ Σ'). + Proof. + rewrite /extends_decls/extends_declsb. + case: extends_decls_partT; case: eqb_specT; case: eqb_specT; cbn; + constructor; intuition. + Qed. + + Lemma extends_strictly_on_declsT Σ Σ' : reflectT (extends_strictly_on_decls Σ Σ') (extends_strictly_on_declsb Σ Σ'). + Proof. + rewrite /extends_strictly_on_decls/extends_strictly_on_declsb. + case: strictly_extends_decls_partT; case: Retroknowledge.extendsT; case: ContextSet.subsetP; cbn; + constructor; intuition. + Qed. + + Lemma strictly_extends_declsT Σ Σ' : reflectT (strictly_extends_decls Σ Σ') (strictly_extends_declsb Σ Σ'). + Proof. + rewrite /strictly_extends_decls/strictly_extends_declsb. + case: strictly_extends_decls_partT; case: eqb_specT; case: eqb_specT; cbn; + constructor; intuition. + Qed. + + Lemma extends_spec Σ Σ' : extendsb Σ Σ' <~> extends Σ Σ'. + Proof. + case: extendsT; split; intuition congruence. + Qed. + + Lemma extends_decls_spec Σ Σ' : extends_declsb Σ Σ' <~> extends_decls Σ Σ'. + Proof. + case: extends_declsT; split; intuition congruence. + Qed. + + Lemma extends_strictly_on_decls_spec Σ Σ' : extends_strictly_on_declsb Σ Σ' <~> extends_strictly_on_decls Σ Σ'. + Proof. + case: extends_strictly_on_declsT; split; intuition congruence. + Qed. + + Lemma strictly_extends_decls_spec Σ Σ' : strictly_extends_declsb Σ Σ' <~> strictly_extends_decls Σ Σ'. + Proof. + case: strictly_extends_declsT; split; intuition congruence. + Qed. + +End EnvironmentReflect. + +Module Type EnvironmentReflectSig (T : Term) (E : EnvironmentSig T) (TDec : TermDecide T) (EDec : EnvironmentDecide T E). + Include EnvironmentReflect T E TDec EDec. +End EnvironmentReflectSig. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 6c31dd7ce..71e71ac40 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -172,6 +172,8 @@ Module LS := LevelSet. Ltac lsets := LevelSetDecide.fsetdec. Notation "(=_lset)" := LevelSet.Equal (at level 0). Infix "=_lset" := LevelSet.Equal (at level 30). +Notation "(==_lset)" := LevelSet.equal (at level 0). +Infix "==_lset" := LevelSet.equal (at level 30). Section LevelSetMoreFacts. @@ -1496,6 +1498,8 @@ Ltac csets := ConstraintSetDecide.fsetdec. Notation "(=_cset)" := ConstraintSet.Equal (at level 0). Infix "=_cset" := ConstraintSet.Equal (at level 30). +Notation "(==_cset)" := ConstraintSet.equal (at level 0). +Infix "==_cset" := ConstraintSet.equal (at level 30). Definition declared_cstr_levels levels (cstr : UnivConstraint.t) := let '(l1,_,l2) := cstr in @@ -1600,21 +1604,28 @@ Module ContextSet. Definition is_empty (uctx : t) := LevelSet.is_empty (fst uctx) && ConstraintSet.is_empty (snd uctx). - Definition equal (x y : t) : Prop := + Definition Equal (x y : t) : Prop := x.1 =_lset y.1 /\ x.2 =_cset y.2. - Definition subset (x y : t) : Prop := + Definition equal (x y : t) : bool := + x.1 ==_lset y.1 && x.2 ==_cset y.2. + + Definition Subset (x y : t) : Prop := LevelSet.Subset (levels x) (levels y) /\ ConstraintSet.Subset (constraints x) (constraints y). + Definition subset (x y : t) : bool := + LevelSet.subset (levels x) (levels y) && + ConstraintSet.subset (constraints x) (constraints y). + Definition inter (x y : t) : t := (LevelSet.inter (levels x) (levels y), ConstraintSet.inter (constraints x) (constraints y)). Definition inter_spec (x y : t) : - subset (inter x y) x /\ - subset (inter x y) y /\ - forall z, subset z x -> subset z y -> subset z (inter x y). + Subset (inter x y) x /\ + Subset (inter x y) y /\ + forall z, Subset z x -> Subset z y -> Subset z (inter x y). Proof. split; last split. 1,2: split=> ?; [move=> /LevelSet.inter_spec [//]|move=> /ConstraintSet.inter_spec [//]]. @@ -1626,21 +1637,45 @@ Module ContextSet. (LevelSet.union (levels x) (levels y), ConstraintSet.union (constraints x) (constraints y)). Definition union_spec (x y : t) : - subset x (union x y) /\ - subset y (union x y) /\ - forall z, subset x z -> subset y z -> subset (union x y) z. + Subset x (union x y) /\ + Subset y (union x y) /\ + forall z, Subset x z -> Subset y z -> Subset (union x y) z. Proof. split; last split. 1,2: split=> ??; [apply/LevelSet.union_spec|apply/ConstraintSet.union_spec ]; by constructor. move=> ? [??] [??]; split=> ?; [move=>/LevelSet.union_spec|move=>/ConstraintSet.union_spec]=>-[]; auto. Qed. + + Lemma equal_spec s s' : equal s s' <-> Equal s s'. + Proof. + rewrite /equal/Equal/is_true Bool.andb_true_iff LevelSet.equal_spec ConstraintSet.equal_spec. + reflexivity. + Qed. + + Lemma subset_spec s s' : subset s s' <-> Subset s s'. + Proof. + rewrite /subset/Subset/is_true Bool.andb_true_iff LevelSet.subset_spec ConstraintSet.subset_spec. + reflexivity. + Qed. + + Lemma subsetP s s' : reflect (Subset s s') (subset s s'). + Proof. + generalize (subset_spec s s'). + destruct subset; case; constructor; intuition. + Qed. End ContextSet. -Notation "(=_cs)" := ContextSet.equal (at level 0). -Notation "(⊂_cs)" := ContextSet.subset (at level 0). -Infix "=_cs" := ContextSet.equal (at level 30). -Infix "⊂_cs" := ContextSet.subset (at level 30). +Export (hints) ContextSet. + +Notation "(=_cs)" := ContextSet.Equal (at level 0). +Notation "(⊂_cs)" := ContextSet.Subset (at level 0). +Infix "=_cs" := ContextSet.Equal (at level 30). +Infix "⊂_cs" := ContextSet.Subset (at level 30). +Notation "(==_cs)" := ContextSet.equal (at level 0). +Notation "(⊂?_cs)" := ContextSet.subset (at level 0). +Infix "==_cs" := ContextSet.equal (at level 30). +Infix "⊂?_cs" := ContextSet.subset (at level 30). Lemma incl_cs_refl cs : cs ⊂_cs cs. Proof. diff --git a/pcuic/theories/Syntax/PCUICReflect.v b/pcuic/theories/Syntax/PCUICReflect.v index 51100825c..a28cedb55 100644 --- a/pcuic/theories/Syntax/PCUICReflect.v +++ b/pcuic/theories/Syntax/PCUICReflect.v @@ -4,6 +4,7 @@ From Equations Require Import Equations. From MetaCoq.PCUIC Require Import PCUICAst PCUICInduction. From MetaCoq.Utils Require Import utils. +From MetaCoq.Common Require Import EnvironmentReflect. From MetaCoq.Common Require Export Reflect. Open Scope pcuic. @@ -375,6 +376,7 @@ Qed. Module PCUICTermDecide <: TermDecide PCUICTerm. #[export] Instance term_eq_dec : EqDec term := _. + Include TermDecideReflectInstances PCUICTerm. End PCUICTermDecide. Module PCUICEnvironmentDecide <: EnvironmentDecide PCUICTerm PCUICEnvironment. @@ -385,4 +387,7 @@ Module PCUICEnvironmentDecide <: EnvironmentDecide PCUICTerm PCUICEnvironment. #[export] Instance mutual_inductive_body_eq_dec : EqDec mutual_inductive_body := _. #[export] Instance constant_body_eq_dec : EqDec constant_body := _. #[export] Instance global_decl_eq_dec : EqDec global_decl := _. + Include EnvironmentDecideReflectInstances PCUICTerm PCUICEnvironment. End PCUICEnvironmentDecide. + +Module PCUICEnvironmentReflect := EnvironmentReflect PCUICTerm PCUICEnvironment PCUICTermDecide PCUICEnvironmentDecide. diff --git a/quotation/theories/ToPCUIC/Common/Universes.v b/quotation/theories/ToPCUIC/Common/Universes.v index de10eb793..b5d367728 100644 --- a/quotation/theories/ToPCUIC/Common/Universes.v +++ b/quotation/theories/ToPCUIC/Common/Universes.v @@ -63,8 +63,8 @@ Export (hints) QuoteUniverses1. UContext.t AUContext.t ContextSet.t - ContextSet.equal - ContextSet.subset + ContextSet.Equal + ContextSet.Subset : quotation. #[export] Typeclasses Transparent diff --git a/quotation/theories/ToTemplate/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v index 29c7034df..f89016683 100644 --- a/quotation/theories/ToTemplate/Common/Universes.v +++ b/quotation/theories/ToTemplate/Common/Universes.v @@ -63,8 +63,8 @@ Export (hints) QuoteUniverses1. UContext.t AUContext.t ContextSet.t - ContextSet.equal - ContextSet.subset + ContextSet.Equal + ContextSet.Subset : quotation. #[export] Typeclasses Transparent diff --git a/template-coq/theories/ReflectAst.v b/template-coq/theories/ReflectAst.v index 30029511e..3123f91e7 100644 --- a/template-coq/theories/ReflectAst.v +++ b/template-coq/theories/ReflectAst.v @@ -2,7 +2,7 @@ (* For primitive integers and floats *) From Coq Require Numbers.Cyclic.Int63.Uint63 Floats.PrimFloat Floats.FloatAxioms. From MetaCoq.Utils Require Import utils. -From MetaCoq.Common Require Import BasicAst Reflect Environment. +From MetaCoq.Common Require Import BasicAst Reflect Environment EnvironmentReflect. From MetaCoq.Template Require Import AstUtils Ast Induction. Require Import ssreflect. From Equations Require Import Equations. @@ -248,6 +248,7 @@ Defined. Module TemplateTermDecide <: TermDecide TemplateTerm. #[export] Instance term_eq_dec : EqDec term := _. + Include TermDecideReflectInstances TemplateTerm. End TemplateTermDecide. Module EnvDecide <: EnvironmentDecide TemplateTerm Env. @@ -258,4 +259,7 @@ Module EnvDecide <: EnvironmentDecide TemplateTerm Env. #[export] Instance mutual_inductive_body_eq_dec : EqDec mutual_inductive_body := _. #[export] Instance constant_body_eq_dec : EqDec constant_body := _. #[export] Instance global_decl_eq_dec : EqDec global_decl := _. + Include EnvironmentDecideReflectInstances TemplateTerm Env. End EnvDecide. + +Module EnvReflect := EnvironmentReflect TemplateTerm Env TemplateTermDecide EnvDecide. diff --git a/utils/theories/MCOption.v b/utils/theories/MCOption.v index f1d0dfd19..05bf8efd0 100644 --- a/utils/theories/MCOption.v +++ b/utils/theories/MCOption.v @@ -1,6 +1,6 @@ -From Coq Require Import List ssreflect Arith Morphisms Relation_Definitions. +From Coq Require Import List ssreflect ssrbool Arith Morphisms Relation_Definitions. -From MetaCoq.Utils Require Import MCPrelude MCList MCProd MCReflect. +From MetaCoq.Utils Require Import MCPrelude MCList MCProd MCReflect ReflectEq. Definition option_get {A} (default : A) (x : option A) : A := match x with @@ -202,6 +202,29 @@ Inductive option_extends {A} : relation (option A) := | option_ext_non : option_extends None None. Derive Signature for option_extends. +Definition option_extendsb {A} {Aeq:ReflectEq A} (x y : option A) : bool := + match x, y with + | None, Some _ => true + | Some t1, Some t2 => t1 == t2 + | None, None => true + | _, _ => false + end. + +Lemma option_extendsT {A} {Aeq : ReflectEq A} x y : reflect (@option_extends A x y) (option_extendsb x y). +Proof. + destruct x as [x|], y as [y|]; cbn. + 1: generalize (eqb_spec x y); case: eqb => H. + all: constructor. + 1: replace y with x by now inversion H. + all: first [ constructor | inversion 1 ]. + { inversion H; congruence. } +Qed. + +Lemma option_extends_spec {A} {Aeq : ReflectEq A} x y : option_extendsb x y <-> @option_extends A x y. +Proof. + case: option_extendsT; intuition congruence. +Qed. + #[export] Instance option_extends_refl {A} : RelationClasses.Reflexive (@option_extends A). Proof. intros []; constructor. Qed. From dd8c80d4bfc86efd74a2271702e1081cc1c2adee Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Thu, 20 Apr 2023 20:56:20 -0700 Subject: [PATCH 03/65] Add a merge operation for the global env This is useful for managing global envs around Gallina quotation. --- common/theories/Environment.v | 117 ++++++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) diff --git a/common/theories/Environment.v b/common/theories/Environment.v index fbfc1cf67..725265ea5 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -80,6 +80,39 @@ Module Retroknowledge. Next Obligation. do 2 case: eqb_spec; destruct x, y; cbn; intros; subst; constructor; congruence. Qed. + + (** This operation is asymmetric; it perfers the first argument when the arguments are incompatible, but otherwise takes the join *) + Definition merge (r1 r2 : t) : t + := {| retro_int63 := match r1.(retro_int63) with Some v => Some v | None => r2.(retro_int63) end + ; retro_float64 := match r1.(retro_float64) with Some v => Some v | None => r2.(retro_float64) end |}. + + Lemma extends_l_merge r1 r2 + : extends r1 (merge r1 r2). + Proof. + rewrite /extends/merge; destruct r1, r2; cbn; repeat destruct ?; subst; + repeat constructor; clear; destruct_head' option; constructor. + Qed. + + Lemma extends_merge_idempotent r1 r2 + : extends r1 r2 -> merge r1 r2 = r2. + Proof. + rewrite /extends/merge; destruct r1, r2; cbn. + intro; rdest; destruct_head' (@option_extends); reflexivity. + Qed. + + Definition compatible (x y : t) : bool + := match x.(retro_int63), y.(retro_int63) with Some x, Some y => x == y | _, _ => true end + && match x.(retro_float64), y.(retro_float64) with Some x, Some y => x == y | _, _ => true end. + + Lemma extends_r_merge r1 r2 + : compatible r1 r2 -> extends r2 (merge r1 r2). + Proof. + rewrite /extends/merge/compatible; destruct r1, r2; cbn; repeat destruct ?; subst. + all: repeat case: eqb_spec => //=. + all: intros; subst. + all: repeat constructor; clear; destruct_head' option; constructor. + Qed. + End Retroknowledge. Export (hints) Retroknowledge. @@ -616,6 +649,90 @@ Module Environment (T : Term). #[global] Instance extends_trans : CRelationClasses.Transitive extends. Proof. extends_trans_t. Qed. + (** Merge two lists of global_declarations, assuming that any globals sharing a name are identical *) + Definition merge_globals (Σ Σ' : global_declarations) : global_declarations + := let known_kns := List.fold_right KernameSet.add KernameSet.empty (List.map fst Σ) in + List.filter (fun '(kn, _) => negb (KernameSet.mem kn known_kns)) Σ' ++ Σ. + + Definition merge_global_envs (Σ Σ' : global_env) : global_env + := {| universes := ContextSet.union Σ.(universes) Σ'.(universes) + ; declarations := merge_globals Σ.(declarations) Σ'.(declarations) + ; retroknowledge := Retroknowledge.merge Σ.(retroknowledge) Σ'.(retroknowledge) |}. + + Definition compatible_globals (Σ Σ' : global_declarations) : Prop + := forall c, lookup_globals Σ c <> [] -> lookup_globals Σ' c <> [] -> lookup_globals Σ c = lookup_globals Σ' c. + + Lemma extends_strictly_on_decls_l_merge Σ Σ' + : extends_strictly_on_decls Σ (merge_global_envs Σ Σ'). + Proof. + rewrite /extends_strictly_on_decls/merge_global_envs/merge_globals; cbn. + split; + try first [ apply ContextSet.union_spec + | apply Retroknowledge.extends_l_merge + | now eexists ]. + Qed. + + Definition compatible (Σ Σ' : global_env) + := Retroknowledge.compatible Σ.(retroknowledge) Σ'.(retroknowledge) + /\ compatible_globals Σ.(declarations) Σ'.(declarations). + + Lemma lookup_globals_filter p Σ c + : lookup_globals (filter (fun '(kn, _) => p kn) Σ) c = if p c then lookup_globals Σ c else []. + Proof. + induction Σ as [|?? IH]; cbn; rdest; cbn; try now repeat destruct ?. + case: eqb_spec => ?; repeat destruct ?; subst => //=. + all: rewrite ?eqb_refl. + all: try case: eqb_spec => ?; subst. + all: rewrite IH //=. + all: try congruence. + Qed. + + Lemma extends_r_merge_globals Σ Σ' + : compatible_globals Σ Σ' -> + forall c, + ∑ decls, lookup_globals (merge_globals Σ Σ') c = decls ++ lookup_globals Σ' c. + Proof. + rewrite /merge_globals. + intro H2; cbn. + cbv [compatible_globals] in *. + intro c. + specialize (H2 c). + rewrite lookup_globals_app lookup_globals_filter. + set (s := fold_right _ _ _). + assert (Hs : forall kn, KernameSet.mem kn s <-> List.In kn (map fst Σ)). + { setoid_rewrite <- KernameSetFact.mem_iff. + clear. + generalize dependent Σ; clear. + elim => //=; try setoid_rewrite KernameSetFact.empty_iff => //=. + move => [? ?] ? IH kn //=. + rewrite KernameSet.add_spec. + intuition. } + clearbody s. + specialize (Hs c). + destruct (in_dec eq_dec c (map fst Σ')) as [H'|H']; + [ exists nil | exists (lookup_globals Σ c) ]. + 2: apply lookup_globals_nil in H'; rewrite H'; clear H'. + 2: now destruct ?; cbn; rewrite app_nil_r. + pose proof (lookup_globals_nil Σ c) as Hc. + rewrite <- !lookup_globals_nil, <- Hs in H2. + rewrite <- Hs in Hc. + destruct KernameSet.mem; cbn in *. + { intuition. } + { destruct Hc as [Hc _]. + rewrite Hc ?app_nil_r //=. } + Qed. + + Lemma extends_r_merge Σ Σ' + : compatible Σ Σ' -> extends Σ' (merge_global_envs Σ Σ'). + Proof. + rewrite /extends/compatible/merge_global_envs/lookup_envs. + intros [H1 H2]. + split; + try first [ apply ContextSet.union_spec + | now apply Retroknowledge.extends_r_merge + | now apply extends_r_merge_globals ]. + Qed. + Definition primitive_constant (Σ : global_env) (p : prim_tag) : option kername := match p with | primInt => Σ.(retroknowledge).(Retroknowledge.retro_int63) From 7ea63fabe6c7c302d5dee4bb3c318a6f9b379b0a Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Fri, 21 Apr 2023 12:55:33 -0700 Subject: [PATCH 04/65] Add computable version of Env compatibility; refactor extension a bit --- common/theories/Environment.v | 152 +++++++++++++++++++-------- common/theories/EnvironmentReflect.v | 46 +++++++- 2 files changed, 154 insertions(+), 44 deletions(-) diff --git a/common/theories/Environment.v b/common/theories/Environment.v index 725265ea5..700d6af68 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -467,24 +467,36 @@ Module Environment (T : Term). └-----------------------------┴------------------------┴---------------------------┘ >>> *) + Notation extends_decls_part_globals Σ Σ' + := (forall c, ∑ decls, lookup_globals Σ' c = decls ++ lookup_globals Σ c) + (only parsing). + Notation strictly_extends_decls_part_globals Σ Σ' + := (∑ Σ'', Σ' = Σ'' ++ Σ) + (only parsing). + Notation extends_decls_part Σ Σ' + := (forall c, ∑ decls, lookup_envs Σ' c = decls ++ lookup_envs Σ c) + (only parsing). + Notation strictly_extends_decls_part Σ Σ' + := (strictly_extends_decls_part_globals Σ.(declarations) Σ'.(declarations)) + (only parsing). Definition extends (Σ Σ' : global_env) := [× Σ.(universes) ⊂_cs Σ'.(universes), - forall c, ∑ decls, lookup_envs Σ' c = decls ++ lookup_envs Σ c & + extends_decls_part Σ Σ' & Retroknowledge.extends Σ.(retroknowledge) Σ'.(retroknowledge)]. Definition extends_decls (Σ Σ' : global_env) := [× Σ.(universes) = Σ'.(universes), - forall c, ∑ decls, lookup_envs Σ' c = decls ++ lookup_envs Σ c & + extends_decls_part Σ Σ' & Σ.(retroknowledge) = Σ'.(retroknowledge)]. Definition extends_strictly_on_decls (Σ Σ' : global_env) := [× Σ.(universes) ⊂_cs Σ'.(universes), - ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & + strictly_extends_decls_part Σ Σ' & Retroknowledge.extends Σ.(retroknowledge) Σ'.(retroknowledge)]. Definition strictly_extends_decls (Σ Σ' : global_env) := [× Σ.(universes) = Σ'.(universes), - ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & + strictly_extends_decls_part Σ Σ' & Σ.(retroknowledge) = Σ'.(retroknowledge)]. Existing Class extends. @@ -551,17 +563,16 @@ Module Environment (T : Term). all: intuition congruence. Qed. - Lemma lookup_env_extends_NoDup Σ Σ' k d : - NoDup (List.map fst Σ'.(declarations)) -> - lookup_env Σ k = Some d -> - extends Σ Σ' -> lookup_env Σ' k = Some d. + Lemma lookup_global_extends_NoDup Σ Σ' k d : + NoDup (List.map fst Σ') -> + lookup_global Σ k = Some d -> + extends_decls_part_globals Σ Σ' -> lookup_global Σ' k = Some d. Proof. - rewrite /lookup_env /= -!hd_error_lookup_globals => Hnd. + rewrite /= -!hd_error_lookup_globals => Hnd. move: (@NoDup_length_lookup_globals _ Hnd k); clear Hnd. rewrite -hd_error_lookup_globals. - move=> H Hd [? eq]. + move=> H Hd eq. move: (eq k); clear eq. - rewrite /lookup_envs. case => ls eq. move: eq Hd H => ->. case: ls => //= ?. @@ -569,6 +580,15 @@ Module Environment (T : Term). case: lookup_globals => //=. Qed. + Lemma lookup_env_extends_NoDup Σ Σ' k d : + NoDup (List.map fst Σ'.(declarations)) -> + lookup_env Σ k = Some d -> + extends Σ Σ' -> lookup_env Σ' k = Some d. + Proof. + move => Hnd Hd; case => *. + eapply lookup_global_extends_NoDup; tea. + Qed. + Lemma lookup_globals_app Σ Σ' kn : lookup_globals (Σ ++ Σ') kn = lookup_globals Σ kn ++ lookup_globals Σ' kn. Proof. @@ -577,14 +597,25 @@ Module Environment (T : Term). case: eqb_spec => //= -> -> //=. Qed. - #[global] Instance strictly_extends_decls_extends_decls Σ Σ' : strictly_extends_decls Σ Σ' -> extends_decls Σ Σ'. + Lemma strictly_extends_decls_extends_part_globals Σ Σ' + : strictly_extends_decls_part_globals Σ Σ' -> extends_decls_part_globals Σ Σ'. Proof. - destruct Σ, Σ'; case => //= -> [Σ'' ->] ->. - rewrite /extends_decls/lookup_envs //=; split => //= ?. + case => //= ? -> c. rewrite lookup_globals_app. eexists; reflexivity. Qed. + Lemma strictly_extends_decls_extends_part Σ Σ' + : strictly_extends_decls_part Σ Σ' -> extends_decls_part Σ Σ'. + Proof. apply strictly_extends_decls_extends_part_globals. Qed. + + #[global] Instance strictly_extends_decls_extends_decls Σ Σ' : strictly_extends_decls Σ Σ' -> extends_decls Σ Σ'. + Proof. + destruct Σ, Σ'; case => //= -> ? ->. + rewrite /extends_decls; split; try reflexivity. + now apply strictly_extends_decls_extends_part. + Qed. + #[global] Instance strictly_extends_decls_extends_strictly_on_decls Σ Σ' : strictly_extends_decls Σ Σ' -> extends_strictly_on_decls Σ Σ'. Proof. destruct Σ, Σ'; intros []. cbn in *; subst. split => //=. @@ -599,10 +630,9 @@ Module Environment (T : Term). #[global] Instance extends_strictly_on_decls_extends Σ Σ' : extends_strictly_on_decls Σ Σ' -> extends Σ Σ'. Proof. - destruct Σ, Σ'; case => //= ? [Σ'' ->] ?. - rewrite /extends/lookup_envs //=; split => //= ?. - rewrite lookup_globals_app. - eexists; reflexivity. + destruct Σ, Σ'; case => //= ? ? ?. + rewrite /extends; split => //=. + now apply strictly_extends_decls_extends_part. Qed. #[global] Instance strictly_extends_decls_extends_decls_subrel : CRelationClasses.subrelation strictly_extends_decls extends_decls := strictly_extends_decls_extends_decls. @@ -628,18 +658,48 @@ Module Environment (T : Term). Proof. apply extends_refl. Qed. *) + Lemma extends_decls_part_globals_refl Σ : extends_decls_part_globals Σ Σ. + Proof. now exists [] => //. Qed. + + Lemma extends_decls_part_refl Σ : extends_decls_part Σ Σ. + Proof. apply extends_decls_part_globals_refl. Qed. + + Lemma strictly_extends_decls_part_globals_refl (Σ : global_declarations) + : strictly_extends_decls_part_globals Σ Σ. + Proof. now exists [] => //. Qed. + + Lemma strictly_extends_decls_part_refl Σ : strictly_extends_decls_part Σ Σ. + Proof. apply strictly_extends_decls_part_globals_refl. Qed. + + Lemma extends_decls_part_globals_trans Σ Σ' Σ'' + : extends_decls_part_globals Σ Σ' -> extends_decls_part_globals Σ' Σ'' -> extends_decls_part_globals Σ Σ''. + Proof. + move => H1 H2 c; move: (H1 c) (H2 c) => [? ->] [? ->]. + now eexists; rewrite app_assoc. + Qed. + + Lemma extends_decls_part_trans Σ Σ' Σ'' + : extends_decls_part Σ Σ' -> extends_decls_part Σ' Σ'' -> extends_decls_part Σ Σ''. + Proof. apply extends_decls_part_globals_trans. Qed. + + Lemma strictly_extends_decls_part_globals_trans (Σ Σ' Σ'' : global_declarations) + : strictly_extends_decls_part_globals Σ Σ' -> strictly_extends_decls_part_globals Σ' Σ'' -> strictly_extends_decls_part_globals Σ Σ''. + Proof. + move => [? ->] [? ->]. + now eexists; rewrite app_assoc. + Qed. + + Lemma strictly_extends_decls_part_trans Σ Σ' Σ'' + : strictly_extends_decls_part Σ Σ' -> strictly_extends_decls_part Σ' Σ'' -> strictly_extends_decls_part Σ Σ''. + Proof. apply strictly_extends_decls_part_globals_trans. Qed. + Local Ltac extends_trans_t := intros [?] [?] [?] [?] [?]; red; cbn in *; split; - try solve [ etransitivity; eassumption | eapply incl_cs_trans; eassumption ]; - repeat first [ progress subst - | match goal with - | [ H : ∑ x : _, _ |- _ ] => destruct H - | [ H : forall c : kername, _, kn : kername |- _ ] => specialize (H kn) - | [ H : ?x = _ |- context[?x] ] => rewrite H - end - | split - | intro - | now eexists; rewrite app_assoc ]. + try solve [ etransitivity; eassumption + | eapply incl_cs_trans; eassumption + | eapply strictly_extends_decls_part_globals_trans; eassumption + | eapply extends_decls_part_globals_trans; eassumption ]. + #[global] Instance strictly_extends_decls_trans : CRelationClasses.Transitive strictly_extends_decls. Proof. extends_trans_t. Qed. #[global] Instance extends_decls_trans : CRelationClasses.Transitive extends_decls. @@ -650,8 +710,11 @@ Module Environment (T : Term). Proof. extends_trans_t. Qed. (** Merge two lists of global_declarations, assuming that any globals sharing a name are identical *) + Definition declared_kername_set (Σ : global_declarations) : KernameSet.t + := List.fold_right KernameSet.add KernameSet.empty (List.map fst Σ). + Definition merge_globals (Σ Σ' : global_declarations) : global_declarations - := let known_kns := List.fold_right KernameSet.add KernameSet.empty (List.map fst Σ) in + := let known_kns := declared_kername_set Σ in List.filter (fun '(kn, _) => negb (KernameSet.mem kn known_kns)) Σ' ++ Σ. Definition merge_global_envs (Σ Σ' : global_env) : global_env @@ -687,6 +750,22 @@ Module Environment (T : Term). all: try congruence. Qed. + Lemma declared_kername_set_spec + : forall Σ c, KernameSet.In c (declared_kername_set Σ) <-> List.In c (map fst Σ). + Proof. + elim => //=; try setoid_rewrite KernameSetFact.empty_iff => //=. + move => [? ?] ? IH c //=. + rewrite KernameSet.add_spec. + intuition. + Qed. + + Lemma declared_kername_set_mem_iff Σ c + : KernameSet.mem c (declared_kername_set Σ) <-> List.In c (map fst Σ). + Proof. + setoid_rewrite <- KernameSetFact.mem_iff. + apply declared_kername_set_spec. + Qed. + Lemma extends_r_merge_globals Σ Σ' : compatible_globals Σ Σ' -> forall c, @@ -698,24 +777,13 @@ Module Environment (T : Term). intro c. specialize (H2 c). rewrite lookup_globals_app lookup_globals_filter. - set (s := fold_right _ _ _). - assert (Hs : forall kn, KernameSet.mem kn s <-> List.In kn (map fst Σ)). - { setoid_rewrite <- KernameSetFact.mem_iff. - clear. - generalize dependent Σ; clear. - elim => //=; try setoid_rewrite KernameSetFact.empty_iff => //=. - move => [? ?] ? IH kn //=. - rewrite KernameSet.add_spec. - intuition. } - clearbody s. - specialize (Hs c). destruct (in_dec eq_dec c (map fst Σ')) as [H'|H']; [ exists nil | exists (lookup_globals Σ c) ]. 2: apply lookup_globals_nil in H'; rewrite H'; clear H'. 2: now destruct ?; cbn; rewrite app_nil_r. pose proof (lookup_globals_nil Σ c) as Hc. - rewrite <- !lookup_globals_nil, <- Hs in H2. - rewrite <- Hs in Hc. + rewrite <- !lookup_globals_nil in H2. + rewrite <- (declared_kername_set_mem_iff Σ) in *. destruct KernameSet.mem; cbn in *. { intuition. } { destruct Hc as [Hc _]. diff --git a/common/theories/EnvironmentReflect.v b/common/theories/EnvironmentReflect.v index 63c5f9571..10ea249c3 100644 --- a/common/theories/EnvironmentReflect.v +++ b/common/theories/EnvironmentReflect.v @@ -12,7 +12,7 @@ Module EnvironmentReflect (T : Term) (Import E : EnvironmentSig T) (Import TDec := (skipn (#|Σ'.(declarations)| - #|Σ.(declarations)|) Σ'.(declarations) == Σ.(declarations)) (only parsing). Lemma extends_decls_partT (Σ Σ' : global_env) - : reflectT (forall c, ∑ decls, lookup_envs Σ' c = decls ++ lookup_envs Σ c) (extendsb_decls_part Σ Σ'). + : reflectT (extends_decls_part Σ Σ') (extendsb_decls_part Σ Σ'). Proof. case: (@forallbP _ _ _ _ (fun _ => eqb_specT _ _)) => H; constructor. all: setoid_rewrite Forall_forall in H. @@ -35,7 +35,7 @@ Module EnvironmentReflect (T : Term) (Import E : EnvironmentSig T) (Import TDec Qed. Lemma strictly_extends_decls_partT (Σ Σ' : global_env) - : reflectT (∑ Σ'', declarations Σ' = Σ'' ++ declarations Σ) (strictly_extendsb_decls_part Σ Σ'). + : reflectT (strictly_extends_decls_part Σ Σ') (strictly_extendsb_decls_part Σ Σ'). Proof. case: eqb_specT => H; constructor. { rewrite -H. @@ -112,6 +112,48 @@ Module EnvironmentReflect (T : Term) (Import E : EnvironmentSig T) (Import TDec case: strictly_extends_declsT; split; intuition congruence. Qed. + Definition compatible_globalsb (Σ Σ' : global_declarations) : bool + := KernameSet.for_all + (fun c => lookup_globals Σ c == lookup_globals Σ' c) + (KernameSet.inter (declared_kername_set Σ) (declared_kername_set Σ')). + + Definition compatibleb (Σ Σ' : global_env) : bool + := Retroknowledge.compatible Σ.(retroknowledge) Σ'.(retroknowledge) + && compatible_globalsb Σ.(declarations) Σ'.(declarations). + + Lemma compatible_globalsP Σ Σ' : reflect (compatible_globals Σ Σ') (compatible_globalsb Σ Σ'). + Proof. + rewrite /compatible_globals/compatible_globalsb. + lazymatch goal with + | [ |- context[KernameSet.for_all ?f ?s] ] + => generalize (@KernameSet.for_all_spec s f _) + end. + rewrite /KernameSet.For_all. + case: KernameSet.for_all; move => [H1 H2]; constructor. + all: first [ specialize (H1 eq_refl); rename H1 into H | clear H1 ]. + all: try pose proof (fun x => diff_false_true (H2 x)) as H; clear H2. + all: move: H. + all: setoid_rewrite KernameSet.inter_spec. + all: setoid_rewrite declared_kername_set_spec. + all: setoid_rewrite <- lookup_globals_nil. + 1: move => H c; move: (H c); clear H. + 2: move => H nH; apply H => c; move: (nH c); clear H nH. + all: case: eqb_spec. + all: intuition. + Qed. + + Lemma compatible_globals_spec Σ Σ' : compatible_globalsb Σ Σ' <-> compatible_globalsb Σ Σ'. + Proof. case: compatible_globalsP; intuition. Qed. + + Lemma compatibleP Σ Σ' : reflect (compatible Σ Σ') (compatibleb Σ Σ'). + Proof. + rewrite /compatible/compatibleb. + case: compatible_globalsP; destruct Retroknowledge.compatible; cbn; constructor; intuition. + Qed. + + Lemma compatible_spec Σ Σ' : compatibleb Σ Σ' <-> compatibleb Σ Σ'. + Proof. case: compatibleP; intuition. Qed. + End EnvironmentReflect. Module Type EnvironmentReflectSig (T : Term) (E : EnvironmentSig T) (TDec : TermDecide T) (EDec : EnvironmentDecide T E). From 6ddfd1392c8df6960b9fdf6517288dca4d7b6585 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Sun, 23 Apr 2023 22:12:36 -0700 Subject: [PATCH 05/65] More extension lemmas --- common/theories/Environment.v | 54 +++++++++++++++++++++++++++-------- 1 file changed, 42 insertions(+), 12 deletions(-) diff --git a/common/theories/Environment.v b/common/theories/Environment.v index 700d6af68..15d94d79b 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -537,6 +537,20 @@ Module Environment (T : Term). rewrite (proj1 (@lookup_global_None _ _)) => //= -> //=. Qed. + Lemma NoDup_lookup_globals_eq Σ + : NoDup (List.map fst Σ) + -> forall kn, lookup_globals Σ kn = match lookup_global Σ kn with + | Some v => [v] + | None => [] + end. + Proof. + move => H kn. + move: (NoDup_length_lookup_globals Σ H kn) (hd_error_lookup_globals Σ kn). + repeat destruct ?; subst. + all: case: lookup_globals; cbn; try congruence. + move => ? [|]; cbn; congruence. + Qed. + Lemma lookup_globals_In Σ kn decl : In (kn, decl) Σ <-> In decl (lookup_globals Σ kn). Proof. @@ -725,16 +739,6 @@ Module Environment (T : Term). Definition compatible_globals (Σ Σ' : global_declarations) : Prop := forall c, lookup_globals Σ c <> [] -> lookup_globals Σ' c <> [] -> lookup_globals Σ c = lookup_globals Σ' c. - Lemma extends_strictly_on_decls_l_merge Σ Σ' - : extends_strictly_on_decls Σ (merge_global_envs Σ Σ'). - Proof. - rewrite /extends_strictly_on_decls/merge_global_envs/merge_globals; cbn. - split; - try first [ apply ContextSet.union_spec - | apply Retroknowledge.extends_l_merge - | now eexists ]. - Qed. - Definition compatible (Σ Σ' : global_env) := Retroknowledge.compatible Σ.(retroknowledge) Σ'.(retroknowledge) /\ compatible_globals Σ.(declarations) Σ'.(declarations). @@ -750,6 +754,33 @@ Module Environment (T : Term). all: try congruence. Qed. + Lemma strictly_extends_decls_l_merge_globals Σ Σ' + : strictly_extends_decls_part_globals Σ (merge_globals Σ Σ'). + Proof. now eexists. Qed. + + Lemma extends_l_merge_globals Σ Σ' + : extends_decls_part_globals Σ (merge_globals Σ Σ'). + Proof. + rewrite /merge_globals. + intro c. + rewrite lookup_globals_app lookup_globals_filter. + eexists; reflexivity. + Qed. + + #[export] Instance extends_strictly_on_decls_l_merge Σ Σ' + : extends_strictly_on_decls Σ (merge_global_envs Σ Σ'). + Proof. + rewrite /extends_strictly_on_decls/merge_global_envs/merge_globals; cbn. + split; + try first [ apply ContextSet.union_spec + | apply Retroknowledge.extends_l_merge + | apply strictly_extends_decls_l_merge_globals ]. + Qed. + + Lemma extends_l_merge Σ Σ' + : extends Σ (merge_global_envs Σ Σ'). + Proof. exact _. Qed. + Lemma declared_kername_set_spec : forall Σ c, KernameSet.In c (declared_kername_set Σ) <-> List.In c (map fst Σ). Proof. @@ -768,8 +799,7 @@ Module Environment (T : Term). Lemma extends_r_merge_globals Σ Σ' : compatible_globals Σ Σ' -> - forall c, - ∑ decls, lookup_globals (merge_globals Σ Σ') c = decls ++ lookup_globals Σ' c. + extends_decls_part_globals Σ' (merge_globals Σ Σ'). Proof. rewrite /merge_globals. intro H2; cbn. From 63074670193f3bf655f6d82c176c68a77518ef08 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Sun, 23 Apr 2023 23:33:39 -0700 Subject: [PATCH 06/65] Fix issue with hint breaking a proof --- common/theories/Environment.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/common/theories/Environment.v b/common/theories/Environment.v index 15d94d79b..aaa015c1b 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -767,7 +767,7 @@ Module Environment (T : Term). eexists; reflexivity. Qed. - #[export] Instance extends_strictly_on_decls_l_merge Σ Σ' + Lemma extends_strictly_on_decls_l_merge Σ Σ' : extends_strictly_on_decls Σ (merge_global_envs Σ Σ'). Proof. rewrite /extends_strictly_on_decls/merge_global_envs/merge_globals; cbn. @@ -776,6 +776,7 @@ Module Environment (T : Term). | apply Retroknowledge.extends_l_merge | apply strictly_extends_decls_l_merge_globals ]. Qed. + #[export] Hint Extern 0 (extends_strictly_on_decls _ (merge_global_envs ?Σ ?Σ')) => simple apply (@extends_strictly_on_decls_l_merge Σ Σ') : typeclass_instances. Lemma extends_l_merge Σ Σ' : extends Σ (merge_global_envs Σ Σ'). From 6c63eacb5ccd00defbdb24b82382325e50730f4b Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 3 May 2023 06:06:38 -0700 Subject: [PATCH 07/65] Add union and inter checker flags (#957) This will allow programatically combining checker flags from multiple constants in Gallina quotation. --- common/theories/config.v | 72 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 72 insertions(+) diff --git a/common/theories/config.v b/common/theories/config.v index edfc01c93..eb89636e3 100644 --- a/common/theories/config.v +++ b/common/theories/config.v @@ -71,3 +71,75 @@ Qed. impl_refl impl_crefl impl_trans impl_ctrans | 100. + +Definition laxest_checker_flags : checker_flags := {| + check_univs := false ; + prop_sub_type := true; + indices_matter := false; + lets_in_constructor_types := true +|}. + +Definition strictest_checker_flags : checker_flags := {| + check_univs := true ; + prop_sub_type := false; + indices_matter := true; + lets_in_constructor_types := false +|}. + +Lemma laxest_checker_flags_laxest : forall cf, impl cf laxest_checker_flags. +Proof. + intro cf; cbv; destruct cf. + repeat match goal with + | [ |- context[match ?x with _ => _ end] ] => case_eq x + end; try reflexivity; congruence. +Qed. + +Lemma strictest_checker_flags_strictest : forall cf, impl strictest_checker_flags cf. +Proof. + intro cf; cbv; destruct cf. + repeat match goal with + | [ |- context[match ?x with _ => _ end] ] => case_eq x + end; try reflexivity; congruence. +Qed. + +(** can check everything that either one can check *) +Definition union_checker_flags (cf1 cf2 : checker_flags) : checker_flags + := {| check_univs := andb cf2.(@check_univs) cf1.(@check_univs) + ; prop_sub_type := orb cf1.(@prop_sub_type) cf2.(@prop_sub_type) + ; indices_matter := andb cf2.(@indices_matter) cf1.(@indices_matter) + ; lets_in_constructor_types := orb cf1.(@lets_in_constructor_types) cf2.(@lets_in_constructor_types) |}. + +(** can check everything that both can check *) +Definition inter_checker_flags (cf1 cf2 : checker_flags) : checker_flags + := {| check_univs := orb cf2.(@check_univs) cf1.(@check_univs) + ; prop_sub_type := andb cf1.(@prop_sub_type) cf2.(@prop_sub_type) + ; indices_matter := orb cf2.(@indices_matter) cf1.(@indices_matter) + ; lets_in_constructor_types := andb cf1.(@lets_in_constructor_types) cf2.(@lets_in_constructor_types) |}. + +Lemma union_checker_flags_spec cf1 cf2 (cf' := union_checker_flags cf1 cf2) + : impl cf1 cf' /\ impl cf2 cf' /\ (forall cf'', impl cf1 cf'' -> impl cf2 cf'' -> impl cf' cf''). +Proof. + destruct cf1, cf2; subst cf'. + cbv. + repeat split. + 3: intro cf''; destruct cf''. + all: repeat first [ match goal with + | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x + end + | reflexivity + | congruence ]. +Qed. + +Lemma inter_checker_flags_spec cf1 cf2 (cf' := inter_checker_flags cf1 cf2) + : impl cf' cf1 /\ impl cf' cf2 /\ (forall cf'', impl cf'' cf1 -> impl cf'' cf2 -> impl cf'' cf'). +Proof. + destruct cf1, cf2; subst cf'. + cbv. + repeat split. + 3: intro cf''; destruct cf''. + all: repeat first [ match goal with + | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x + end + | reflexivity + | congruence ]. +Qed. From 198e2023bec459b1ebae5e3c6d38f4fdc8cd819d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 5 May 2023 08:26:45 +0200 Subject: [PATCH 08/65] Fix sprop_level/prop_level requring lazy evaluation --- template-coq/src/constr_quoter.ml | 32 +++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index f796d4df4..8d2240daa 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -134,7 +134,7 @@ struct match Constr.kind ty with | Constr.Ind (ind, u) -> ind | _ -> failwith "byte_ind : tByte is not bound to an inductive type") - + let quote_char i = Constr.mkConstruct (Lazy.force byte_ind, (i+1)) @@ -168,7 +168,7 @@ struct match r with | Sorts.Relevant -> Lazy.force tRelevant | Sorts.Irrelevant -> Lazy.force tIrrelevant - + let quote_name n = match n with Names.Name id -> constr_mkApp (nNamed, [| quote_ident id |]) @@ -287,7 +287,7 @@ struct | Some var -> let var' = quote_cuminfo_variance var in constr_mkApp (cSome, [| listvar; var' |]) *) - + let quote_abstract_univ_context uctx = let arr = (AbstractContext.names uctx) in let idents = to_coq_listl tname (CArray.map_to_list quote_name arr) in @@ -299,10 +299,10 @@ struct let mkPolymorphic_ctx t = constr_mkApp (cPolymorphic_ctx, [|t|]) - let mkMonomorphic_entry ctx = + let mkMonomorphic_entry ctx = constr_mkApp (cMonomorphic_entry, [| ctx |]) - - let mkPolymorphic_entry ctx = + + let mkPolymorphic_entry ctx = constr_mkApp (cPolymorphic_entry, [| ctx |]) let quote_inductive_universes uctx = @@ -323,14 +323,14 @@ struct let sprop_level = - constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelSProp |]) + lazy (constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelSProp |])) let prop_level = - constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelProp |]) + lazy (constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelProp |])) let quote_sort s = match s with | Sorts.Set -> quote_universe Universe.type0 - | Sorts.Prop -> constr_mkApp (tof_levels, [| prop_level |]) - | Sorts.SProp -> constr_mkApp (tof_levels, [| sprop_level |]) + | Sorts.Prop -> constr_mkApp (tof_levels, [| Lazy.force prop_level |]) + | Sorts.SProp -> constr_mkApp (tof_levels, [| Lazy.force sprop_level |]) | Sorts.Type u -> quote_universe u let quote_sort_family = function @@ -344,14 +344,14 @@ struct let quote_context ctx = to_coq_list (constr_mkAppl (tcontext_decl, [| tTerm |])) ctx - + let mk_ctor_list ls = - let ctors = List.map (fun (a,b,c,d,e) -> + let ctors = List.map (fun (a,b,c,d,e) -> constr_mkApp (tBuild_constructor_body, [| a ; b ; to_coq_listl tTerm c ; d ; e |])) ls in to_coq_listl tconstructor_body ctors let mk_proj_list ps = - let projs = List.map (fun (a,b,c) -> + let projs = List.map (fun (a,b,c) -> constr_mkApp (tBuild_projection_body, [| a ; b ; c |])) ps in to_coq_listl tprojection_body projs @@ -408,11 +408,11 @@ struct let pair = pairl tkername tglobal_decl kn d in constr_mkApp (c_cons, [| global_pairty (); pair; l|]) - type pre_quoted_retroknowledge = + type pre_quoted_retroknowledge = { retro_int63 : quoted_kernel_name option; retro_float64 : quoted_kernel_name option } - let quote_retroknowledge r = + let quote_retroknowledge r = let rint63 = to_coq_option (Lazy.force tkername) (fun x -> x) r.retro_int63 in let rfloat64 = to_coq_option (Lazy.force tkername) (fun x -> x) r.retro_float64 in constr_mkApp (tmk_retroknowledge, [| rint63; rfloat64 |]) @@ -432,7 +432,7 @@ struct let consnames = to_coq_listl tident consnames in let constypes = to_coq_listl tTerm constypes in constr_mkApp (tBuild_one_inductive_entry, [| iname; arity; consnames; constypes |]) - + let quote_mutual_inductive_entry (mf, mp, is, mpol, var) = let is = to_coq_listl tOne_inductive_entry (List.map make_one_inductive_entry is) in let mpr = constr_mkAppl (cNone, [|bool_type|]) in From c7b8d8fd90a8a612493f45cea7cc15c46d08e993 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 5 May 2023 08:29:08 +0200 Subject: [PATCH 09/65] Fix use of lazy for (s)prop_level --- template-coq/src/constr_quoter.ml | 32 +++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index f796d4df4..8d2240daa 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -134,7 +134,7 @@ struct match Constr.kind ty with | Constr.Ind (ind, u) -> ind | _ -> failwith "byte_ind : tByte is not bound to an inductive type") - + let quote_char i = Constr.mkConstruct (Lazy.force byte_ind, (i+1)) @@ -168,7 +168,7 @@ struct match r with | Sorts.Relevant -> Lazy.force tRelevant | Sorts.Irrelevant -> Lazy.force tIrrelevant - + let quote_name n = match n with Names.Name id -> constr_mkApp (nNamed, [| quote_ident id |]) @@ -287,7 +287,7 @@ struct | Some var -> let var' = quote_cuminfo_variance var in constr_mkApp (cSome, [| listvar; var' |]) *) - + let quote_abstract_univ_context uctx = let arr = (AbstractContext.names uctx) in let idents = to_coq_listl tname (CArray.map_to_list quote_name arr) in @@ -299,10 +299,10 @@ struct let mkPolymorphic_ctx t = constr_mkApp (cPolymorphic_ctx, [|t|]) - let mkMonomorphic_entry ctx = + let mkMonomorphic_entry ctx = constr_mkApp (cMonomorphic_entry, [| ctx |]) - - let mkPolymorphic_entry ctx = + + let mkPolymorphic_entry ctx = constr_mkApp (cPolymorphic_entry, [| ctx |]) let quote_inductive_universes uctx = @@ -323,14 +323,14 @@ struct let sprop_level = - constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelSProp |]) + lazy (constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelSProp |])) let prop_level = - constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelProp |]) + lazy (constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelProp |])) let quote_sort s = match s with | Sorts.Set -> quote_universe Universe.type0 - | Sorts.Prop -> constr_mkApp (tof_levels, [| prop_level |]) - | Sorts.SProp -> constr_mkApp (tof_levels, [| sprop_level |]) + | Sorts.Prop -> constr_mkApp (tof_levels, [| Lazy.force prop_level |]) + | Sorts.SProp -> constr_mkApp (tof_levels, [| Lazy.force sprop_level |]) | Sorts.Type u -> quote_universe u let quote_sort_family = function @@ -344,14 +344,14 @@ struct let quote_context ctx = to_coq_list (constr_mkAppl (tcontext_decl, [| tTerm |])) ctx - + let mk_ctor_list ls = - let ctors = List.map (fun (a,b,c,d,e) -> + let ctors = List.map (fun (a,b,c,d,e) -> constr_mkApp (tBuild_constructor_body, [| a ; b ; to_coq_listl tTerm c ; d ; e |])) ls in to_coq_listl tconstructor_body ctors let mk_proj_list ps = - let projs = List.map (fun (a,b,c) -> + let projs = List.map (fun (a,b,c) -> constr_mkApp (tBuild_projection_body, [| a ; b ; c |])) ps in to_coq_listl tprojection_body projs @@ -408,11 +408,11 @@ struct let pair = pairl tkername tglobal_decl kn d in constr_mkApp (c_cons, [| global_pairty (); pair; l|]) - type pre_quoted_retroknowledge = + type pre_quoted_retroknowledge = { retro_int63 : quoted_kernel_name option; retro_float64 : quoted_kernel_name option } - let quote_retroknowledge r = + let quote_retroknowledge r = let rint63 = to_coq_option (Lazy.force tkername) (fun x -> x) r.retro_int63 in let rfloat64 = to_coq_option (Lazy.force tkername) (fun x -> x) r.retro_float64 in constr_mkApp (tmk_retroknowledge, [| rint63; rfloat64 |]) @@ -432,7 +432,7 @@ struct let consnames = to_coq_listl tident consnames in let constypes = to_coq_listl tTerm constypes in constr_mkApp (tBuild_one_inductive_entry, [| iname; arity; consnames; constypes |]) - + let quote_mutual_inductive_entry (mf, mp, is, mpol, var) = let is = to_coq_listl tOne_inductive_entry (List.map make_one_inductive_entry is) in let mpr = constr_mkAppl (cNone, [|bool_type|]) in From f91a1e7798cd6d2b62a22d6416ae82d8ca8ab2fd Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Fri, 5 May 2023 12:36:39 +0200 Subject: [PATCH 10/65] close some computational obligations with defined in erase_global_decls --- erasure/theories/ErasureFunction.v | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index fba458ddf..421898b47 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -924,7 +924,7 @@ Qed. Next Obligation. cbv [id]. unshelve eapply (normalization_in 0); cbn; try reflexivity; try lia. -Qed. +Defined. Next Obligation. pose proof (abstract_env_ext_wf _ H) as [wf]. pose proof (abstract_env_exists (abstract_pop_decls X)) as [[? HX']]. @@ -941,7 +941,7 @@ Next Obligation. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). @@ -950,7 +950,7 @@ Next Obligation. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). @@ -959,7 +959,7 @@ now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). @@ -968,7 +968,7 @@ Next Obligation. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). @@ -2719,7 +2719,7 @@ Qed. Next Obligation. cbv [id]. unshelve eapply (normalization_in 0); cbn; try reflexivity; try lia. -Qed. +Defined. Next Obligation. pose proof (abstract_env_ext_wf _ H) as [?]. pose proof (abstract_env_exists X) as [[? wf]]. @@ -2732,28 +2732,28 @@ Next Obligation. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. specialize_Σ H. sq; red. destruct prop as [Σ' ->]. eexists (Σ' ++ [(kn, ConstantDecl cb)]); rewrite -app_assoc //. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. specialize_Σ H. sq; red. destruct prop as [Σ' ->]. eexists (Σ' ++ [(kn, ConstantDecl cb)]); rewrite -app_assoc //. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. specialize_Σ H. sq; red. destruct prop as [Σ' ->]. eexists (Σ' ++ [(kn, _)]); rewrite -app_assoc //. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Qed. +Defined. Next Obligation. specialize_Σ H. sq; red. destruct prop as [Σ' ->]. eexists (Σ' ++ [(kn, _)]); rewrite -app_assoc //. From e04bc87cf93427acd8d76c937cc0efb0e2c23a3b Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Fri, 5 May 2023 12:42:39 -0700 Subject: [PATCH 11/65] Add MCListable class for enumerating finite types This will be useful for proving that quotation of byte is well-typed with the safechecker. --- utils/_CoqProject | 1 + utils/theories/MCListable.v | 169 ++++++++++++++++++++++++++++++++++++ 2 files changed, 170 insertions(+) create mode 100644 utils/theories/MCListable.v diff --git a/utils/_CoqProject b/utils/_CoqProject index 6ab957809..9f0b08c4e 100644 --- a/utils/_CoqProject +++ b/utils/_CoqProject @@ -17,6 +17,7 @@ theories/MCEquality.v theories/MCFSets.v theories/LibHypsNaming.v theories/MCList.v +theories/MCListable.v theories/MCMSets.v theories/MCOption.v theories/MCProd.v diff --git a/utils/theories/MCListable.v b/utils/theories/MCListable.v new file mode 100644 index 000000000..dee720445 --- /dev/null +++ b/utils/theories/MCListable.v @@ -0,0 +1,169 @@ +From Coq Require Import Lia Arith Bool List Program. +From MetaCoq.Utils Require Import MCPrelude ReflectEq. +From Coq.ssr Require Import ssreflect. +From Equations Require Import Equations. +Import ListNotations. + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. + +Class Listable T := { list_all : list T ; find_index : T -> nat ; cardinality := length list_all }. + +Arguments find_index {T} {_} _. +Arguments list_all T {_}. +Arguments cardinality T {_}. + +Class FinitelyListable T {l : Listable T} + := { find_index_ok : forall t, nth_error (list_all T) (find_index t) = Some t + ; enumerate_smallb : forallb (fun '(n, t) => n == find_index t) + (combine (seq 0 (cardinality T)) (list_all T)) }. + +Class FinitelyListablePackage T + := { FinitelyListablePackage_Listable : Listable T + ; FinitelyListablePackage_FinitelyListable : FinitelyListable T }. +#[export] Existing Instances FinitelyListablePackage_Listable FinitelyListablePackage_FinitelyListable. +#[global] Coercion FinitelyListablePackage_Listable : FinitelyListablePackage >-> Listable. +#[global] Coercion FinitelyListablePackage_FinitelyListable : FinitelyListablePackage >-> FinitelyListable. + +Ltac prove_FinitelyListable := + split; + [ let t := fresh in + intro t; destruct t; + vm_compute; try reflexivity + | vm_compute; reflexivity ]. + +Ltac push_S_refine_num ev := + lazymatch ev with + | S ?ev + => refine (S _); push_S_refine_num ev + | ?ev => let __ := open_constr:(eq_refl : ev = S _) in + refine O + end. + +Ltac force_num ev := + lazymatch ev with + | S ?ev => force_num ev + | ?ev => unify ev O + end. + +Ltac partially_prove_Listable := + let fin := open_constr:(_) in + unshelve esplit; + [ + | repeat (let t := fresh in intro t; case t; clear t); + push_S_refine_num fin ]; + force_num fin. + +Ltac finish_prove_FinitelyListable := + split; + [ cbv [list_all find_index]; + repeat (let t := fresh in intro t; case t; clear t); + unshelve + (repeat match goal with + | [ |- nth_error (?x :: _) O = ?rhs ] => change (Some x = rhs) + | [ |- nth_error (_ :: ?xs) (S ?n) = ?rhs ] => change (nth_error xs n = rhs) + | [ |- nth_error ?ev _ = ?rhs ] + => is_evar ev; + let __ := open_constr:(eq_refl : ev = cons _ _) in + idtac + | [ |- Some _ = Some _ ] => reflexivity + end); + try exact nil + | try instantiate (1:=nil) (* for empty types *); + vm_compute; reflexivity ]. + +Ltac prove_ListableDerive := + lazymatch goal with + | [ |- @FinitelyListable ?T ?H ] + => instantiate (1:=ltac:(partially_prove_Listable)) in (value of H); + cbv [H]; + finish_prove_FinitelyListable + end. + +Ltac prove_ListablePackage T := + refine (_ : { l : Listable T | FinitelyListable T }); + unshelve econstructor; + [ partially_prove_Listable + | finish_prove_FinitelyListable ]. + +Ltac prove_FinitelyListablePackage_goal _ := + unshelve econstructor; + [ partially_prove_Listable + | finish_prove_FinitelyListable ]. +Ltac prove_FinitelyListablePackage T := + refine (_ : FinitelyListablePackage T); + prove_FinitelyListablePackage_goal (). + +Ltac get_ListablePackage T := + constr:(ltac:(prove_ListablePackage T)). + +Section with_listable. + Context {T} + {Listable_T : Listable T} + {FinitelyListable_T : FinitelyListable T}. + + Lemma find_index_iff x n : find_index x = n <-> List.nth_error (list_all T) n = Some x. + Proof using FinitelyListable_T. + split; [ intro; subst; apply find_index_ok | ]. + generalize enumerate_smallb. + cbv [cardinality]. + set (offset := O). + change n with (offset + n)%nat at 2. + clearbody offset. + rename x into v. + intros Hfold Hnth; revert offset n Hfold Hnth. + induction (list_all T) as [|x xs IHxs]; intros. + { destruct n; cbn in *; congruence. } + { cbn in *. + move: Hfold; case: eqb_specT => //= Hfold1 Hfold2. + specialize (IHxs (S offset) (pred n) Hfold2). + subst offset; destruct n as [|n]; cbn in *. + { inversion Hnth; subst; lia. } + { specialize (IHxs Hnth); lia. } } + Qed. + + Lemma enumerate_unique n m x y + (Hn : List.nth_error (list_all T) n = Some x) + (Hm : List.nth_error (list_all T) m = Some y) + (Hxy : x = y) + : n = m. + Proof using FinitelyListable_T. rewrite <- !find_index_iff in *; subst; reflexivity. Qed. + + Lemma find_index_inj x y : find_index x = find_index y -> x = y. + Proof using FinitelyListable_T. rewrite find_index_iff find_index_ok; congruence. Qed. + + Definition eqb_of_listable : T -> T -> bool := fun x y => Nat.eqb (find_index x) (find_index y). + Lemma eqb_of_listable_refl x : eqb_of_listable x x = true. + Proof using Type. cbv [eqb_of_listable]. apply Nat.eqb_refl. Qed. + Lemma eqb_of_listable_lb x y : x = y -> eqb_of_listable x y = true. + Proof using Type. intros; subst; apply eqb_of_listable_refl. Qed. + Lemma eqb_of_listable_bl x y : eqb_of_listable x y = true -> x = y. + Proof using FinitelyListable_T. cbv [eqb_of_listable]; rewrite Nat.eqb_eq. apply find_index_inj. Qed. + Lemma eqb_of_listable_eq x y : eqb_of_listable x y = true <-> x = y. + Proof using FinitelyListable_T. split; auto using eqb_of_listable_lb, eqb_of_listable_bl. Qed. + Lemma eqb_of_listable_spec x y : reflectProp (x = y) (eqb_of_listable x y). + Proof using FinitelyListable_T. generalize (eqb_of_listable_eq x y); case: eqb_of_listable; case; constructor; auto. Qed. + + #[local] Instance ReflectEq_of_listable : ReflectEq T + := { eqb := eqb_of_listable + ; eqb_spec := eqb_of_listable_spec }. +End with_listable. + +#[export] Existing Instance ReflectEq_of_listable. + +Local Obligation Tactic := try prove_FinitelyListablePackage_goal (). +#[export,program] Instance unit_FinitelyListablePackage : FinitelyListablePackage unit := _. +#[export,program] Instance Empty_set_FinitelyListablePackage : FinitelyListablePackage Empty_set := _. +#[export,program] Instance True_FinitelyListablePackage : FinitelyListablePackage True := _. +#[export,program] Instance False_FinitelyListablePackage : FinitelyListablePackage False := _. +#[export,program] Instance bool_FinitelyListablePackage : FinitelyListablePackage bool := _. +#[export] Instance byte_FinitelyListablePackage : FinitelyListablePackage Byte.byte. +Proof. + unshelve econstructor. + { unshelve esplit; [ | exact Byte.to_nat ]. + { let ls := (eval cbv in (List.flat_map (fun v => match Byte.of_nat v with Some v => [v] | None => [] end) (seq 0 256))) in + exact ls. } } + { split. + { intro x; destruct x; vm_compute; reflexivity. } + { vm_compute; reflexivity. } } +Defined. From e578a027c9cc9da2b9e84bd331dea5609e7b1be0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 9 May 2023 09:13:47 +0200 Subject: [PATCH 12/65] Move nix actions away --- ...ix-action-coq-8.16-macos.yml => nix-action-coq-8.17-macos.yml} | 0 ...-action-coq-8.16-ubuntu.yml => nix-action-coq-8.17-ubuntu.yml} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename .github/{workflows/nix-action-coq-8.16-macos.yml => nix-action-coq-8.17-macos.yml} (100%) rename .github/{workflows/nix-action-coq-8.16-ubuntu.yml => nix-action-coq-8.17-ubuntu.yml} (100%) diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/nix-action-coq-8.17-macos.yml similarity index 100% rename from .github/workflows/nix-action-coq-8.16-macos.yml rename to .github/nix-action-coq-8.17-macos.yml diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/nix-action-coq-8.17-ubuntu.yml similarity index 100% rename from .github/workflows/nix-action-coq-8.16-ubuntu.yml rename to .github/nix-action-coq-8.17-ubuntu.yml From 14ad024c41da54c73dc95588f99e0a84a66b71f0 Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Fri, 2 Jun 2023 14:09:49 +0200 Subject: [PATCH 13/65] Invariants in named recursion rule (#967) --- erasure/theories/EWcbvEvalNamed.v | 238 +++++++++++++++--------------- 1 file changed, 119 insertions(+), 119 deletions(-) diff --git a/erasure/theories/EWcbvEvalNamed.v b/erasure/theories/EWcbvEvalNamed.v index 6bdbeae78..08e77b7d4 100644 --- a/erasure/theories/EWcbvEvalNamed.v +++ b/erasure/theories/EWcbvEvalNamed.v @@ -1,7 +1,6 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Utf8 Program. -From MetaCoq.Utils Require Import utils. -From MetaCoq.Common Require Import config BasicAst. +From MetaCoq Require Import config utils BasicAst. From MetaCoq.PCUIC Require PCUICWcbvEval. From MetaCoq.Erasure Require Import EAst EAstUtils ELiftSubst ECSubst EReflect EGlobalEnv EWellformed EWcbvEval. @@ -37,7 +36,7 @@ Inductive value : Set := Definition environment := list (ident * value). Definition add : ident -> value -> environment -> environment := fun (x : ident) (v : value) env => (x, v) :: env. -Fixpoint add_multiple (xs : list ident) (vs : list value) (env : environment) : environment := +Fixpoint add_multiple (xs : list ident) (vs : list value) (env : environment) {struct vs} : environment := match xs, vs with | x :: xs, v :: vs => add x v (add_multiple xs vs env) | _, _ => env @@ -114,10 +113,12 @@ Section Wcbv. (** Fix unfolding, without guard *) | eval_fix_unfold f mfix idx a na na' av fn res Γ' : + forallb (λ x, isLambda (snd x)) mfix -> + ~ In na (map fst mfix) -> eval Γ f (vRecClos mfix idx Γ') -> NoDup (map fst mfix) -> nth_error mfix idx = Some (na', tLambda (nNamed na) fn) -> - eval (add na av (add_multiple (map fst mfix) (fix_env mfix Γ') Γ')) fn res -> + eval (add na av (add_multiple (List.rev (map fst mfix)) (fix_env mfix Γ') (Γ'))) fn res -> eval Γ a av -> eval Γ (tApp f a) res @@ -137,7 +138,7 @@ Section Wcbv. (** Constructor congruence: we do not allow over-applications *) | eval_construct_block ind c mdecl idecl cdecl args args' : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - #|args| <= cstr_arity mdecl cdecl -> + #|args| <= cstr_nargs cdecl -> All2_Set (eval Γ) args args' -> eval Γ (tConstruct ind c args) (vConstruct ind c args') @@ -186,6 +187,8 @@ Section Wcbv. (res : value) (Γ' : list (ident × value)) + (Hbodies : forallb (λ x, isLambda (snd x)) mfix) + (Hfresh : ~ In na (map fst mfix)) (e : eval Γ f5 (vRecClos mfix idx Γ')), @@ -199,16 +202,14 @@ Section Wcbv. (na', tLambda (nNamed na) fn)) (e1 : eval - (add na av - (add_multiple - (map fst mfix) - (fix_env mfix Γ') Γ')) fn + (add na av (add_multiple + (List.rev (map fst mfix)) + (fix_env mfix Γ') (Γ'))) fn res), P - (add na av - (add_multiple - (map fst mfix) - (fix_env mfix Γ') Γ')) fn + (add na av (add_multiple + (List.rev (map fst mfix)) + (fix_env mfix Γ') (Γ'))) fn res e1 → forall e2 : eval Γ a av, @@ -216,7 +217,7 @@ Section Wcbv. P Γ (tApp f5 a) res (eval_fix_unfold Γ f5 mfix - idx a na na' av fn res Γ' e + idx a na na' av fn res Γ' Hbodies Hfresh e n e0 e1 e2)) (f6 : ∀ (Γ : environment) (mfix : list (def term)) (idx : nat) (nms : list ident) (Hlen : (idx < #|mfix|)) (Hbodies : List.forallb (isLambda ∘ dbody) mfix) (n : NoDup nms) (f6 : Forall2 (λ (d : def term) (n0 : ident), nNamed n0 = dname d) mfix nms), @@ -240,7 +241,7 @@ Section Wcbv. (eval_delta Γ c decl body isdecl res e e0)) (f8 : ∀ (Γ : environment) (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) - (args : list term) (args' : list value) (e : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl)) (l : #|args| ≤ cstr_arity mdecl cdecl) + (args : list term) (args' : list value) (e : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl)) (l : #|args| ≤ cstr_nargs cdecl) (a : All2_Set (eval Γ) args args') (IHa : All2_over a (P Γ)), P Γ (tConstruct ind c args) (vConstruct ind c args') (eval_construct_block Γ ind c mdecl idecl cdecl args args' e l a)) (f9 : ∀ (Γ : environment) (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) (e : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl)), @@ -254,8 +255,8 @@ Section Wcbv. | @eval_zeta _ na b0 b0' b1 res e0 e1 => f3 Γ na b0 b0' b1 res e0 (F Γ b0 b0' e0) e1 (F (add na b0' Γ) b1 res e1) | @eval_iota_block _ ind cdecl discr c args brs br res nms e0 e1 e2 e3 e4 f10 e5 n => f4 Γ ind cdecl discr c args brs br res nms e0 (F Γ discr (vConstruct ind c args) e0) e1 e2 e3 e4 f10 e5 (F (add_multiple (List.rev nms) args Γ) br.2 res e5) n - | @eval_fix_unfold _ f10 mfix idx a na na' av fn res Γ' e0 n e1 e2 e3 => - f5 Γ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + | @eval_fix_unfold _ f10 mfix idx a na na' av fn res Γ' Hbodies Hfresh e0 n e1 e2 e3 => + f5 Γ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ | @eval_fix _ mfix idx nms Hlen Hbodies n f10 => f6 Γ mfix idx nms Hlen Hbodies n f10 | @eval_delta _ c decl body isdecl res e0 e1 => f7 Γ c decl body isdecl res e0 e1 (F [] body res e1) | @eval_construct_block _ ind c mdecl idecl cdecl args args' e0 l a => f8 Γ ind c mdecl idecl cdecl args args' e0 l a _ @@ -290,14 +291,14 @@ Inductive represents : list ident -> environment -> term -> term -> Set := List.forallb (isLambda ∘ dbody) mfix -> NoDup nms -> All2_Set (fun d n => d.(dname) = nNamed n) mfix nms -> - All2_Set (fun d d' => (nms ++ Γ) ;;; E ⊩ d.(dbody) ~ d'.(dbody)) mfix mfix' -> + All2_Set (fun d d' => (List.rev nms ++ Γ) ;;; E ⊩ d.(dbody) ~ d'.(dbody)) mfix mfix' -> Γ ;;; E ⊩ tFix mfix idx ~ tFix mfix' idx with represents_value : value -> term -> Set := | represents_value_tBox : represents_value vBox tBox | represents_value_tClos na E s t na' : [na] ;;; E ⊩ s ~ t -> represents_value (vClos na s E) (tLambda na' t) | represents_value_tConstruct vs ts ind c : All2_Set represents_value vs ts -> represents_value (vConstruct ind c vs) (tConstruct ind c ts) | represents_value_tFix vfix i E mfix : - All2_Set (fun v d => isLambda (snd v) × (map fst vfix ;;; E ⊩ snd v ~ d.(dbody))) vfix mfix -> represents_value (vRecClos vfix i E) (tFix mfix i) + All2_Set (fun v d => isLambda (snd v) × (List.rev (map fst vfix) ;;; E ⊩ snd v ~ d.(dbody))) vfix mfix -> represents_value (vRecClos vfix i E) (tFix mfix i) where "Γ ;;; E ⊩ s ~ t" := (represents Γ E s t). Program Definition represents_ind := @@ -362,9 +363,9 @@ Program Definition represents_ind := (λ (d : def term) (n : ident), dname d = nNamed n) mfix nms) (a0 : All2_Set - (λ d d' : def term, (nms ++ Γ);;; E ⊩ dbody d ~ dbody d') + (λ d d' : def term, (List.rev nms ++ Γ);;; E ⊩ dbody d ~ dbody d') mfix mfix') - (IH : All2_over a0 (fun t t' : def term => P (nms ++ Γ) E (dbody t) (dbody t'))), + (IH : All2_over a0 (fun t t' : def term => P (List.rev nms ++ Γ) E (dbody t) (dbody t'))), P Γ E (tFix mfix idx) (tFix mfix' idx) (represents_tFix Γ E mfix mfix' idx nms Hbodies Hnodup a a0)) (f9 : P0 vBox tBox represents_value_tBox) (f10 : @@ -386,8 +387,8 @@ Program Definition represents_ind := (represents_value_tConstruct vs ts ind c a)) (f12 : ∀ (vfix : list (ident × term)) (i : nat) (E : list (ident × value)) (mfix : list (def term)) - (a : All2_Set (λ (v : ident × term) (d : def term), isLambda v.2 × map fst vfix ;;; E ⊩ v.2 ~ dbody d) vfix mfix) - (IH : All2_over a (fun v d H => P (map fst vfix) E v.2 (dbody d) (snd H) ) ), + (a : All2_Set (λ (v : ident × term) (d : def term), isLambda v.2 × List.rev (map fst vfix) ;;; E ⊩ v.2 ~ dbody d) vfix mfix) + (IH : All2_over a (fun v d H => P (List.rev (map fst vfix)) E v.2 (dbody d) (snd H) ) ), P0 (vRecClos vfix i E) (tFix mfix i) (represents_value_tFix vfix i E mfix a)), fix F @@ -506,9 +507,9 @@ Program Definition represents_value_ind := (λ (d : def term) (n : ident), dname d = nNamed n) mfix nms) (a0 : All2_Set - (λ d d' : def term, (nms ++ Γ);;; E ⊩ dbody d ~ dbody d') + (λ d d' : def term, (List.rev nms ++ Γ);;; E ⊩ dbody d ~ dbody d') mfix mfix') - (IH : All2_over a0 (fun t t' : def term => P (nms ++ Γ) E (dbody t) (dbody t'))), + (IH : All2_over a0 (fun t t' : def term => P (List.rev nms ++ Γ) E (dbody t) (dbody t'))), P Γ E (tFix mfix idx) (tFix mfix' idx) (represents_tFix Γ E mfix mfix' idx nms Hbodies Hnodup a a0)) (f9 : P0 vBox tBox represents_value_tBox) (f10 : @@ -532,8 +533,8 @@ Program Definition represents_value_ind := (E : list (ident × value)) (mfix : list (def term)) (a : All2_Set (λ (v : ident × term) (d : def term), isLambda v.2 × - (map fst vfix) ;;; E ⊩ v.2 ~ d.(dbody)) vfix mfix) - (IH : All2_over a (fun v d H => P (map fst vfix) E v.2 (dbody d) (snd H) ) ), + (List.rev (map fst vfix)) ;;; E ⊩ v.2 ~ d.(dbody)) vfix mfix) + (IH : All2_over a (fun v d H => P (List.rev (map fst vfix)) E v.2 (dbody d) (snd H) ) ), P0 (vRecClos vfix i E) (tFix mfix i) (represents_value_tFix vfix i E mfix a)), fix F @@ -652,9 +653,9 @@ Definition rep_ind := (λ (d : def term) (n : ident), dname d = nNamed n) mfix nms) (a0 : All2_Set - (λ d d' : def term, (nms ++ Γ);;; E ⊩ dbody d ~ dbody d') + (λ d d' : def term, (List.rev nms ++ Γ);;; E ⊩ dbody d ~ dbody d') mfix mfix') - (IH : All2_over a0 (fun t t' : def term => P (nms ++ Γ) E (dbody t) (dbody t'))), + (IH : All2_over a0 (fun t t' : def term => P (List.rev nms ++ Γ) E (dbody t) (dbody t'))), P Γ E (tFix mfix idx) (tFix mfix' idx) (represents_tFix Γ E mfix mfix' idx nms Hbodies Hnodup a a0)) (f9 : P0 vBox tBox represents_value_tBox) (f10 : @@ -678,10 +679,10 @@ Definition rep_ind := (E : list (ident × value)) (mfix : list (def term)) (a : All2_Set (λ (v : ident × term) (d : def term), isLambda v.2 × - (map fst vfix) ;;; + (List.rev (map fst vfix)) ;;; E ⊩ v.2 ~ dbody d) vfix mfix) - (IH : All2_over a (fun v d H => P (map fst vfix) E v.2 (dbody d) (snd H) ) ), + (IH : All2_over a (fun v d H => P (List.rev (map fst vfix)) E v.2 (dbody d) (snd H) ) ), P0 (vRecClos vfix i E) (tFix mfix i) (represents_value_tFix vfix i E mfix a)), (represents_ind P P0 f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12, @@ -691,7 +692,7 @@ Local Notation "'⊩' v ~ s" := (represents_value v s) (at level 50). Local Hint Constructors represents : core. Local Hint Constructors represents_value : core. -From MetaCoq.Utils Require Import bytestring MCString. +From MetaCoq Require Import bytestring MCString. Require Import BinaryString. Import String. @@ -875,7 +876,7 @@ Fixpoint annotate (s : list ident) (u : term) {struct u} : term := | tProj p c => tProj p (annotate s c) | tFix mfix idx => let nms := gen_many_fresh s (map dname mfix) in - let mfix' := map2 (fun d na => map_def_name _ (fun _ => nNamed na) (annotate (gen_many_fresh s (map dname mfix) ++ s)) d) mfix nms in + let mfix' := map2 (fun d na => map_def_name _ (fun _ => nNamed na) (annotate (List.rev (gen_many_fresh s ((map dname mfix))) ++ s)) d) mfix nms in tFix mfix' idx | _ => u end. @@ -951,7 +952,7 @@ Proof. * eapply p. rewrite app_length gen_many_fresh_length. eapply p. * eapply NoDup_gen_many_fresh. - eapply represents_tFix with (nms := gen_many_fresh Γ (map dname m)). - 1:{ solve_all. generalize (gen_many_fresh Γ (map dname m) ++ Γ). clear - H. + 1:{ solve_all. generalize (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ). clear - H. induction H in Γ; cbn. econstructor. intros. destruct x, dname; cbn. all: econstructor. - cbn in *. destruct p, dbody; cbn in *; try congruence. - eapply IHAll. @@ -959,21 +960,21 @@ Proof. - eapply IHAll. } 1:{ eapply NoDup_gen_many_fresh. } - { clear. generalize (((gen_many_fresh Γ (map dname m) ++ Γ))). - generalize Γ. induction m; cbn. + { clear. generalize ((List.rev (gen_many_fresh Γ ( (map dname m))) ++ Γ)). + induction m in Γ |- *; cbn. - econstructor. - - intros. destruct a; cbn. destruct dname; cbn; econstructor; eauto. + - intros. destruct a; cbn. destruct dname; cbn; try econstructor; eauto. } { solve_all. unfold wf_fix in *. rtoProp. solve_all. clear H0. unfold test_def in *. cbn in *. eapply All_impl in H1. 2:{ intros ? [[] ]. - specialize (r (gen_many_fresh Γ (map dname m) ++ Γ)). - revert r. rewrite app_length gen_many_fresh_length map_length. intros r. eapply r in i0. exact i0. + specialize (r (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). + revert r. rewrite ?List.rev_length app_length ?List.rev_length gen_many_fresh_length ?List.rev_length map_length. intros r. eapply r in i0. exact i0. } revert H1. - generalize (((gen_many_fresh Γ (map dname m) ++ Γ))). + generalize ((List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). intros. induction H1 in Γ |- *. - econstructor. - - cbn. destruct x; cbn. destruct dname; cbn; econstructor; eauto. + - cbn. destruct x; cbn. destruct dname; cbn; econstructor; eauto. } Qed. @@ -995,11 +996,11 @@ Proof. 2:{ eapply All2_length in a. clear IH. eapply All2_Set_All2, All2_length in a0. len. } clear Hbodies a. induction a0; cbn in *; econstructor. - rewrite app_length in IH. eapply IH. + rewrite app_length List.rev_length in IH. eapply IH. eapply IHa0. eapply IH. - solve_all. induction a; cbn in *; rtoProp; eauto. econstructor. cbn in *. eapply IH. eapply IHa. eapply IH. - - rewrite map_length in IH. + - rewrite List.rev_length map_length in IH. assert (Hlen : #|vfix| = #|mfix|). { clear IH. eapply All2_Set_All2, All2_length in a. lia. } rewrite Hlen in IH. revert IH. generalize (#|mfix|). induction a; intros n H; cbn in *; rtoProp; split. @@ -1085,9 +1086,9 @@ Proof. + inversion a0; subst. cbn. eauto. + cbn. depelim a0. cbn. invs IH. econstructor. * cbn. - specialize (H (nms ++ Γ1) Γ2). + specialize (H (List.rev nms ++ Γ1) Γ2). rewrite app_length in H. - rewrite <- !app_assoc in *. eapply H; eauto. + rewrite <- !app_assoc in *. rewrite List.rev_length in H. eapply H; eauto. * eapply IHmfix; eauto. Qed. @@ -1316,6 +1317,40 @@ Proof. - eapply IHn; eauto. Qed. +Lemma fresh_subset Γ1 Γ2 i : + fresh i Γ1 -> incl Γ2 Γ1 -> fresh i Γ2. +Proof. + unfold fresh. repeat destruct in_dec; eauto; cbn. + intros. firstorder. +Qed. + +Local Hint Resolve fresh_subset : core. + +Lemma sunny_subset Γ1 Γ2 t : + sunny Γ1 t -> incl Γ2 Γ1 -> sunny Γ2 t. +Proof. + intros H Hincl. + induction t using EInduction.term_forall_list_ind in Γ1, Γ2, H, Hincl |- * ; cbn in *; eauto. + - cbn in H. solve_all. + - destruct n; eauto. cbn in *. rtoProp. split. 1: eapply fresh_subset; eauto. + eapply IHt; eauto. intros ? []; cbn; eauto. + - destruct n; eauto. cbn in *. rtoProp. repeat split; eauto. + eapply IHt2; eauto. eapply incl_cons; cbn; eauto. + eapply incl_tl; eauto. + - rtoProp; split; eauto. + - solve_all. + - rtoProp; split; solve_all; rtoProp; eauto; repeat split; solve_all. + + destruct x0; eauto. + + eapply a0; eauto. + intros ? ?. rewrite -> in_app_iff in *. + destruct H3; eauto. + - rtoProp; repeat split; solve_all. destruct x; cbn in *. + { destruct dname; cbn in *; eauto. } + eapply a; eauto. + intros ? ?. rewrite -> in_app_iff in *. + destruct H; eauto. +Qed. + Lemma eval_wf Σ E s v : Forall (fun d => match d.2 with ConstantDecl (Build_constant_body (Some d)) => sunny [] d | _ => true end) Σ -> All (fun x => wf (snd x)) E -> @@ -1357,12 +1392,13 @@ Proof. eapply X0. + econstructor; cbn; eauto. eapply wf_add_multiple; eauto. - now rewrite map_length fix_env_length. + now rewrite List.rev_length map_length fix_env_length. eapply wf_fix_env; eauto. + let X2 := multimatch goal with H : All _ _ |- _ => H end in eapply All_nth_error in X2; eauto; cbn in X2; rtoProp; - rewrite map_fst_add_multiple; first [ now rewrite map_length fix_env_length - | eauto ]. + rewrite map_fst_add_multiple; first [ now rewrite List.rev_length map_length fix_env_length | eauto ]. + eapply sunny_subset. eauto. + intros ?. cbn. rewrite !in_app_iff. now rewrite <- in_rev. - assert (map fst (MCList.map2 (λ (n : ident) (d0 : def term), (n, EAst.dbody d0)) nms mfix) = nms) as EE. { clear - f6. induction f6; cbn; f_equal; eauto. } econstructor. @@ -1425,7 +1461,7 @@ Qed. Lemma eval_construct_All2 Σ E ind c args vs mdecl idecl cdecl : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - #|args| <= cstr_arity mdecl cdecl -> + #|args| <= cstr_nargs cdecl -> All2 (eval Σ E) args vs -> eval Σ E (tConstruct ind c args) (vConstruct ind c vs). Proof. intros Hind. @@ -1438,7 +1474,7 @@ Proof. + eapply All2_All2_Set, All2_app. eapply H1; eauto. econstructor; eauto. Qed. -From MetaCoq.Erasure Require Import EWcbvEvalCstrsAsBlocksFixLambdaInd. +From MetaCoq Require Import EWcbvEvalCstrsAsBlocksFixLambdaInd. Lemma lookup_in_env Σ Σ' ind i : All2 (fun d d' => d.1 = d'.1 × match d.2 with ConstantDecl (Build_constant_body (Some body)) => @@ -1478,40 +1514,6 @@ Proof. Qed. *) -Lemma fresh_subset Γ1 Γ2 i : - fresh i Γ1 -> incl Γ2 Γ1 -> fresh i Γ2. -Proof. - unfold fresh. repeat destruct in_dec; eauto; cbn. - intros. firstorder. -Qed. - -Local Hint Resolve fresh_subset : core. - -Lemma sunny_subset Γ1 Γ2 t : - sunny Γ1 t -> incl Γ2 Γ1 -> sunny Γ2 t. -Proof. - intros H Hincl. - induction t using EInduction.term_forall_list_ind in Γ1, Γ2, H, Hincl |- * ; cbn in *; eauto. - - cbn in H. solve_all. - - destruct n; eauto. cbn in *. rtoProp. split. 1: eapply fresh_subset; eauto. - eapply IHt; eauto. intros ? []; cbn; eauto. - - destruct n; eauto. cbn in *. rtoProp. repeat split; eauto. - eapply IHt2; eauto. eapply incl_cons; cbn; eauto. - eapply incl_tl; eauto. - - rtoProp; split; eauto. - - solve_all. - - rtoProp; split; solve_all; rtoProp; eauto; repeat split; solve_all. - + destruct x0; eauto. - + eapply a0; eauto. - intros ? ?. rewrite -> in_app_iff in *. - destruct H3; eauto. - - rtoProp; repeat split; solve_all. destruct x; cbn in *. - { destruct dname; cbn in *; eauto. } - eapply a; eauto. - intros ? ?. rewrite -> in_app_iff in *. - destruct H; eauto. -Qed. - Lemma represents_add_fresh nms Γ E vs s t : Γ ;;; E ⊩ s ~ t -> sunny nms s -> @@ -1590,8 +1592,7 @@ Proof. edestruct s1 as (? & ? & ?); eauto. invs Hv1. eexists; split; eauto. econstructor; eauto. - invs Hrep. - + let H3 := match goal with H : ⊩ _ ~ tApp _ _ |- _ => H end in - invs H3. + + invs H3. + cbn in Hsunny. rtoProp. edestruct s0 as (v1 & Hv1 & Hv2). 3: eauto. eauto. eauto. invs Hv1. @@ -1615,7 +1616,6 @@ Proof. - assert (pars = 0) as ->. { unfold constructor_isprop_pars_decl in *. destruct lookup_constructor as [[[[] [? ?]] ?] | ] eqn:EE; cbn in *; try congruence. - let H0 := match goal with H : Some _ = Some _ |- _ => H end in invs H0. destruct lookup_env eqn:EEE; try congruence. eapply lookup_env_wellformed in EEE; eauto. @@ -1634,8 +1634,7 @@ Proof. eapply All2_Set_All2 in H14. eapply All2_nth_error_Some_right in H14 as He2. 2: eauto. destruct He2 as (br' & Hnth & nms & Hbrs & Hbr & Hnodup). invs Hv1. edestruct s1 as (v2 & Hv1_ & Hv2_). - 1: { let H6 := match goal with H : is_true (forallb _ _) |- _ => H end in - eapply forallb_nth_error in H6; setoid_rewrite Hnth in H6; cbn in H6. rtoProp. + 1: { eapply forallb_nth_error in H6. setoid_rewrite Hnth in H6. cbn in H6. rtoProp. assert (nms = flat_map (λ x : name, match x with | nAnon => [] | nNamed na => [na] @@ -1644,9 +1643,6 @@ Proof. { rewrite Heqnms flat_map_concat_map. intros ? (? & ([] & <- & ?) % in_map_iff & Hd) % in_concat; cbn in *; eauto. destruct Hd; subst; eauto. - rename H6 into H6_old; - let H6' := match goal with H : is_true (forallb _ _) |- _ => H end in - rename H6' into H6. eapply forallb_forall in H6; eauto. cbn in H6. unfold fresh in H6. destruct in_dec; cbn in *; congruence. } { subst. unfold dupfree in H9. destruct dupfree_dec_ident; cbn in *; congruence. } @@ -1664,10 +1660,7 @@ Proof. eapply All2_Set_All2, All2_length in H10; eauto. eapply All2_Set_All2, All2_length in Hbrs; eauto. rewrite -> !skipn_length in *. lia. - -- rename H6 into H6_old; - let H6' := match goal with H : is_true (forallb _ _) |- _ => H end in - rename H6' into H6. - eapply forallb_nth_error in H6. setoid_rewrite Hnth in H6. cbn in H6. rtoProp. + -- eapply forallb_nth_error in H6. setoid_rewrite Hnth in H6. cbn in H6. rtoProp. enough (nms = flat_map (λ x : name, match x with | nAnon => [] | nNamed na => [na] @@ -1689,7 +1682,7 @@ Proof. rewrite -> !skipn_length in *. lia. * solve_all. * now rewrite rev_involutive in Hv2_. - - eauto. (* artifact of the induction being weird and having a trivial assumption to not mess up proof script. FIXME! *) + - eapply X; eauto. (* artifact of the induction being weird and having a trivial assumption to not mess up proof script. FIXME! *) - invs Hrep. + let H5 := match goal with H : ⊩ _ ~ tApp _ _ |- _ => H end in invs H5. @@ -1716,35 +1709,35 @@ Proof. edestruct s2 as (v'' & IH1'' & IH2''). - eapply represents_substl_rev with (vs := _ :: fix_env vfix E0) (nms := na0 :: map fst vfix); eauto. (* having represents_substl_rev with nms ++ Gamma created an order problem here. changing it there fixes the problem here. but is this correct? *) + eapply represents_substl_rev with (vs := _ :: fix_env vfix E0) (nms := na0 :: List.rev (map fst vfix)); eauto. (* having represents_substl_rev with nms ++ Gamma created an order problem here. changing it there fixes the problem here. but is this correct? *) 8:{ eexists. split. eauto. eapply eval_fix_unfold; eauto. - (* eapply eval_wf in IH2; eauto. + solve_all. + eapply eval_wf in IH2; eauto. invs IH2. - Lemma NoDup_app_inv {A} (l1 l2 : list A) : - NoDup (l1 ++ l2) -> NoDup l1 /\ NoDup l2. - Proof. - induction l1; cbn; eauto using NoDup. - inversion 1; subst; firstorder. - rewrite in_app_iff in H2. econstructor; eauto. - Qed. eapply NoDup_app_inv in H9 as []; eauto. *) + eapply All_nth_error in Hb1. 2: exact X. cbn in *. + rtoProp. + intros Hna. + unfold fresh in H2. + destruct in_dec; cbn in *; try congruence. + eapply n. rewrite in_app_iff. eauto. } { intros ? [-> | ?]. - eapply All_nth_error in sunny_in_vfix; eauto. cbn in sunny_in_vfix. rtoProp. unfold fresh in *. destruct in_dec; cbn in *; eauto. rewrite in_app_iff in n. eauto. - - eapply distinct_vfix_E0; eauto. + - eapply distinct_vfix_E0; eauto. now eapply in_rev. } { econstructor. - eapply All_nth_error in sunny_in_vfix; eauto. cbn in *. rtoProp. unfold fresh in *. destruct in_dec; cbn in *; eauto. - rewrite in_app_iff in n. eauto. - - eauto. + rewrite in_app_iff in n. rewrite <- in_rev. eauto. + - eapply NoDup_rev. eauto. } - { cbn. now rewrite map_length fix_env_length. } + { cbn. now rewrite List.rev_length map_length fix_env_length. } econstructor; eauto. { clear - H13. unfold fix_env, fix_subst. eapply All2_length in H13 as Hlen. rewrite Hlen. clear Hlen. @@ -1753,15 +1746,17 @@ Proof. } now rewrite app_nil_r. { cbn. rewrite map_fst_add_multiple. - now rewrite map_length fix_env_length. + now rewrite List.rev_length map_length fix_env_length. eapply All_nth_error in sunny_in_vfix; eauto. cbn in sunny_in_vfix. - now rtoProp. + rtoProp. + eapply sunny_subset; eauto. + intros ?; cbn in *. rewrite !in_app_iff. rewrite <- !in_rev. eauto. } { econstructor. - cbn. eapply eval_wf. 4: eauto. all:eauto. - eapply wf_add_multiple. + eauto. - + now rewrite map_length fix_env_length. + + now rewrite List.rev_length map_length fix_env_length. + eapply eval_wf in IH2; eauto. eapply wf_fix_env; eauto. } @@ -1801,8 +1796,7 @@ Proof. edestruct s0 as (v & Hv1 & Hv2). 1: eauto. eauto. econstructor. eexists. split. eauto. econstructor; eauto. - invs Hrep. - + let H2 := multimatch goal with H : _ |- _ => H end in - now invs H2. + + invs H2. + cbn in Hsunny. rtoProp. eapply eval_to_value in ev as Hval. invs Hval. * destruct f'; cbn in *; try congruence. @@ -1850,8 +1844,14 @@ Proof. eexists. split. econstructor. { instantiate (1 := vs). clear - Hvs; induction Hvs; econstructor; eauto. eapply r. } econstructor. erewrite <- lookup_in_env. 2: solve_all. - eapply H. eapply All2_length in H5. lia. - clear - Hvs; induction Hvs; econstructor; eauto. eapply r. + eapply H. eapply All2_length in H5. + destruct lookup_env as [ [] | ] eqn:Elo; try congruence. + epose proof (@lookup_env_wellformed _ Σ (inductive_mind ind) _ HwfΣ Elo). + cbn in H1. unfold wf_minductive in H1. rtoProp. cbn in *. eapply Nat.eqb_eq in H1. unfold cstr_arity in *. + destruct nth_error eqn:E1; cbn in *; try congruence. + destruct (nth_error (ind_ctors o) i) eqn:E2; cbn in *; try congruence. + unfold cstr_arity in *. invs H. lia. + clear - Hvs; induction Hvs; econstructor; eauto. eapply r. - invs Hrep; cbn in *; try congruence; rtoProp. + econstructor. split; eauto. econstructor. + destruct args'; congruence. @@ -1866,7 +1866,7 @@ Proof. symmetry. eapply All2_length; eauto. intros. cbn in *. destruct H1 as (([? []] & ?) & ?). - rewrite app_nil_r in r. eauto. + rewrite app_nil_r in r. all: eauto. - Unshelve. all: repeat econstructor. + Unshelve. all: repeat econstructor. Qed. From 713dbde5c9a3702acd64e72fa1742db3a3e4d161 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 19 Jun 2023 07:06:06 -0700 Subject: [PATCH 14/65] Bump cachix/install-nix-action from 20 to 21 (#966) Bumps [cachix/install-nix-action](https://github.com/cachix/install-nix-action) from 20 to 21. - [Release notes](https://github.com/cachix/install-nix-action/releases) - [Commits](https://github.com/cachix/install-nix-action/compare/v20...v21) --- updated-dependencies: - dependency-name: cachix/install-nix-action dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> --- .github/workflows/nix-action-coq-8.16-macos.yml | 6 +++--- .github/workflows/nix-action-coq-8.16-ubuntu.yml | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/workflows/nix-action-coq-8.16-macos.yml index 1e89ebab4..73b8a4969 100644 --- a/.github/workflows/nix-action-coq-8.16-macos.yml +++ b/.github/workflows/nix-action-coq-8.16-macos.yml @@ -19,7 +19,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v20 + uses: cachix/install-nix-action@v21 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -59,7 +59,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v20 + uses: cachix/install-nix-action@v21 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -104,7 +104,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v20 + uses: cachix/install-nix-action@v21 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/workflows/nix-action-coq-8.16-ubuntu.yml index c9705f2ba..62ef6ba7c 100644 --- a/.github/workflows/nix-action-coq-8.16-ubuntu.yml +++ b/.github/workflows/nix-action-coq-8.16-ubuntu.yml @@ -19,7 +19,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v20 + uses: cachix/install-nix-action@v21 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -59,7 +59,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v20 + uses: cachix/install-nix-action@v21 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -104,7 +104,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v20 + uses: cachix/install-nix-action@v21 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq From 6899a1a4b4db72ff5f28e5114f745e35c848d11e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Jun 2023 14:06:25 +0200 Subject: [PATCH 15/65] Fix a sneaky Prop <= Type use messing up certified erasure --- Makefile | 2 ++ erasure/theories/ErasureFunction.v | 4 ++-- template-coq/update_plugin.sh | 4 ++-- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 1d5d99253..a99854e73 100644 --- a/Makefile +++ b/Makefile @@ -36,6 +36,7 @@ install: all translations $(MAKE) -C quotation install $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install + $(MAKE) -C erasure-plugin install $(MAKE) -C translations install uninstall: @@ -48,6 +49,7 @@ uninstall: $(MAKE) -C quotation uninstall $(MAKE) -C safechecker-plugin uninstall $(MAKE) -C erasure uninstall + $(MAKE) -C erasure-plugin uninstall $(MAKE) -C translations uninstall html: all diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index fba458ddf..8fc9429cf 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -895,7 +895,7 @@ Program Fixpoint erase_global_decls let X' := abstract_pop_decls X in if KernameSet.mem kn deps then let Xext := abstract_make_wf_env_ext X' (cst_universes cb) _ in - let normalization_in' : id _ := _ in (* hack to avoid program erroring out on unresolved tc *) + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) let cb' := @erase_constant_body X_type Xext normalization_in' cb _ in let deps := KernameSet.union deps (snd cb') in let X'' := erase_global_decls deps X' decls _ in @@ -2694,7 +2694,7 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) | (kn, ConstantDecl cb) :: decls => if KernameSet.mem kn deps then let Xext' := abstract_make_wf_env_ext X (cst_universes cb) _ in - let normalization_in' : id _ := _ in (* hack to avoid program erroring out on unresolved tc *) + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) let cb' := @erase_constant_body X_type Xext' normalization_in' cb _ in let deps := KernameSet.union deps (snd cb') in let Σ' := erase_global_decls_fast deps X_type X decls _ in diff --git a/template-coq/update_plugin.sh b/template-coq/update_plugin.sh index 097a2e93b..1842cfdeb 100755 --- a/template-coq/update_plugin.sh +++ b/template-coq/update_plugin.sh @@ -19,8 +19,8 @@ then mv -f tmp $f done # Fix an extraction bug: wrong type annotation on eq_equivalence - patch -N -p0 < extraction.patch || exit $? - patch -N -p0 < specFloat.patch || exit $? + patch -N -p0 < extraction.patch + patch -N -p0 < specFloat.patch exit 0 else echo "Extracted code is up-to-date" From c065ed6faedd1e226af967631bc2154db0bc99ae Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 2 Jun 2023 17:06:10 +0200 Subject: [PATCH 16/65] Update Makefile to install erasure plugin --- .gitignore | 2 ++ Makefile | 2 ++ 2 files changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 704758b38..0558c7fc7 100644 --- a/.gitignore +++ b/.gitignore @@ -404,3 +404,5 @@ erasure-plugin/Makefile.erasureplugin erasure-plugin/Makefile.erasureplugin.conf erasure-plugin/Makefile.plugin erasure-plugin/Makefile.plugin.conf +erasure-plugin/META +safechecker-plugin/META diff --git a/Makefile b/Makefile index 1d5d99253..a99854e73 100644 --- a/Makefile +++ b/Makefile @@ -36,6 +36,7 @@ install: all translations $(MAKE) -C quotation install $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install + $(MAKE) -C erasure-plugin install $(MAKE) -C translations install uninstall: @@ -48,6 +49,7 @@ uninstall: $(MAKE) -C quotation uninstall $(MAKE) -C safechecker-plugin uninstall $(MAKE) -C erasure uninstall + $(MAKE) -C erasure-plugin uninstall $(MAKE) -C translations uninstall html: all From e0794e31790fa719d4a9bf34a0f508d17e43da95 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Jun 2023 14:14:44 +0200 Subject: [PATCH 17/65] Fix sneaky, useless Prop <= Type use that was breaking certified erasure --- erasure/theories/ErasureFunction.v | 5 +++-- template-coq/Makefile.plugin.local | 2 +- template-coq/update_plugin.sh | 4 ++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 421898b47..b1d033023 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -895,7 +895,7 @@ Program Fixpoint erase_global_decls let X' := abstract_pop_decls X in if KernameSet.mem kn deps then let Xext := abstract_make_wf_env_ext X' (cst_universes cb) _ in - let normalization_in' : id _ := _ in (* hack to avoid program erroring out on unresolved tc *) + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) let cb' := @erase_constant_body X_type Xext normalization_in' cb _ in let deps := KernameSet.union deps (snd cb') in let X'' := erase_global_decls deps X' decls _ in @@ -2637,6 +2637,7 @@ Notation NormalizationIn_erase_global_decls_fast X decls end) (only parsing). + Section EraseGlobalFast. Import PCUICEnvironment. @@ -2694,7 +2695,7 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) | (kn, ConstantDecl cb) :: decls => if KernameSet.mem kn deps then let Xext' := abstract_make_wf_env_ext X (cst_universes cb) _ in - let normalization_in' : id _ := _ in (* hack to avoid program erroring out on unresolved tc *) + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) let cb' := @erase_constant_body X_type Xext' normalization_in' cb _ in let deps := KernameSet.union deps (snd cb') in let Σ' := erase_global_decls_fast deps X_type X decls _ in diff --git a/template-coq/Makefile.plugin.local b/template-coq/Makefile.plugin.local index 9700c197b..3d1b9c40a 100644 --- a/template-coq/Makefile.plugin.local +++ b/template-coq/Makefile.plugin.local @@ -5,7 +5,7 @@ CAMLFLAGS+=-w -39 # Unused rec flag CAMLFLAGS+=-w -26 # Unused variable CAMLFLAGS+=-w -34 # Unused type CAMLFLAGS+=-w -60 # Unused module -CAMLFLAGS+=-w -8 # Non-exhaustive pattern-matchings (BEWARE, just for extracted code) +# CAMLFLAGS+=-w -8 # Non-exhaustive pattern-matchings (BEWARE, just for extracted code) CAMLFLAGS+=-bin-annot # For merlin CAMLPKGS+=-package stdlib-shims INSTALLDEFAULTROOT=MetaCoq/Template diff --git a/template-coq/update_plugin.sh b/template-coq/update_plugin.sh index 097a2e93b..1842cfdeb 100755 --- a/template-coq/update_plugin.sh +++ b/template-coq/update_plugin.sh @@ -19,8 +19,8 @@ then mv -f tmp $f done # Fix an extraction bug: wrong type annotation on eq_equivalence - patch -N -p0 < extraction.patch || exit $? - patch -N -p0 < specFloat.patch || exit $? + patch -N -p0 < extraction.patch + patch -N -p0 < specFloat.patch exit 0 else echo "Extracted code is up-to-date" From f5967d8f2e3043779b6d0ee67edf720b88279850 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 5 Jul 2023 06:22:39 -0700 Subject: [PATCH 18/65] Update dependabot.yml to also update other branches --- .github/dependabot.yml | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/.github/dependabot.yml b/.github/dependabot.yml index dcd7c9ef7..b378be58f 100644 --- a/.github/dependabot.yml +++ b/.github/dependabot.yml @@ -9,3 +9,27 @@ updates: interval: "daily" labels: - "dependencies" + - package-ecosystem: "github-actions" + directory: "/" + target-branch: "master" + schedule: + # Check for updates to GitHub Actions every weekday + interval: "daily" + labels: + - "dependencies" + - package-ecosystem: "github-actions" + directory: "/" + target-branch: "coq-8.17" + schedule: + # Check for updates to GitHub Actions every weekday + interval: "daily" + labels: + - "dependencies" + - package-ecosystem: "github-actions" + directory: "/" + target-branch: "coq-8.16" + schedule: + # Check for updates to GitHub Actions every weekday + interval: "daily" + labels: + - "dependencies" From a738c553d8a7953d5bf0d81beafadbcb34da48f5 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 5 Jul 2023 06:24:14 -0700 Subject: [PATCH 19/65] Update dependabot.yml to check main, not master --- .github/dependabot.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/dependabot.yml b/.github/dependabot.yml index b378be58f..ea49cfd2a 100644 --- a/.github/dependabot.yml +++ b/.github/dependabot.yml @@ -11,7 +11,7 @@ updates: - "dependencies" - package-ecosystem: "github-actions" directory: "/" - target-branch: "master" + target-branch: "main" schedule: # Check for updates to GitHub Actions every weekday interval: "daily" From e8d0b36017e20a8fb9b7fb32bea74a6dc8d96814 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Wed, 5 Jul 2023 06:25:05 -0700 Subject: [PATCH 20/65] Bump cachix/install-nix-action from 21 to 22 (#970) Bumps [cachix/install-nix-action](https://github.com/cachix/install-nix-action) from 21 to 22. - [Release notes](https://github.com/cachix/install-nix-action/releases) - [Commits](https://github.com/cachix/install-nix-action/compare/v21...v22) --- updated-dependencies: - dependency-name: cachix/install-nix-action dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> --- .github/workflows/nix-action-coq-8.16-macos.yml | 6 +++--- .github/workflows/nix-action-coq-8.16-ubuntu.yml | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/workflows/nix-action-coq-8.16-macos.yml index 73b8a4969..d4910f21d 100644 --- a/.github/workflows/nix-action-coq-8.16-macos.yml +++ b/.github/workflows/nix-action-coq-8.16-macos.yml @@ -19,7 +19,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v21 + uses: cachix/install-nix-action@v22 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -59,7 +59,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v21 + uses: cachix/install-nix-action@v22 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -104,7 +104,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v21 + uses: cachix/install-nix-action@v22 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/workflows/nix-action-coq-8.16-ubuntu.yml index 62ef6ba7c..81a42bc26 100644 --- a/.github/workflows/nix-action-coq-8.16-ubuntu.yml +++ b/.github/workflows/nix-action-coq-8.16-ubuntu.yml @@ -19,7 +19,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v21 + uses: cachix/install-nix-action@v22 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -59,7 +59,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v21 + uses: cachix/install-nix-action@v22 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -104,7 +104,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v21 + uses: cachix/install-nix-action@v22 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq From 943cc72bd12ab41d1f67af96f5744c32e40338bf Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Wed, 5 Jul 2023 06:25:41 -0700 Subject: [PATCH 21/65] Bump cachix/install-nix-action from 21 to 22 (#973) Bumps [cachix/install-nix-action](https://github.com/cachix/install-nix-action) from 21 to 22. - [Release notes](https://github.com/cachix/install-nix-action/releases) - [Commits](https://github.com/cachix/install-nix-action/compare/v21...v22) --- updated-dependencies: - dependency-name: cachix/install-nix-action dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> From 3e0f857109da9530c572edb293a737bc5fe25943 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 4 Sep 2023 18:20:32 +0000 Subject: [PATCH 22/65] Bump actions/checkout from 3 to 4 (#978) --- .github/workflows/build.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 3b85ce6de..0c54ab5d6 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -11,7 +11,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 1 @@ -37,7 +37,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 1 From 555b2394100846c758c17fc8b7450a4d2b728baf Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 4 Sep 2023 18:21:32 +0000 Subject: [PATCH 23/65] Bump actions/checkout from 3 to 4 (#977) --- .github/workflows/build.yml | 4 ++-- .github/workflows/nix-action-coq-8.16-macos.yml | 6 +++--- .github/workflows/nix-action-coq-8.16-ubuntu.yml | 6 +++--- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index cb1ea1d6f..e789f6ed3 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -11,7 +11,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 1 @@ -37,7 +37,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 1 diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/workflows/nix-action-coq-8.16-macos.yml index d4910f21d..b1fbcb83e 100644 --- a/.github/workflows/nix-action-coq-8.16-macos.yml +++ b/.github/workflows/nix-action-coq-8.16-macos.yml @@ -14,7 +14,7 @@ jobs: \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - name: Git checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} @@ -54,7 +54,7 @@ jobs: \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - name: Git checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} @@ -99,7 +99,7 @@ jobs: \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - name: Git checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/workflows/nix-action-coq-8.16-ubuntu.yml index 81a42bc26..c2652234d 100644 --- a/.github/workflows/nix-action-coq-8.16-ubuntu.yml +++ b/.github/workflows/nix-action-coq-8.16-ubuntu.yml @@ -14,7 +14,7 @@ jobs: \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - name: Git checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} @@ -54,7 +54,7 @@ jobs: \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - name: Git checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} @@ -99,7 +99,7 @@ jobs: \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - name: Git checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} From 77234210ad9593d7304f9f0d453f70424b2c8f90 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 4 Sep 2023 19:54:27 +0000 Subject: [PATCH 24/65] Bump cachix/install-nix-action from 22 to 23 (#979) --- .github/workflows/nix-action-coq-8.16-macos.yml | 6 +++--- .github/workflows/nix-action-coq-8.16-ubuntu.yml | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/workflows/nix-action-coq-8.16-macos.yml index b1fbcb83e..ae2df21fe 100644 --- a/.github/workflows/nix-action-coq-8.16-macos.yml +++ b/.github/workflows/nix-action-coq-8.16-macos.yml @@ -19,7 +19,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v22 + uses: cachix/install-nix-action@v23 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -59,7 +59,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v22 + uses: cachix/install-nix-action@v23 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -104,7 +104,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v22 + uses: cachix/install-nix-action@v23 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/workflows/nix-action-coq-8.16-ubuntu.yml index c2652234d..3da6051c9 100644 --- a/.github/workflows/nix-action-coq-8.16-ubuntu.yml +++ b/.github/workflows/nix-action-coq-8.16-ubuntu.yml @@ -19,7 +19,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v22 + uses: cachix/install-nix-action@v23 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -59,7 +59,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v22 + uses: cachix/install-nix-action@v23 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq @@ -104,7 +104,7 @@ jobs: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install - uses: cachix/install-nix-action@v22 + uses: cachix/install-nix-action@v23 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup metacoq From adba7945a55e4590802318f27b0c56d6ddf48f7f Mon Sep 17 00:00:00 2001 From: nicolas tabareau Date: Tue, 26 Sep 2023 14:49:58 +0200 Subject: [PATCH 25/65] improve stengthening to get cumul info on type --- .../theories/Bidirectional/BDStrengthening.v | 73 ++++++++++++++----- pcuic/theories/PCUICFirstorder.v | 8 -- utils/theories/All_Forall.v | 5 +- 3 files changed, 56 insertions(+), 30 deletions(-) diff --git a/pcuic/theories/Bidirectional/BDStrengthening.v b/pcuic/theories/Bidirectional/BDStrengthening.v index 2a2f754c5..827f91eaf 100644 --- a/pcuic/theories/Bidirectional/BDStrengthening.v +++ b/pcuic/theories/Bidirectional/BDStrengthening.v @@ -3,7 +3,7 @@ From Coq Require String. From MetaCoq.Utils Require Import utils monad_utils. From MetaCoq.Common Require Import config. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICGlobalEnv - PCUICTactics + PCUICTactics PCUICCumulativity PCUICInduction PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils PCUICPosition PCUICTyping PCUICSigmaCalculus PCUICOnFreeVars PCUICClosed PCUICConfluence PCUICSpine PCUICInductiveInversion PCUICParallelReductionConfluence PCUICWellScopedCumulativity PCUICClosed PCUICRenameDef PCUICInstConv PCUICClosedTyp PCUICWeakeningEnvTyp PCUICRenameTyp PCUICRenameConv PCUICGuardCondition PCUICWeakeningConv. @@ -896,21 +896,6 @@ Qed. End BDRenaming. -Theorem typing_renaming_cond_P `{checker_flags} {P f Σ Γ Δ t T} {wfΣ : wf Σ.1} : - renaming P Σ Γ Δ f -> - on_ctx_free_vars P Γ -> - on_free_vars P t -> - Σ ;;; Γ |- t : T -> - ∑ T', Σ ;;; Δ |- rename f t : T'. -Proof. - move => [ur wfΔ] fvΓ fvt tyt. - move: (tyt) => /typing_wf_local wfΓ. - move: (tyt) => /typing_infering [T' [inf cum]]. - exists (rename f T'). - apply infering_typing => //. - eapply bidirectional_renaming ; eassumption. -Qed. - Lemma closedn_ctx_lift_inv n k k' Γ : k <= k' -> closedn_ctx (k' + n) (lift_context n k Γ) -> closedn_ctx k' Γ. @@ -996,9 +981,29 @@ Proof. all: lia. Qed. + +Theorem typing_renaming_cond_P `{checker_flags} {P f Σ Γ Δ t T} {wfΣ : wf Σ.1} : + renaming P Σ Γ Δ f -> + on_ctx_free_vars P Γ -> + on_free_vars P t -> + on_free_vars P T -> + Σ ;;; Γ |- t : T -> + ∑ T', (Σ ;;; Δ |- rename f t : T') * (Σ ;;; Δ |- T' <= rename f T). +Proof. + move => [ur wfΔ] fvΓ fvt fvT tyt. + move: (tyt) => /typing_wf_local wfΓ. + move: (tyt) => /typing_infering [T' [inf cum]]. + exists (rename f T'). split; eauto. sq. + apply infering_typing => //. + eapply bidirectional_renaming ; eassumption. + eapply cumul_renameP with (Γ := Γ); eauto. + 2: { eapply ws_cumul_pb_forget_cumul; eauto. } + eapply infering_on_free_vars; try exact inf; eauto. +Qed. + Lemma strengthening `{cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Γ' Γ'' t T : - Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : T -> - ∑ T', Σ ;;; Γ ,,, Γ'' |- t : T'. + Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : lift #|Γ'| #|Γ''| T -> + ∑ T', (Σ ;;; Γ ,,, Γ'' |- t : T') * (Σ ;;; Γ ,,, Γ'' |- T' <= T). Proof. intros Hty. assert (wf_local Σ Γ) by @@ -1029,9 +1034,9 @@ Proof. eassumption. } - erewrite <- (lift_unlift_term t). + erewrite <- (lift_unlift_term t). erewrite <- (lift_unlift_term T). eapply typing_renaming_cond_P. - 4: eassumption. + 5: eassumption. - split => //. apply urenaming_strengthen. - move: wfΓ'' => /wf_local_closed_context. @@ -1046,4 +1051,32 @@ Proof. 2: lia. eapply closedn_on_free_vars. eassumption. + - rewrite on_free_vars_lift -shiftnP_xpredT. + move: Hty => /type_closed. + len. + rewrite -[X in _ + X]Nat.add_comm Nat.add_assoc => Ht. + eapply closedn_lift_inv in Ht. + 2: lia. + eapply closedn_on_free_vars. + eassumption. Qed. + + +Lemma strengthening_type `{cf: checker_flags} {Σ : global_env_ext} {wfΣ : PCUICTyping.wf Σ} Γ Γ' Γ'' t s : + Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : tSort s -> + ∑ s', (Σ ;;; Γ ,,, Γ'' |- t : tSort s') * (compare_universe Cumul Σ s' s). +Proof. + assert (liftSort : lift #|Γ'| #|Γ''| (tSort s) = tSort s) by reflexivity. rewrite <- liftSort; clear liftSort. + intros H; eapply strengthening in H. destruct H as [T' [HT' Hcumul]]. + pose proof (Hcumul' := Hcumul). + pose proof (type_closed HT'). + eapply closedn_on_free_vars in H. + pose proof (wf_local_closed_context (typing_wf_local HT')). + eapply into_ws_cumul_pb in Hcumul; eauto. + eapply PCUICConversion.ws_cumul_pb_Sort_r_inv in Hcumul as [s' [Hred Hcumul]]. + eapply closed_red_red in Hred. pose proof (HT'':=HT'). eapply PCUICValidity.validity in HT' as [? ?]. + exists s'; split; eauto. + eapply type_Cumul; eauto. eapply PCUICSR.subject_reduction; eauto. + eapply PCUICConversion.cumulAlgo_cumulSpec. eapply PCUICConversion.ws_cumul_pb_red_r_inv; eauto. + eapply ws_cumul_pb_refl; eauto. +Qed. \ No newline at end of file diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index 47f5e6198..cf5bc91af 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -48,14 +48,6 @@ Section firstorder. | tRel i => (k <=? i) && (i false end. - (* - Definition firstorder_type (t : term) := - match (PCUICAstUtils.decompose_app t).1 with - | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with - | Some l => nth i l false | None => false - end - | _ => false - end. *) Definition firstorder_con mind (c : constructor_body) := let inds := #|mind.(ind_bodies)| in diff --git a/utils/theories/All_Forall.v b/utils/theories/All_Forall.v index 848c19f3d..1e408d0aa 100644 --- a/utils/theories/All_Forall.v +++ b/utils/theories/All_Forall.v @@ -1,6 +1,7 @@ From Coq Require Import List Bool Arith ssreflect Morphisms Lia Utf8. From MetaCoq.Utils Require Import MCPrelude MCReflect MCList MCRelations MCProd MCOption. From Equations Require Import Equations. + Import ListNotations. Derive Signature for Forall Forall2. @@ -3016,11 +3017,11 @@ Proof. Qed. Lemma Forall2_sym : - forall A (P : A -> A -> Prop) l l', + forall A B (P : A -> B -> Prop) l l', Forall2 P l l' -> Forall2 (fun x y => P y x) l' l. Proof. - intros A P l l' h. + intros A B P l l' h. induction h. - constructor. - constructor. all: auto. From 9fd6f611eeca836f34807eb706e314e56ee7a01a Mon Sep 17 00:00:00 2001 From: nicolas tabareau Date: Tue, 26 Sep 2023 17:58:59 +0200 Subject: [PATCH 26/65] more general strengthening --- .../theories/Bidirectional/BDStrengthening.v | 62 ++++++++++--------- 1 file changed, 33 insertions(+), 29 deletions(-) diff --git a/pcuic/theories/Bidirectional/BDStrengthening.v b/pcuic/theories/Bidirectional/BDStrengthening.v index 827f91eaf..3882a6364 100644 --- a/pcuic/theories/Bidirectional/BDStrengthening.v +++ b/pcuic/theories/Bidirectional/BDStrengthening.v @@ -986,24 +986,26 @@ Theorem typing_renaming_cond_P `{checker_flags} {P f Σ Γ Δ t T} {wfΣ : wf Σ renaming P Σ Γ Δ f -> on_ctx_free_vars P Γ -> on_free_vars P t -> - on_free_vars P T -> Σ ;;; Γ |- t : T -> - ∑ T', (Σ ;;; Δ |- rename f t : T') * (Σ ;;; Δ |- T' <= rename f T). + ∑ T', [× (on_free_vars P T'), (Σ ;;; Γ |- t : T'), (Σ ;;; Γ |- T' <= T) & + (Σ ;;; Δ |- rename f t : rename f T')]. Proof. - move => [ur wfΔ] fvΓ fvt fvT tyt. + move => [ur wfΔ] fvΓ fvt tyt. move: (tyt) => /typing_wf_local wfΓ. move: (tyt) => /typing_infering [T' [inf cum]]. - exists (rename f T'). split; eauto. sq. - apply infering_typing => //. - eapply bidirectional_renaming ; eassumption. - eapply cumul_renameP with (Γ := Γ); eauto. - 2: { eapply ws_cumul_pb_forget_cumul; eauto. } - eapply infering_on_free_vars; try exact inf; eauto. + unshelve epose proof (infering_on_free_vars _ _ _ _ _ _ _ _ inf); eauto. + pose proof (inf' := inf). apply infering_typing in inf; eauto. + exists T'. split; eauto. + eapply ws_cumul_pb_forget_cumul; eauto. + eapply bidirectional_renaming in inf'; eauto. eapply infering_typing; eauto. Qed. Lemma strengthening `{cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Γ' Γ'' t T : - Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : lift #|Γ'| #|Γ''| T -> - ∑ T', (Σ ;;; Γ ,,, Γ'' |- t : T') * (Σ ;;; Γ ,,, Γ'' |- T' <= T). + Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : T -> + ∑ T', [× on_free_vars (strengthenP #|Γ''| #|Γ'| xpredT) T', + (Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : T') , + (Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- T' <= T) & + (Σ ;;; Γ ,,, Γ'' |- t : unlift #|Γ'| #|Γ''| T')]. Proof. intros Hty. assert (wf_local Σ Γ) by @@ -1034,11 +1036,10 @@ Proof. eassumption. } - erewrite <- (lift_unlift_term t). erewrite <- (lift_unlift_term T). - eapply typing_renaming_cond_P. - 5: eassumption. - - split => //. - apply urenaming_strengthen. + eapply typing_renaming_cond_P in Hty as [T' [? ?]]; eauto. + exists T'. split; eauto. + - erewrite <- (lift_unlift_term t); eauto. + - split; eauto. eapply urenaming_strengthen. - move: wfΓ'' => /wf_local_closed_context. rewrite on_free_vars_ctx_app => /andP [? ?]. apply on_ctx_free_vars_strengthenP. @@ -1051,14 +1052,6 @@ Proof. 2: lia. eapply closedn_on_free_vars. eassumption. - - rewrite on_free_vars_lift -shiftnP_xpredT. - move: Hty => /type_closed. - len. - rewrite -[X in _ + X]Nat.add_comm Nat.add_assoc => Ht. - eapply closedn_lift_inv in Ht. - 2: lia. - eapply closedn_on_free_vars. - eassumption. Qed. @@ -1066,17 +1059,28 @@ Lemma strengthening_type `{cf: checker_flags} {Σ : global_env_ext} {wfΣ : PCUI Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : tSort s -> ∑ s', (Σ ;;; Γ ,,, Γ'' |- t : tSort s') * (compare_universe Cumul Σ s' s). Proof. - assert (liftSort : lift #|Γ'| #|Γ''| (tSort s) = tSort s) by reflexivity. rewrite <- liftSort; clear liftSort. - intros H; eapply strengthening in H. destruct H as [T' [HT' Hcumul]]. + intros H; pose proof (H' := H); eapply strengthening in H. destruct H as [T' [? HT Hcumul HT']]. pose proof (Hcumul' := Hcumul). - pose proof (type_closed HT'). + pose proof (type_closed HT). eapply closedn_on_free_vars in H. - pose proof (wf_local_closed_context (typing_wf_local HT')). + pose proof (type_closed HT'). + eapply closedn_on_free_vars in H0. + pose proof (wf_local_closed_context (typing_wf_local H')). eapply into_ws_cumul_pb in Hcumul; eauto. eapply PCUICConversion.ws_cumul_pb_Sort_r_inv in Hcumul as [s' [Hred Hcumul]]. eapply closed_red_red in Hred. pose proof (HT'':=HT'). eapply PCUICValidity.validity in HT' as [? ?]. exists s'; split; eauto. + assert (PCUICReduction.red Σ (Γ,,, Γ'') (unlift #|Γ'| #|Γ''| T') (tSort s')). + { assert (tSort s' = unlift #|Γ'| #|Γ''| (tSort s')) by reflexivity. rewrite H2; clear H2. + eapply red_rename. eauto. eapply (urenaming_strengthen _ _ _ _); eauto. + 2-3: eauto. eapply typing_wf_local in HT''. + eapply wf_local_closed_context in HT''. revert HT''. + rewrite on_free_vars_ctx_app => /andP [? ?]. + apply on_ctx_free_vars_strengthenP. + all: eapply on_free_vars_ctx_on_ctx_free_vars_xpredT; eauto. + } eapply type_Cumul; eauto. eapply PCUICSR.subject_reduction; eauto. + assert (liftSort : unlift #|Γ'| #|Γ''| (tSort s') = tSort s') by reflexivity. rewrite <- liftSort; clear liftSort. eapply PCUICConversion.cumulAlgo_cumulSpec. eapply PCUICConversion.ws_cumul_pb_red_r_inv; eauto. - eapply ws_cumul_pb_refl; eauto. + eapply ws_cumul_pb_refl; eauto. eapply PCUICInversion.typing_closed_ctx; eauto. Qed. \ No newline at end of file From be4447721e859796b52b4d9a4819e7a0bf2d64bc Mon Sep 17 00:00:00 2001 From: nicolas tabareau Date: Wed, 27 Sep 2023 16:47:01 +0200 Subject: [PATCH 27/65] remove parameters in firstorder inductive types --- pcuic/theories/PCUICFirstorder.v | 37 +++++++++++++++----------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index cf5bc91af..0942d8141 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -41,12 +41,12 @@ Section firstorder. end. *) Definition firstorder_type (n k : nat) (t : term) := - match (PCUICAstUtils.decompose_app t).1 with - | tInd (mkInd nm i) u => match (plookup_env Σb nm) with + match (PCUICAstUtils.decompose_app t).1, (PCUICAstUtils.decompose_app t).2 with + | tInd (mkInd nm i) u , [] => match (plookup_env Σb nm) with | Some b => b | None => false end - | tRel i => (k <=? i) && (i false + | tRel i , [] => (k <=? i) && (i false end. Definition firstorder_con mind (c : constructor_body) := @@ -432,6 +432,7 @@ Proof using Type. destruct plookup_env eqn:hl => //. destruct b => //. eapply (plookup_env_extends (Σ:=Σ)) in hl. 2:split; eauto. rewrite eq in hl. rewrite hl //. apply wf. + all: destruct l; eauto. Qed. Lemma firstorder_args {Σ : global_env_ext} {wfΣ : wf Σ} { mind cbody i n ui args u pandi oind} : @@ -480,7 +481,7 @@ Proof using Type. { intros k t. rewrite /firstorder_type. rewrite -PCUICUnivSubstitutionConv.subst_instance_decompose_app /=. - destruct (decompose_app) => //=. destruct t0 => //. } + destruct (decompose_app) => //=. destruct t0 => //; destruct l; eauto. } replace (List.rev c)@[ui] with (List.rev c@[ui]). 2:{ rewrite /subst_instance /subst_instance_context /map_context map_rev //. } revert args. @@ -511,17 +512,15 @@ Proof using Type. unfold firstorder_type; cbn. destruct (decompose_app decl_type) eqn:da. rewrite (decompose_app_inv da) subst_mkApps /=. - destruct t0 => //=. + destruct t0 => //=; destruct l; eauto. { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn']. destruct (Nat.leb_spec n n0). destruct (n0 - n) eqn:E. lia. - cbn. rewrite nth_error_nil /=. - rewrite decompose_app_mkApps //=. + cbn. rewrite nth_error_nil /=. apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. - cbn. rewrite decompose_app_mkApps //=. apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } - { destruct ind => //. rewrite decompose_app_mkApps //. } + { destruct ind => //. } + move=> /andP[] fot foΓ. rewrite subst_context_app /=. rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. @@ -529,9 +528,10 @@ Proof using Type. destruct ((PCUICAstUtils.decompose_app t)) eqn:E. cbn in fot. destruct t0; try solve [inv fot]. * rewrite (decompose_app_inv E) /= subst_mkApps. - rewrite Nat.add_0_r in fot. eapply Nat.ltb_lt in fot. + rewrite Nat.add_0_r in fot. destruct l; try solve [inversion fot]. + eapply Nat.ltb_lt in fot. cbn. rewrite nth_error_inds. lia. cbn. - econstructor. + eapply instantiated_tProd with (args := []). unshelve epose proof (d1_ := declared_minductive_to_gen d1); eauto. { rewrite /firstorder_ind d1_ /= /firstorder_mutind indf H0 //. } intros x. @@ -552,20 +552,19 @@ Proof using Type. unfold firstorder_type; cbn. destruct (decompose_app decl_type) eqn:da. rewrite (decompose_app_inv da) subst_mkApps /=. - destruct t0 => //=. + destruct t0 => //=; destruct l; eauto. { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn']. destruct (Nat.leb_spec n n0). destruct (n0 - n) eqn:E. lia. cbn. rewrite nth_error_nil /=. - rewrite decompose_app_mkApps //=. apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. - cbn. rewrite decompose_app_mkApps //=. apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } - { destruct ind => //. rewrite decompose_app_mkApps //. } + { destruct ind => //. } * rewrite (decompose_app_inv E) subst_mkApps //=. constructor. { unfold firstorder_ind. destruct ind. cbn in *. + destruct l; [|inversion fot]. destruct plookup_env eqn:hp => //. eapply plookup_env_lookup_env in hp as [Σ' [decl [eq [ext he]]]]. rewrite eq. destruct decl; subst b => //. @@ -587,17 +586,15 @@ Proof using Type. unfold firstorder_type; cbn. destruct (decompose_app decl_type) eqn:da. rewrite (decompose_app_inv da) subst_mkApps /=. - destruct t0 => //=. + destruct t0 => //=; destruct l; eauto. { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn']. destruct (Nat.leb_spec n n0). destruct (n0 - n) eqn:E. lia. cbn. rewrite nth_error_nil /=. - rewrite decompose_app_mkApps //=. apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. - cbn. rewrite decompose_app_mkApps //=. apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } - { destruct ind => //. rewrite decompose_app_mkApps //. } + { destruct ind => //. } } cbn in Hi |- *. revert Hi Hspine. cbn. From 00a42993444ad6f77c8f20921e4c3e2cdaf56b66 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Fri, 29 Sep 2023 23:17:25 -0700 Subject: [PATCH 28/65] Drastically speed up ByteCompareSpec Old: ``` theories/ByteCompareSpec.vo (real: 113.67, user: 111.75, sys: 1.57, mem: 1287536 ko) ``` New: ``` COQC theories/ByteCompareSpec.v theories/ByteCompareSpec.vo (real: 9.46, user: 8.89, sys: 0.26, mem: 442460 ko) ``` The new file is also compatible with COQNATIVE, taking only seconds rather than dozens of minutes or more. --- utils/theories/ByteCompareSpec.v | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/utils/theories/ByteCompareSpec.v b/utils/theories/ByteCompareSpec.v index 1bf10f910..207588924 100644 --- a/utils/theories/ByteCompareSpec.v +++ b/utils/theories/ByteCompareSpec.v @@ -1,4 +1,4 @@ -From Coq Require Import Strings.Byte NArith. +From Coq Require Import Strings.Byte NArith Eqdep_dec. From MetaCoq.Utils Require Import ReflectEq ByteCompare. From Equations Require Import Equations. @@ -6,19 +6,31 @@ Derive NoConfusion for comparison. Section ByteNoConf. Local Ltac solve_noconf ::= idtac. + (** The NoConfusion definition is quite large, so we define a much more compact version of it that is nevertheless convertible *) + Definition eta_byte {A} (f : forall b : byte, A b) (b : byte) : A b + := Eval cbv in + ltac:(pose (f b) as v; destruct b; let val := (eval cbv in v) in exact val). + Definition uneta_byte {A f b} : @eta_byte A f b = f b + := match b with x00 | _ => eq_refl end. + Definition NoConfusion_byte_alt : byte -> byte -> Prop + := eta_byte (fun b1 b2 => eta_byte (fun b2 => if Byte.eqb b1 b2 then True else False) b2). Derive NoConfusion for byte. Next Obligation. - destruct a; abstract (destruct b; try exact (False_ind _ H); exact eq_refl). - Defined. + change (NoConfusion_byte a b) with (NoConfusion_byte_alt a b) in *. + cbv [NoConfusion_byte_alt] in *; apply byte_dec_bl. + rewrite !uneta_byte in *. + destruct Byte.eqb; [ reflexivity | exfalso; assumption ]. + Qed. Next Obligation. destruct b; cbn; exact I. Defined. Next Obligation. - destruct a; abstract (destruct b; try (exact (False_ind _ e)); destruct e; exact eq_refl). - Defined. + lazymatch goal with |- ?f _ _ ?g = ?e => generalize g; revert e end; intros e g; subst; revert e. + destruct b; vm_compute; intros []; reflexivity. + Qed. Next Obligation. - destruct b; cbn; exact eq_refl. - Defined. + apply UIP_dec, byte_eq_dec. + Qed. End ByteNoConf. Lemma reflect_equiv P Q b : P <-> Q -> Bool.reflect P b -> Bool.reflect Q b. From c2d27540a592182a2611985f1bad7977e471f855 Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Mon, 2 Oct 2023 15:15:11 +0200 Subject: [PATCH 29/65] adapt CI and opam files to 8.18 --- .github/workflows/build.yml | 3 ++- coq-metacoq-common.opam | 2 +- coq-metacoq-erasure-plugin.opam | 2 +- coq-metacoq-erasure.opam | 2 +- coq-metacoq-pcuic.opam | 2 +- coq-metacoq-quotation.opam | 2 +- coq-metacoq-safechecker-plugin.opam | 2 +- coq-metacoq-safechecker.opam | 2 +- coq-metacoq-template-pcuic.opam | 2 +- coq-metacoq-template.opam | 2 +- coq-metacoq-translations.opam | 2 +- coq-metacoq-utils.opam | 6 +++--- coq-metacoq.opam | 2 +- 13 files changed, 16 insertions(+), 15 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 0077acc3b..835fbadb1 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -24,7 +24,7 @@ jobs: strategy: matrix: coq_version: - - 'dev' + - '8.18' ocaml_version: - '4.14-flambda' target: [ local, opam, quick ] @@ -50,6 +50,7 @@ jobs: startGroup "Workaround permission issue" sudo chown -R coq:coq . # <-- opam exec -- ocamlfind list + opam pin coq-equations.1.3 "https://github.com/mattam82/Coq-Equations.git#8.18" endGroup before_install: | startGroup "Print opam config" diff --git a/coq-metacoq-common.opam b/coq-metacoq-common.opam index 45a73ba75..cd4ae3fc6 100644 --- a/coq-metacoq-common.opam +++ b/coq-metacoq-common.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-erasure-plugin.opam b/coq-metacoq-erasure-plugin.opam index 884d6a877..c480c7e98 100644 --- a/coq-metacoq-erasure-plugin.opam +++ b/coq-metacoq-erasure-plugin.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-erasure.opam b/coq-metacoq-erasure.opam index b2dd484f9..0eecc5523 100644 --- a/coq-metacoq-erasure.opam +++ b/coq-metacoq-erasure.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-pcuic.opam b/coq-metacoq-pcuic.opam index f8abf0db5..87791e67c 100644 --- a/coq-metacoq-pcuic.opam +++ b/coq-metacoq-pcuic.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-quotation.opam b/coq-metacoq-quotation.opam index 59f5f9d3b..d36813915 100644 --- a/coq-metacoq-quotation.opam +++ b/coq-metacoq-quotation.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-safechecker-plugin.opam b/coq-metacoq-safechecker-plugin.opam index c691fdba0..10825a6a3 100644 --- a/coq-metacoq-safechecker-plugin.opam +++ b/coq-metacoq-safechecker-plugin.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-safechecker.opam b/coq-metacoq-safechecker.opam index 7594e7991..4ec7b94bc 100644 --- a/coq-metacoq-safechecker.opam +++ b/coq-metacoq-safechecker.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-template-pcuic.opam b/coq-metacoq-template-pcuic.opam index 1a0848d0c..18aa8302c 100644 --- a/coq-metacoq-template-pcuic.opam +++ b/coq-metacoq-template-pcuic.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-template.opam b/coq-metacoq-template.opam index 8d0ff8ed7..a6ac991a0 100644 --- a/coq-metacoq-template.opam +++ b/coq-metacoq-template.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-translations.opam b/coq-metacoq-translations.opam index 5db167651..409ce2ee3 100644 --- a/coq-metacoq-translations.opam +++ b/coq-metacoq-translations.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" diff --git a/coq-metacoq-utils.opam b/coq-metacoq-utils.opam index 497c11b53..680c1ded6 100644 --- a/coq-metacoq-utils.opam +++ b/coq-metacoq-utils.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" @@ -29,8 +29,8 @@ install: [ ] depends: [ "stdlib-shims" - "coq" { = "dev" } - "coq-equations" { = "dev" } + "coq" { >= "8.18" & < "8.19~" } + "coq-equations" { = "1.3" } ] synopsis: "The utility library of Template Coq and PCUIC" description: """ diff --git a/coq-metacoq.opam b/coq-metacoq.opam index 0e36fb32c..0995857c4 100644 --- a/coq-metacoq.opam +++ b/coq-metacoq.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev" +version: "8.18.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" dev-repo: "git+https://github.com/MetaCoq/metacoq.git#main" From 88b4a4d8534669a1e5e4ca806e10da0d9893e491 Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Mon, 2 Oct 2023 15:19:47 +0200 Subject: [PATCH 30/65] update documentation to mention 8.18 --- DOC.md | 7 +++---- INSTALL.md | 13 ++++++------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/DOC.md b/DOC.md index 9eb9294af..bb585b42b 100644 --- a/DOC.md +++ b/DOC.md @@ -2,8 +2,7 @@ ## Branches and compatibility -**tl;dr** You should do your PRs against [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16). - +**tl;dr** You should do your PRs against [coq-8.18](https://github.com/MetaCoq/metacoq/tree/coq-8.16). Coq's kernel API is not stable yet, and changes there are reflected in MetaCoq's reified structures, so we do not ensure any compatibility from version to version. There is one branch for each Coq version. @@ -22,8 +21,8 @@ stable release of Coq. -The branches [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16) and [coq-8.17](https://github.com/MetaCoq/metacoq/tree/coq-8.17) are being kept in sync. -The branches [coq-8.6](https://github.com/MetaCoq/metacoq/tree/coq-8.6) to [coq-8.15](https://github.com/MetaCoq/metacoq/tree/coq-8.15) are frozen. +The branches [coq-8.17](https://github.com/MetaCoq/metacoq/tree/coq-8.17) and [coq-8.18](https://github.com/MetaCoq/metacoq/tree/coq-8.18) are being kept in sync. +The branches [coq-8.6](https://github.com/MetaCoq/metacoq/tree/coq-8.6) to [coq-8.15](https://github.com/MetaCoq/metacoq/tree/coq-8.16) are frozen. ## Program and Equations diff --git a/INSTALL.md b/INSTALL.md index c16427ad8..f5155d414 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -55,8 +55,7 @@ To compile the library, you need: - The `Coq` version corrsponding to your branch (you can use the `coq.dev` package for the `main` branch). -- `OCaml` (tested with `4.06.1`, `4.07.1`, and `4.10.0`, beware that `OCaml 4.06.0` - can produce linking errors on some platforms) +- `OCaml` (tested with `4.14.0`) - [`Equations 1.3`](http://mattam82.github.io/Coq-Equations/) The recommended way to build a development environment for MetaCoq is @@ -67,10 +66,10 @@ to have a dedicated `opam` switch (see below). To get the source code: # git clone https://github.com/MetaCoq/metacoq.git - # git checkout -b coq-8.17 origin/coq-8.17 + # git checkout -b coq-8.18 origin/coq-8.18 # git status -This checks that you are indeed on the `coq-8.17` branch. +This checks that you are indeed on the `coq-8.18` branch. ### Setting up an `opam` switch @@ -79,10 +78,10 @@ To setup a fresh `opam` installation, you might want to create a one yet. You need to use **opam 2** to obtain the right version of `Equations`. - # opam switch create coq.8.17 --packages=ocaml-variants.4.13.1+options,ocaml-option-flambda + # opam switch create coq.8.18 --packages="ocaml-variants.4.14.0+options,ocaml-option-flambda" # eval $(opam env) -This creates the `coq.8.17` switch which initially contains only the +This creates the `coq.8.18` switch which initially contains only the basic `OCaml` `4.13.1` compiler with the `flambda` option enabled, and puts you in the right environment (check with `ocamlc -v`). @@ -96,7 +95,7 @@ If the commands are successful you should have `coq` available (check with `coqc **Remark:** You can create a [local switch](https://opam.ocaml.org/blog/opam-20-tips/#Local-switches) for developing using (in the root directory of the sources): - # opam switch create . 4.07.1 + # opam switch create . --packages="ocaml-variants.4.14.0+options,ocaml-option-flambda" Or use `opam switch link foo` to link an existing opam switch `foo` with the sources directory. From dce0b9e51ce6335bed80cceca15b11f3087777ef Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Thu, 6 Jul 2023 08:06:27 +0200 Subject: [PATCH 31/65] split out verified erasure pipeline --- Makefile | 3 +- erasure-plugin/theories/ETransform.v | 12 +- erasure-plugin/theories/Erasure.v | 58 +++- erasure/theories/EOptimizePropDiscr.v | 334 ++++++++++----------- erasure/theories/EWcbvEvalNamed.v | 160 +++++++++- erasure/theories/Typed/Extraction.v | 2 +- erasure/theories/Typed/OptimizePropDiscr.v | 34 +-- erasure/theories/Typed/TypeAnnotations.v | 30 +- 8 files changed, 403 insertions(+), 230 deletions(-) diff --git a/Makefile b/Makefile index a99854e73..e16daadc8 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: printconf template-coq pcuic safechecker erasure examples test-suite translations quotation +all: printconf template-coq pcuic safechecker erasure -include Makefile.conf @@ -37,7 +37,6 @@ install: all translations $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install $(MAKE) -C erasure-plugin install - $(MAKE) -C translations install uninstall: $(MAKE) -C utils uninstall diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index 822730bdd..521481293 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -358,23 +358,23 @@ Qed. Import EOptimizePropDiscr EWcbvEval. -Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : +Program Definition remove_match_on_box_trans {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := {| name := "optimize_prop_discr"; - transform p _ := optimize_program p ; + transform p _ := remove_match_on_box_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram efl p /\ EEtaExpanded.expanded_eprogram_cstrs p; - obseq g g' v v' := v' = EOptimizePropDiscr.optimize g.1 v |}. + obseq g g' v v' := v' = EOptimizePropDiscr.remove_match_on_box g.1 v |}. Next Obligation. move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap]. cbn in *. split. - - now eapply optimize_program_wf. - - now eapply optimize_program_expanded. + - now eapply remove_match_on_box_program_wf. + - now eapply remove_match_on_box_program_expanded. Qed. Next Obligation. red. move=> fl wcon efl hastrel hastbox [Σ t] /= v [wfe wft] [ev]. - eapply EOptimizePropDiscr.optimize_correct in ev; eauto. + eapply EOptimizePropDiscr.remove_match_on_box_correct in ev; eauto. eexists; split => //. red. sq; auto. cbn. apply wfe. eapply wellformed_closed_env, wfe. eapply wellformed_closed, wfe. diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index 05789e1c6..567ca5f4f 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -57,10 +57,10 @@ Next Obligation. apply assume_preservation_template_program_env_expansion in ev as [ev']; eauto. Qed. -Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t TemplateProgram.template_program EProgram.eprogram - Ast.term EAst.term - TemplateProgram.eval_template_program +Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + Transform.t pcuic_program EProgram.eprogram + PCUICAst.term EAst.term + PCUICTransform.eval_pcuic_program (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := (* a bunch of nonsense for normalization preconditions *) let K ty (T : ty -> _) p @@ -68,15 +68,6 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf (PCUICTyping.wf_ext p -> PCUICSN.NormalizationIn p) /\ (PCUICTyping.wf_ext p -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p) in let T1 (p:global_env_ext_map) := p in - let T2 (p:global_env_ext_map) := T1 (build_global_env_map (PCUICExpandLets.trans_global_env p.1), p.2) in - let T3 (p:global_env) := T2 (TemplateToPCUIC.trans_global_env p, Monomorphic_ctx) in - let T4 (p:GlobalEnvMap.t) := T3 (eta_expand_global_env p) in - (* Build an efficient lookup map for the following eta-expansion phase *) - build_template_program_env (K _ T4) ▷ - (* Eta-expand constructors and fixpoint *) - eta_expand (K _ T3) ▷ - (* Casts are removed, application is binary, case annotations are inferred from the global environment *) - template_to_pcuic_transform (K _ T2) ▷ (* Branches of cases are expanded to bind only variables, constructor types are expanded accordingly *) pcuic_expand_lets_transform (K _ T1) ▷ (* Erasure of proofs terms in Prop and types *) @@ -90,7 +81,7 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf (* Rebuild the efficient lookup table *) rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ (* Remove all cases / projections on propositional content *) - optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ + remove_match_on_box_trans (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ (* Rebuild the efficient lookup table *) rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ (* Inline projections to cases *) @@ -114,6 +105,43 @@ Next Obligation. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. +Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + Transform.t TemplateProgram.template_program pcuic_program + Ast.term PCUICAst.term + TemplateProgram.eval_template_program + PCUICTransform.eval_pcuic_program := + (* a bunch of nonsense for normalization preconditions *) + let K ty (T : ty -> _) p + := let p := T p in + (PCUICTyping.wf_ext p -> PCUICSN.NormalizationIn p) /\ + (PCUICTyping.wf_ext p -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p) in + let T1 (p:global_env_ext_map) := p in + let T2 (p:global_env_ext_map) := T1 (build_global_env_map (PCUICExpandLets.trans_global_env p.1), p.2) in + let T3 (p:global_env) := T2 (TemplateToPCUIC.trans_global_env p, Monomorphic_ctx) in + let T4 (p:GlobalEnvMap.t) := T3 (eta_expand_global_env p) in + (* Build an efficient lookup map for the following eta-expansion phase *) + build_template_program_env (K _ T4) ▷ + (* Eta-expand constructors and fixpoint *) + eta_expand (K _ T3) ▷ + (* Casts are removed, application is binary, case annotations are inferred from the global environment *) + template_to_pcuic_transform (K _ T2). + +Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + Transform.t TemplateProgram.template_program EProgram.eprogram + Ast.term EAst.term + TemplateProgram.eval_template_program + (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := + pre_erasure_pipeline ▷ + verified_erasure_pipeline. + +(* At the end of erasure we get a well-formed program (well-scoped globally and localy), without + parameters in inductive declarations. The constructor applications are also transformed to a first-order + "block" application, of the right length, and the evaluation relation does not need to consider guarded + fixpoints or case analyses on propositional content. All fixpoint bodies start with a lambda as well. + Finally, projections are inlined to cases, so no `tProj` remains. *) + +Import EGlobalEnv EWellformed. + Definition run_erase_program {guard : abstract_guard_impl} := run erasure_pipeline. Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) := @@ -134,7 +162,7 @@ Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := E guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ remove_params_fast_optimization (wcon := eq_refl) _ ▷ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ - optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ + remove_match_on_box_trans (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ let efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags) in diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index bbf48f9af..70ad8701c 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -28,7 +28,7 @@ Ltac introdep := let H := fresh in intros H; depelim H. #[global] Hint Constructors eval : core. -Section optimize. +Section remove_match_on_box. Context (Σ : GlobalContextMap.t). Definition isprop_ind Σ (ind:inductive × nat) @@ -37,41 +37,41 @@ Section optimize. | _ => false end. - Fixpoint optimize (t : term) : term := + Fixpoint remove_match_on_box (t : term) : term := match t with | tRel i => tRel i - | tEvar ev args => tEvar ev (List.map optimize args) - | tLambda na M => tLambda na (optimize M) - | tApp u v => tApp (optimize u) (optimize v) - | tLetIn na b b' => tLetIn na (optimize b) (optimize b') + | tEvar ev args => tEvar ev (List.map remove_match_on_box args) + | tLambda na M => tLambda na (remove_match_on_box M) + | tApp u v => tApp (remove_match_on_box u) (remove_match_on_box v) + | tLetIn na b b' => tLetIn na (remove_match_on_box b) (remove_match_on_box b') | tCase ind c brs => - let brs' := List.map (on_snd optimize) brs in + let brs' := List.map (on_snd remove_match_on_box) brs in if isprop_ind Σ ind then match brs' with | [(a, b)] => ECSubst.substl (repeat tBox #|a|) b - | _ => tCase ind (optimize c) brs' + | _ => tCase ind (remove_match_on_box c) brs' end - else tCase ind (optimize c) brs' + else tCase ind (remove_match_on_box c) brs' | tProj p c => match GlobalContextMap.inductive_isprop_and_pars Σ p.(proj_ind) with | Some (true, _) => tBox - | _ => tProj p (optimize c) + | _ => tProj p (remove_match_on_box c) end | tFix mfix idx => - let mfix' := List.map (map_def optimize) mfix in + let mfix' := List.map (map_def remove_match_on_box) mfix in tFix mfix' idx | tCoFix mfix idx => - let mfix' := List.map (map_def optimize) mfix in + let mfix' := List.map (map_def remove_match_on_box) mfix in tCoFix mfix' idx | tBox => t | tVar _ => t | tConst _ => t - | tConstruct ind i args => tConstruct ind i (map optimize args) + | tConstruct ind i args => tConstruct ind i (map remove_match_on_box args) | tPrim _ => t end. - Lemma optimize_mkApps f l : optimize (mkApps f l) = mkApps (optimize f) (map optimize l). + Lemma remove_match_on_box_mkApps f l : remove_match_on_box (mkApps f l) = mkApps (remove_match_on_box f) (map remove_match_on_box l). Proof using Type. induction l using rev_ind; simpl; auto. now rewrite mkApps_app /= IHl map_app /= mkApps_app /=. @@ -82,7 +82,7 @@ Section optimize. now induction n; simpl; auto; rewrite IHn. Qed. - Lemma map_optimize_repeat_box n : map optimize (repeat tBox n) = repeat tBox n. + Lemma map_remove_match_on_box_repeat_box n : map remove_match_on_box (repeat tBox n) = repeat tBox n. Proof using Type. by rewrite map_repeat. Qed. Import ECSubst. @@ -106,7 +106,7 @@ Section optimize. destruct x0; cbn in *. f_equal; auto. Qed. - Lemma closed_optimize t k : closedn k t -> closedn k (optimize t). + Lemma closed_remove_match_on_box t k : closedn k t -> closedn k (remove_match_on_box t). Proof using Type. induction t in k |- * using EInduction.term_forall_list_ind; simpl; auto; intros; try easy; @@ -166,9 +166,9 @@ Section optimize. apply subst_csubst_comm => //. Qed. - Lemma optimize_csubst a k b : + Lemma remove_match_on_box_csubst a k b : closed a -> - optimize (ECSubst.csubst a k b) = ECSubst.csubst (optimize a) k (optimize b). + remove_match_on_box (ECSubst.csubst a k b) = ECSubst.csubst (remove_match_on_box a) k (remove_match_on_box b). Proof using Type. induction b in k |- * using EInduction.term_forall_list_ind; simpl; auto; intros cl; try easy; @@ -186,7 +186,7 @@ Section optimize. rewrite {2}H. rewrite substl_csubst_comm //. solve_all. eapply All_repeat => //. - now eapply closed_optimize. + now eapply closed_remove_match_on_box. * depelim X. depelim X. f_equal; eauto. unfold on_snd; cbn. f_equal; eauto. @@ -199,28 +199,28 @@ Section optimize. now rewrite IHb. Qed. - Lemma optimize_substl s t : + Lemma remove_match_on_box_substl s t : forallb (closedn 0) s -> - optimize (substl s t) = substl (map optimize s) (optimize t). + remove_match_on_box (substl s t) = substl (map remove_match_on_box s) (remove_match_on_box t). Proof using Type. induction s in t |- *; simpl; auto. move/andP => [] cla cls. rewrite IHs //. f_equal. - now rewrite optimize_csubst. + now rewrite remove_match_on_box_csubst. Qed. - Lemma optimize_iota_red pars args br : + Lemma remove_match_on_box_iota_red pars args br : forallb (closedn 0) args -> - optimize (EGlobalEnv.iota_red pars args br) = EGlobalEnv.iota_red pars (map optimize args) (on_snd optimize br). + remove_match_on_box (EGlobalEnv.iota_red pars args br) = EGlobalEnv.iota_red pars (map remove_match_on_box args) (on_snd remove_match_on_box br). Proof using Type. intros cl. unfold EGlobalEnv.iota_red. - rewrite optimize_substl //. + rewrite remove_match_on_box_substl //. rewrite forallb_rev forallb_skipn //. now rewrite map_rev map_skipn. Qed. - Lemma optimize_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def optimize) mfix) = map optimize (EGlobalEnv.fix_subst mfix). + Lemma remove_match_on_box_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def remove_match_on_box) mfix) = map remove_match_on_box (EGlobalEnv.fix_subst mfix). Proof using Type. unfold EGlobalEnv.fix_subst. rewrite map_length. @@ -229,7 +229,7 @@ Section optimize. f_equal; auto. Qed. - Lemma optimize_cofix_subst mfix : EGlobalEnv.cofix_subst (map (map_def optimize) mfix) = map optimize (EGlobalEnv.cofix_subst mfix). + Lemma remove_match_on_box_cofix_subst mfix : EGlobalEnv.cofix_subst (map (map_def remove_match_on_box) mfix) = map remove_match_on_box (EGlobalEnv.cofix_subst mfix). Proof using Type. unfold EGlobalEnv.cofix_subst. rewrite map_length. @@ -238,41 +238,41 @@ Section optimize. f_equal; auto. Qed. - Lemma optimize_cunfold_fix mfix idx n f : + Lemma remove_match_on_box_cunfold_fix mfix idx n f : forallb (closedn 0) (EGlobalEnv.fix_subst mfix) -> cunfold_fix mfix idx = Some (n, f) -> - cunfold_fix (map (map_def optimize) mfix) idx = Some (n, optimize f). + cunfold_fix (map (map_def remove_match_on_box) mfix) idx = Some (n, remove_match_on_box f). Proof using Type. intros hfix. unfold cunfold_fix. rewrite nth_error_map. destruct nth_error. intros [= <- <-] => /=. f_equal. - now rewrite optimize_substl // optimize_fix_subst. + now rewrite remove_match_on_box_substl // remove_match_on_box_fix_subst. discriminate. Qed. - Lemma optimize_cunfold_cofix mfix idx n f : + Lemma remove_match_on_box_cunfold_cofix mfix idx n f : forallb (closedn 0) (EGlobalEnv.cofix_subst mfix) -> cunfold_cofix mfix idx = Some (n, f) -> - cunfold_cofix (map (map_def optimize) mfix) idx = Some (n, optimize f). + cunfold_cofix (map (map_def remove_match_on_box) mfix) idx = Some (n, remove_match_on_box f). Proof using Type. intros hcofix. unfold cunfold_cofix. rewrite nth_error_map. destruct nth_error. intros [= <- <-] => /=. f_equal. - now rewrite optimize_substl // optimize_cofix_subst. + now rewrite remove_match_on_box_substl // remove_match_on_box_cofix_subst. discriminate. Qed. - Lemma optimize_nth {n l d} : - optimize (nth n l d) = nth n (map optimize l) (optimize d). + Lemma remove_match_on_box_nth {n l d} : + remove_match_on_box (nth n l d) = nth n (map remove_match_on_box l) (remove_match_on_box d). Proof using Type. induction l in n |- *; destruct n; simpl; auto. Qed. -End optimize. +End remove_match_on_box. Lemma is_box_inv b : is_box b -> ∑ args, b = mkApps tBox args. Proof. @@ -313,26 +313,26 @@ Proof. eexists; econstructor; eauto. Qed. -Definition optimize_constant_decl Σ cb := - {| cst_body := option_map (optimize Σ) cb.(cst_body) |}. +Definition remove_match_on_box_constant_decl Σ cb := + {| cst_body := option_map (remove_match_on_box Σ) cb.(cst_body) |}. -Definition optimize_decl Σ d := +Definition remove_match_on_box_decl Σ d := match d with - | ConstantDecl cb => ConstantDecl (optimize_constant_decl Σ cb) + | ConstantDecl cb => ConstantDecl (remove_match_on_box_constant_decl Σ cb) | InductiveDecl idecl => d end. -Definition optimize_env Σ := - map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls). +Definition remove_match_on_box_env Σ := + map (on_snd (remove_match_on_box_decl Σ)) Σ.(GlobalContextMap.global_decls). Import EnvMap. -Program Fixpoint optimize_env' Σ : EnvMap.fresh_globals Σ -> global_context := +Program Fixpoint remove_match_on_box_env' Σ : EnvMap.fresh_globals Σ -> global_context := match Σ with | [] => fun _ => [] | hd :: tl => fun HΣ => let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in - on_snd (optimize_decl Σg) hd :: optimize_env' tl (fresh_globals_cons_inv HΣ) + on_snd (remove_match_on_box_decl Σg) hd :: remove_match_on_box_env' tl (fresh_globals_cons_inv HΣ) end. Import EGlobalEnv EExtends. @@ -363,10 +363,10 @@ Proof. destruct nth_error => //. Qed. -Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma wellformed_remove_match_on_box_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : forall n, EWellformed.wellformed Σ n t -> forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> wf_glob Σ' -> - optimize Σ t = optimize Σ' t. + remove_match_on_box Σ t = remove_match_on_box Σ' t. Proof. induction t using EInduction.term_forall_list_ind; cbn -[lookup_constant lookup_inductive lookup_projection @@ -375,7 +375,7 @@ Proof. all:try now f_equal; eauto; solve_all. - destruct cstr_as_blocks; rtoProp; eauto. f_equal. solve_all. destruct args; inv H2. reflexivity. - rewrite !GlobalContextMap.inductive_isprop_and_pars_spec. - assert (map (on_snd (optimize Σ)) l = map (on_snd (optimize Σ')) l) as -> by solve_all. + assert (map (on_snd (remove_match_on_box Σ)) l = map (on_snd (remove_match_on_box Σ')) l) as -> by solve_all. rewrite (extends_inductive_isprop_and_pars H0 H1 H2). destruct inductive_isprop_and_pars as [[[]]|]. destruct map => //. f_equal; eauto. @@ -390,23 +390,23 @@ Proof. all:f_equal; eauto. Qed. -Lemma wellformed_optimize_decl_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma wellformed_remove_match_on_box_decl_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : wf_global_decl Σ t -> forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> wf_glob Σ' -> - optimize_decl Σ t = optimize_decl Σ' t. + remove_match_on_box_decl Σ t = remove_match_on_box_decl Σ' t. Proof. destruct t => /= //. - intros wf Σ' ext wf'. f_equal. unfold optimize_constant_decl. f_equal. + intros wf Σ' ext wf'. f_equal. unfold remove_match_on_box_constant_decl. f_equal. destruct (cst_body c) => /= //. f_equal. - now eapply wellformed_optimize_extends. + now eapply wellformed_remove_match_on_box_extends. Qed. -Lemma lookup_env_optimize_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn d : +Lemma lookup_env_remove_match_on_box_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn d : wf_glob Σ -> GlobalContextMap.lookup_env Σ kn = Some d -> ∑ Σ' : GlobalContextMap.t, [× extends Σ' Σ, wf_global_decl Σ' d & - lookup_env (optimize_env Σ) kn = Some (optimize_decl Σ' d)]. + lookup_env (remove_match_on_box_env Σ) kn = Some (remove_match_on_box_decl Σ' d)]. Proof. rewrite GlobalContextMap.lookup_env_spec. destruct Σ as [Σ map repr wf]. @@ -417,7 +417,7 @@ Proof. exists (GlobalContextMap.make Σ (fresh_globals_cons_inv wf)). split. now eexists [_]. cbn. now depelim wfg. - f_equal. symmetry. eapply wellformed_optimize_decl_extends. cbn. now depelim wfg. + f_equal. symmetry. eapply wellformed_remove_match_on_box_decl_extends. cbn. now depelim wfg. cbn. now exists [a]. now cbn. - intros _. set (Σ' := GlobalContextMap.make Σ (fresh_globals_cons_inv wf)). @@ -430,7 +430,7 @@ Proof. * rewrite -hl'. f_equal. clear -wfg. eapply map_ext_in => kn hin. unfold on_snd. f_equal. - symmetry. eapply wellformed_optimize_decl_extends => //. cbn. + symmetry. eapply wellformed_remove_match_on_box_decl_extends => //. cbn. eapply lookup_env_In in hin. 2:now depelim wfg. depelim wfg. eapply lookup_env_wellformed; tea. cbn. now exists [a]. @@ -442,48 +442,48 @@ Proof. case: eqb_spec => //. Qed. -Lemma lookup_env_optimize_env_None {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : +Lemma lookup_env_remove_match_on_box_env_None {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : GlobalContextMap.lookup_env Σ kn = None -> - lookup_env (optimize_env Σ) kn = None. + lookup_env (remove_match_on_box_env Σ) kn = None. Proof. rewrite GlobalContextMap.lookup_env_spec. destruct Σ as [Σ map repr wf]. cbn. intros hl. rewrite lookup_env_map_snd hl //. Qed. -Lemma lookup_env_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : +Lemma lookup_env_remove_match_on_box {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : wf_glob Σ -> - lookup_env (optimize_env Σ) kn = option_map (optimize_decl Σ) (lookup_env Σ kn). + lookup_env (remove_match_on_box_env Σ) kn = option_map (remove_match_on_box_decl Σ) (lookup_env Σ kn). Proof. intros wf. rewrite -GlobalContextMap.lookup_env_spec. destruct (GlobalContextMap.lookup_env Σ kn) eqn:hl. - - eapply lookup_env_optimize_env_Some in hl as [Σ' [ext wf' hl']] => /=. + - eapply lookup_env_remove_match_on_box_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. - eapply wellformed_optimize_decl_extends; eauto. auto. + eapply wellformed_remove_match_on_box_decl_extends; eauto. auto. - - cbn. now eapply lookup_env_optimize_env_None in hl. + - cbn. now eapply lookup_env_remove_match_on_box_env_None in hl. Qed. -Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : +Lemma is_propositional_remove_match_on_box {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : wf_glob Σ -> - inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (optimize_env Σ) ind. + inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (remove_match_on_box_env Σ) ind. Proof. rewrite /inductive_isprop_and_pars => wf. rewrite /lookup_inductive /lookup_minductive. - rewrite (lookup_env_optimize (inductive_mind ind) wf). + rewrite (lookup_env_remove_match_on_box (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. -Lemma is_propositional_cstr_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : +Lemma is_propositional_cstr_remove_match_on_box {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : wf_glob Σ -> - constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (optimize_env Σ) ind c. + constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (remove_match_on_box_env Σ) ind c. Proof. rewrite /constructor_isprop_pars_decl => wf. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. - rewrite (lookup_env_optimize (inductive_mind ind) wf). + rewrite (lookup_env_remove_match_on_box (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. @@ -511,12 +511,12 @@ Proof. - rewrite mkApps_app /=. now destruct l => /= //; rewrite andb_false_r. Qed. -Lemma lookup_constructor_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} {ind c} : +Lemma lookup_constructor_remove_match_on_box {efl : EEnvFlags} {Σ : GlobalContextMap.t} {ind c} : wf_glob Σ -> - lookup_constructor Σ ind c = lookup_constructor (optimize_env Σ) ind c. + lookup_constructor Σ ind c = lookup_constructor (remove_match_on_box_env Σ) ind c. Proof. intros wfΣ. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. - rewrite lookup_env_optimize // /=. destruct lookup_env => // /=. + rewrite lookup_env_remove_match_on_box // /=. destruct lookup_env => // /=. destruct g => //. Qed. @@ -529,12 +529,12 @@ Proof. destruct nth_error => //. congruence. Qed. -Lemma optimize_correct {efl : EEnvFlags} {fl}{wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v : +Lemma remove_match_on_box_correct {efl : EEnvFlags} {fl}{wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v : wf_glob Σ -> closed_env Σ -> @Ee.eval fl Σ t v -> closed t -> - @Ee.eval (disable_prop_cases fl) (optimize_env Σ) (optimize Σ t) (optimize Σ v). + @Ee.eval (disable_prop_cases fl) (remove_match_on_box_env Σ) (remove_match_on_box Σ t) (remove_match_on_box Σ v). Proof. intros wfΣ clΣ ev. induction ev; simpl in *. @@ -544,23 +544,23 @@ Proof. eapply eval_closed in ev2; tea. eapply eval_closed in ev1; tea. econstructor; eauto. - rewrite optimize_csubst // in IHev3. + rewrite remove_match_on_box_csubst // in IHev3. apply IHev3. eapply closed_csubst => //. - - move/andP => [] clb0 clb1. rewrite optimize_csubst in IHev2. + - move/andP => [] clb0 clb1. rewrite remove_match_on_box_csubst in IHev2. now eapply eval_closed in ev1. econstructor; eauto. eapply IHev2, closed_csubst => //. now eapply eval_closed in ev1. - - move/andP => [] cld clbrs. rewrite optimize_mkApps in IHev1. + - move/andP => [] cld clbrs. rewrite remove_match_on_box_mkApps in IHev1. have := (eval_closed _ clΣ _ _ cld ev1); rewrite closedn_mkApps => /andP[] _ clargs. - rewrite optimize_iota_red in IHev2. + rewrite remove_match_on_box_iota_red in IHev2. eapply eval_closed in ev1 => //. unfold isprop_ind. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. rewrite (constructor_isprop_pars_decl_inductive e1). eapply eval_iota; eauto. - now rewrite -is_propositional_cstr_optimize. + now rewrite -is_propositional_cstr_remove_match_on_box. rewrite nth_error_map e2 //. now len. cbn. rewrite -e4. rewrite !skipn_length map_length //. eapply IHev2. @@ -574,24 +574,24 @@ Proof. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. rewrite e0 e1 /=. subst brs. cbn in clbrs. rewrite Nat.add_0_r andb_true_r in clbrs. - rewrite optimize_substl in IHev2. + rewrite remove_match_on_box_substl in IHev2. eapply All_forallb, All_repeat => //. - rewrite map_optimize_repeat_box in IHev2. + rewrite map_remove_match_on_box_repeat_box in IHev2. apply IHev2. eapply closed_substl. eapply All_forallb, All_repeat => //. now rewrite repeat_length Nat.add_0_r. - - move/andP => [] clf cla. rewrite optimize_mkApps in IHev1. + - move/andP => [] clf cla. rewrite remove_match_on_box_mkApps in IHev1. simpl in *. eapply eval_closed in ev1 => //. rewrite closedn_mkApps in ev1. move: ev1 => /andP [] clfix clargs. eapply Ee.eval_fix; eauto. rewrite map_length. - eapply optimize_cunfold_fix; tea. + eapply remove_match_on_box_cunfold_fix; tea. eapply closed_fix_subst. tea. - rewrite optimize_mkApps in IHev3. apply IHev3. + rewrite remove_match_on_box_mkApps in IHev3. apply IHev3. rewrite closedn_mkApps clargs. eapply eval_closed in ev2; tas. rewrite ev2 /= !andb_true_r. eapply closed_cunfold_fix; tea. @@ -601,9 +601,9 @@ Proof. rewrite closedn_mkApps in ev1. move: ev1 => /andP [] clfix clargs. eapply eval_closed in ev2; tas. - rewrite optimize_mkApps in IHev1 |- *. + rewrite remove_match_on_box_mkApps in IHev1 |- *. simpl in *. eapply Ee.eval_fix_value. auto. auto. auto. - eapply optimize_cunfold_fix; eauto. + eapply remove_match_on_box_cunfold_fix; eauto. eapply closed_fix_subst => //. now rewrite map_length. @@ -611,7 +611,7 @@ Proof. eapply eval_closed in ev1 => //. eapply eval_closed in ev2; tas. simpl in *. eapply Ee.eval_fix'. auto. auto. - eapply optimize_cunfold_fix; eauto. + eapply remove_match_on_box_cunfold_fix; eauto. eapply closed_fix_subst => //. eapply IHev2; tea. eapply IHev3. apply/andP; split => //. @@ -625,21 +625,21 @@ Proof. forward IHev2. { rewrite clargs clbrs !andb_true_r. eapply closed_cunfold_cofix; tea. } - rewrite -> optimize_mkApps in IHev1, IHev2. simpl. unfold isprop_ind in *. + rewrite -> remove_match_on_box_mkApps in IHev1, IHev2. simpl. unfold isprop_ind in *. rewrite GlobalContextMap.inductive_isprop_and_pars_spec in IHev2 |- *. destruct EGlobalEnv.inductive_isprop_and_pars as [[[] pars]|] eqn:isp => //. destruct brs as [|[a b] []]; simpl in *; auto. simpl in IHev1. eapply Ee.eval_cofix_case. tea. - apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. + apply remove_match_on_box_cunfold_cofix; tea. eapply closed_cofix_subst; tea. apply IHev2. eapply Ee.eval_cofix_case; tea. - apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. + apply remove_match_on_box_cunfold_cofix; tea. eapply closed_cofix_subst; tea. simpl in *. eapply Ee.eval_cofix_case; tea. - apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. + apply remove_match_on_box_cunfold_cofix; tea. eapply closed_cofix_subst; tea. eapply Ee.eval_cofix_case; tea. - apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. + apply remove_match_on_box_cunfold_cofix; tea. eapply closed_cofix_subst; tea. - intros cd. specialize (IHev1 cd). move: (eval_closed _ clΣ _ _ cd ev1). @@ -647,15 +647,15 @@ Proof. { rewrite closedn_mkApps clargs andb_true_r. eapply closed_cunfold_cofix; tea. } rewrite GlobalContextMap.inductive_isprop_and_pars_spec in IHev2 |- *. destruct EGlobalEnv.inductive_isprop_and_pars as [[[] pars]|] eqn:isp; auto. - rewrite -> optimize_mkApps in IHev1, IHev2. simpl in *. + rewrite -> remove_match_on_box_mkApps in IHev1, IHev2. simpl in *. econstructor; eauto. - apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. - rewrite -> optimize_mkApps in IHev1, IHev2. simpl in *. + apply remove_match_on_box_cunfold_cofix; tea. eapply closed_cofix_subst; tea. + rewrite -> remove_match_on_box_mkApps in IHev1, IHev2. simpl in *. econstructor; eauto. - apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. + apply remove_match_on_box_cunfold_cofix; tea. eapply closed_cofix_subst; tea. - rewrite /declared_constant in isdecl. - move: (lookup_env_optimize c wfΣ). + move: (lookup_env_remove_match_on_box c wfΣ). rewrite isdecl /= //. intros hl. econstructor; tea. cbn. rewrite e //. @@ -668,10 +668,10 @@ Proof. move: ev1; rewrite closedn_mkApps /= => clargs. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. rewrite (constructor_isprop_pars_decl_inductive e1). - rewrite optimize_mkApps in IHev1. + rewrite remove_match_on_box_mkApps in IHev1. specialize (IHev1 cld). eapply Ee.eval_proj; tea. - now rewrite -is_propositional_cstr_optimize. + now rewrite -is_propositional_cstr_remove_match_on_box. now len. rewrite nth_error_map e3 //. eapply IHev2. eapply nth_error_forallb in e3; tea. @@ -682,10 +682,10 @@ Proof. now rewrite e0. - move/andP=> [] clf cla. - rewrite optimize_mkApps. + rewrite remove_match_on_box_mkApps. eapply eval_construct; tea. - rewrite -lookup_constructor_optimize //. exact e0. - rewrite optimize_mkApps in IHev1. now eapply IHev1. + rewrite -lookup_constructor_remove_match_on_box //. exact e0. + rewrite remove_match_on_box_mkApps in IHev1. now eapply IHev1. now len. now eapply IHev2. @@ -696,11 +696,11 @@ Proof. eapply Ee.eval_app_cong; eauto. eapply Ee.eval_to_value in ev1. destruct ev1; simpl in *; eauto. - * destruct t => //; rewrite optimize_mkApps /=. + * destruct t => //; rewrite remove_match_on_box_mkApps /=. * destruct with_guarded_fix. + move: i. rewrite !negb_or. - rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. + rewrite remove_match_on_box_mkApps !isFixApp_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. rewrite !andb_true_r. rtoProp; intuition auto. @@ -709,26 +709,26 @@ Proof. destruct v => /= //. + move: i. rewrite !negb_or. - rewrite optimize_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. + rewrite remove_match_on_box_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. destruct v => /= //. - destruct t => //. - all:constructor; eauto. cbn [atom optimize] in i |- *. - rewrite -lookup_constructor_optimize //. destruct l => //. + all:constructor; eauto. cbn [atom remove_match_on_box] in i |- *. + rewrite -lookup_constructor_remove_match_on_box //. destruct l => //. Qed. From MetaCoq.Erasure Require Import EEtaExpanded. -Lemma isLambda_optimize Σ t : isLambda t -> isLambda (optimize Σ t). +Lemma isLambda_remove_match_on_box Σ t : isLambda t -> isLambda (remove_match_on_box Σ t). Proof. destruct t => //. Qed. -Lemma isBox_optimize Σ t : isBox t -> isBox (optimize Σ t). +Lemma isBox_remove_match_on_box Σ t : isBox t -> isBox (remove_match_on_box Σ t). Proof. destruct t => //. Qed. -Lemma optimize_expanded {Σ : GlobalContextMap.t} t : expanded Σ t -> expanded Σ (optimize Σ t). +Lemma remove_match_on_box_expanded {Σ : GlobalContextMap.t} t : expanded Σ t -> expanded Σ (remove_match_on_box Σ t). Proof. induction 1 using expanded_ind. all:try solve[constructor; eauto; solve_all]. - all:rewrite ?optimize_mkApps. + all:rewrite ?remove_match_on_box_mkApps. - eapply expanded_mkApps_expanded => //. solve_all. - cbn -[GlobalContextMap.inductive_isprop_and_pars]. unfold isprop_ind. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. @@ -750,40 +750,40 @@ Proof. destruct inductive_isprop_and_pars as [[[|] _]|] => /= //. constructor. all:constructor; auto. - cbn. eapply expanded_tFix. solve_all. - rewrite isLambda_optimize //. + rewrite isLambda_remove_match_on_box //. - eapply expanded_tConstruct_app; tea. now len. solve_all. Qed. -Lemma optimize_expanded_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : wf_glob Σ -> expanded Σ t -> expanded (optimize_env Σ) t. +Lemma remove_match_on_box_expanded_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : wf_glob Σ -> expanded Σ t -> expanded (remove_match_on_box_env Σ) t. Proof. intros wf; induction 1 using expanded_ind. all:try solve[constructor; eauto; solve_all]. eapply expanded_tConstruct_app. destruct H as [[H ?] ?]. split => //. split => //. red. - red in H. rewrite lookup_env_optimize // /= H //. 1-2:eauto. auto. solve_all. + red in H. rewrite lookup_env_remove_match_on_box // /= H //. 1-2:eauto. auto. solve_all. Qed. -Lemma optimize_expanded_decl {Σ : GlobalContextMap.t} t : expanded_decl Σ t -> expanded_decl Σ (optimize_decl Σ t). +Lemma remove_match_on_box_expanded_decl {Σ : GlobalContextMap.t} t : expanded_decl Σ t -> expanded_decl Σ (remove_match_on_box_decl Σ t). Proof. destruct t as [[[]]|] => /= //. unfold expanded_constant_decl => /=. - apply optimize_expanded. + apply remove_match_on_box_expanded. Qed. -Lemma optimize_expanded_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : wf_glob Σ -> expanded_decl Σ t -> expanded_decl (optimize_env Σ) t. +Lemma remove_match_on_box_expanded_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : wf_glob Σ -> expanded_decl Σ t -> expanded_decl (remove_match_on_box_env Σ) t. Proof. destruct t as [[[]]|] => /= //. unfold expanded_constant_decl => /=. - apply optimize_expanded_irrel. + apply remove_match_on_box_expanded_irrel. Qed. -Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : +Lemma remove_match_on_box_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : extends Σ Σ' -> wf_glob Σ' -> - List.map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls) = - List.map (on_snd (optimize_decl Σ')) Σ.(GlobalContextMap.global_decls). + List.map (on_snd (remove_match_on_box_decl Σ)) Σ.(GlobalContextMap.global_decls) = + List.map (on_snd (remove_match_on_box_decl Σ')) Σ.(GlobalContextMap.global_decls). Proof. intros ext. destruct Σ as [Σ map repr wf]; cbn in *. @@ -798,48 +798,48 @@ Proof. f_equal. 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. } unfold on_snd. cbn. f_equal. - eapply wellformed_optimize_decl_extends => //. cbn. + eapply wellformed_remove_match_on_box_decl_extends => //. cbn. eapply extends_wf_global_decl. 3:tea. eapply extends_wf_glob; tea. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. Qed. -Lemma optimize_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> optimize_env Σ = optimize_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). +Lemma remove_match_on_box_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> remove_match_on_box_env Σ = remove_match_on_box_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). Proof. intros wf. - unfold optimize_env. + unfold remove_match_on_box_env. destruct Σ; cbn. cbn in wf. induction global_decls in map, repr, wf0, wf |- * => //. cbn. f_equal. destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. - eapply wellformed_optimize_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn. + eapply wellformed_remove_match_on_box_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn. set (Σg' := GlobalContextMap.make global_decls (fresh_globals_cons_inv wf0)). erewrite <- (IHglobal_decls (GlobalContextMap.map Σg') (GlobalContextMap.repr Σg')). 2:now depelim wf. set (Σg := {| GlobalContextMap.global_decls := _ :: _ |}). - symmetry. eapply (optimize_env_extends' (Σ := Σg') (Σ' := Σg)) => //. + symmetry. eapply (remove_match_on_box_env_extends' (Σ := Σg') (Σ' := Σg)) => //. cbn. now exists [a]. Qed. -Lemma optimize_env_expanded {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - wf_glob Σ -> expanded_global_env Σ -> expanded_global_env (optimize_env Σ). +Lemma remove_match_on_box_env_expanded {efl : EEnvFlags} {Σ : GlobalContextMap.t} : + wf_glob Σ -> expanded_global_env Σ -> expanded_global_env (remove_match_on_box_env Σ). Proof. unfold expanded_global_env; move=> wfg. - rewrite optimize_env_eq //. + rewrite remove_match_on_box_env_eq //. destruct Σ as [Σ map repr wf]. cbn in *. clear map repr. induction 1; cbn; constructor; auto. cbn in IHexpanded_global_declarations. unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. set (Σ' := GlobalContextMap.make _ _). - rewrite -(optimize_env_eq Σ'). cbn. now depelim wfg. - eapply (optimize_expanded_decl_irrel (Σ := Σ')). now depelim wfg. - now unshelve eapply (optimize_expanded_decl (Σ:=Σ')). + rewrite -(remove_match_on_box_env_eq Σ'). cbn. now depelim wfg. + eapply (remove_match_on_box_expanded_decl_irrel (Σ := Σ')). now depelim wfg. + now unshelve eapply (remove_match_on_box_expanded_decl (Σ:=Σ')). Qed. -Lemma optimize_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : +Lemma remove_match_on_box_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_tBox -> has_tRel -> - wf_glob Σ -> EWellformed.wellformed Σ n t -> EWellformed.wellformed Σ n (optimize Σ t). + wf_glob Σ -> EWellformed.wellformed Σ n t -> EWellformed.wellformed Σ n (remove_match_on_box Σ t). Proof. intros wfΣ hbox hrel. induction t in n |- * using EInduction.term_forall_list_ind => //. @@ -865,7 +865,7 @@ Proof. - cbn -[GlobalContextMap.inductive_isprop_and_pars lookup_inductive]. move/andP => [] /andP[]hasc hs ht. destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|] => /= //. all:rewrite hasc hs /=; eauto. - - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now eapply isLambda_optimize. now len. + - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now eapply isLambda_remove_match_on_box. now len. unfold test_def in *. len. eauto. - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now len. unfold test_def in *. len. eauto. @@ -873,26 +873,26 @@ Qed. Import EWellformed. -Lemma optimize_wellformed_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma remove_match_on_box_wellformed_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : wf_glob Σ -> - forall n, wellformed Σ n t -> wellformed (optimize_env Σ) n t. + forall n, wellformed Σ n t -> wellformed (remove_match_on_box_env Σ) n t. Proof. intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. all:try solve [intros; unfold wf_fix_gen in *; rtoProp; intuition eauto; solve_all]. - - rewrite lookup_env_optimize //. + - rewrite lookup_env_remove_match_on_box //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. destruct (cst_body c) => //. - - rewrite lookup_env_optimize //. + - rewrite lookup_env_remove_match_on_box //. destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. destruct g eqn:hg => /= //; intros; rtoProp; eauto. repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; len; eauto. 1: solve_all. - - rewrite lookup_env_optimize //. + - rewrite lookup_env_remove_match_on_box //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. destruct nth_error => /= //. intros; rtoProp; intuition auto; solve_all. - - rewrite lookup_env_optimize //. + - rewrite lookup_env_remove_match_on_box //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. rewrite andb_false_r => //. @@ -900,73 +900,73 @@ Proof. all:intros; rtoProp; intuition auto; solve_all. Qed. -Lemma optimize_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : +Lemma remove_match_on_box_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : wf_glob Σ -> - wf_global_decl Σ d -> wf_global_decl (optimize_env Σ) d. + wf_global_decl Σ d -> wf_global_decl (remove_match_on_box_env Σ) d. Proof. intros wf; destruct d => /= //. destruct (cst_body c) => /= //. - now eapply optimize_wellformed_irrel. + now eapply remove_match_on_box_wellformed_irrel. Qed. -Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : +Lemma remove_match_on_box_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : has_tBox -> has_tRel -> wf_glob Σ -> - forall d, wf_global_decl Σ d -> wf_global_decl (optimize_env Σ) (optimize_decl Σ d). + forall d, wf_global_decl Σ d -> wf_global_decl (remove_match_on_box_env Σ) (remove_match_on_box_decl Σ d). Proof. intros hasb hasr wf d. intros hd. - eapply optimize_wellformed_decl_irrel; tea. + eapply remove_match_on_box_wellformed_decl_irrel; tea. move: hd. destruct d => /= //. destruct (cst_body c) => /= //. - now eapply optimize_wellformed => //. + now eapply remove_match_on_box_wellformed => //. Qed. -Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : +Lemma fresh_global_remove_match_on_box_env {Σ : GlobalContextMap.t} kn : fresh_global kn Σ -> - fresh_global kn (optimize_env Σ). + fresh_global kn (remove_match_on_box_env Σ). Proof. destruct Σ as [Σ map repr wf]; cbn in *. induction 1; cbn; constructor; auto. now eapply Forall_map; cbn. Qed. -Lemma optimize_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : +Lemma remove_match_on_box_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : has_tBox -> has_tRel -> - wf_glob Σ -> wf_glob (optimize_env Σ). + wf_glob Σ -> wf_glob (remove_match_on_box_env Σ). Proof. intros hasb hasrel. - intros wfg. rewrite optimize_env_eq //. + intros wfg. rewrite remove_match_on_box_env_eq //. destruct Σ as [Σ map repr wf]; cbn in *. clear map repr. induction wfg; cbn; constructor; auto. - - rewrite /= -(optimize_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. - eapply optimize_decl_wf => //. - - rewrite /= -(optimize_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. - now eapply fresh_global_optimize_env. + - rewrite /= -(remove_match_on_box_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. + eapply remove_match_on_box_decl_wf => //. + - rewrite /= -(remove_match_on_box_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. + now eapply fresh_global_remove_match_on_box_env. Qed. -Definition optimize_program (p : eprogram_env) := - (EOptimizePropDiscr.optimize_env p.1, EOptimizePropDiscr.optimize p.1 p.2). +Definition remove_match_on_box_program (p : eprogram_env) := +(remove_match_on_box_env p.1, remove_match_on_box p.1 p.2). -Definition optimize_program_wf {efl} (p : eprogram_env) {hastbox : has_tBox} {hastrel : has_tRel} : - wf_eprogram_env efl p -> wf_eprogram efl (optimize_program p). +Definition remove_match_on_box_program_wf {efl} (p : eprogram_env) {hastbox : has_tBox} {hastrel : has_tRel} : + wf_eprogram_env efl p -> wf_eprogram efl (remove_match_on_box_program p). Proof. intros []; split. - now eapply optimize_env_wf. - cbn. eapply optimize_wellformed_irrel => //. now eapply optimize_wellformed. + now eapply remove_match_on_box_env_wf. + cbn. eapply remove_match_on_box_wellformed_irrel => //. now eapply remove_match_on_box_wellformed. Qed. -Definition optimize_program_expanded {efl} (p : eprogram_env) : +Definition remove_match_on_box_program_expanded {efl} (p : eprogram_env) : wf_eprogram_env efl p -> - expanded_eprogram_env_cstrs p -> expanded_eprogram_cstrs (optimize_program p). + expanded_eprogram_env_cstrs p -> expanded_eprogram_cstrs (remove_match_on_box_program p). Proof. unfold expanded_eprogram_env_cstrs. move=> [wfe wft] /andP[] etae etat. apply/andP; split. - cbn. eapply expanded_global_env_isEtaExp_env, optimize_env_expanded => //. + cbn. eapply expanded_global_env_isEtaExp_env, remove_match_on_box_env_expanded => //. now eapply isEtaExp_env_expanded_global_env. eapply expanded_isEtaExp. - eapply optimize_expanded_irrel => //. - now apply optimize_expanded, isEtaExp_expanded. + eapply remove_match_on_box_expanded_irrel => //. + now apply remove_match_on_box_expanded, isEtaExp_expanded. Qed. diff --git a/erasure/theories/EWcbvEvalNamed.v b/erasure/theories/EWcbvEvalNamed.v index 08e77b7d4..c3578d341 100644 --- a/erasure/theories/EWcbvEvalNamed.v +++ b/erasure/theories/EWcbvEvalNamed.v @@ -78,6 +78,8 @@ Section Wcbv. lookup Γ na = Some v -> eval Γ (tVar na) v + | eval_vbox : eval Γ tBox vBox + | eval_box a t t' : eval Γ a vBox -> eval Γ t t' -> @@ -148,7 +150,10 @@ Section Wcbv. Program Definition eval_ind := λ (P : ∀ (Γ : environment) (t : term) (v : value), eval Γ t v → Type) (f : ∀ (Γ : environment) (na : string) (v : value) (e : lookup Γ na = Some v), - P Γ (tVar na) v (eval_var Γ na v e)) (f0 : ∀ (Γ : environment) (a t : term) + P Γ (tVar na) v (eval_var Γ na v e)) + + (f_vbox : ∀ (Γ : environment) (e : eval Γ tBox vBox), P Γ tBox vBox e) + (f0 : ∀ (Γ : environment) (a t : term) (t' : value) (e : eval Γ a vBox), P Γ a vBox e → ∀ e0 : eval Γ t t', @@ -249,6 +254,7 @@ Section Wcbv. fix F (Γ : environment) (t : term) (v : value) (e : eval Γ t v) {struct e} : P Γ t v e := match e as e0 in (eval _ t0 v0) return (P Γ t0 v0 e0) with | @eval_var _ na v0 e0 => f Γ na v0 e0 + | @eval_vbox _ => f_vbox Γ _ | @eval_box _ a t0 t' e0 e1 => f0 Γ a t0 t' e0 (F Γ a vBox e0) e1 (F Γ t0 t' e1) | @eval_beta _ f10 na b a a' res Γ' e0 e1 e2 => f1 Γ f10 na b a a' res Γ' e0 (F Γ f10 (vClos na b Γ') e0) e1 (F Γ a a' e1) e2 (F (add na a' Γ') b res e2) | @eval_lambda _ na b => f2 Γ na b @@ -963,7 +969,7 @@ Proof. { clear. generalize ((List.rev (gen_many_fresh Γ ( (map dname m))) ++ Γ)). induction m in Γ |- *; cbn. - econstructor. - - intros. destruct a; cbn. destruct dname; cbn; try econstructor; eauto. + - intros. destruct a; cbn. destruct dname; cbn; try econstructor; eauto. } { solve_all. unfold wf_fix in *. rtoProp. solve_all. clear H0. unfold test_def in *. cbn in *. eapply All_impl in H1. 2:{ intros ? [[] ]. @@ -974,7 +980,7 @@ Proof. generalize ((List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). intros. induction H1 in Γ |- *. - econstructor. - - cbn. destruct x; cbn. destruct dname; cbn; econstructor; eauto. + - cbn. destruct x; cbn. destruct dname; cbn; econstructor; eauto. } Qed. @@ -1226,7 +1232,9 @@ Definition dupfree (Γ : list ident) := Fixpoint sunny Γ (t : term) : bool := match t with - | tRel i => true + | tBox => true + | tRel _ => true + | tVar na => true | tEvar ev args => List.forallb (sunny Γ) args | tLambda (nNamed na) M => fresh na Γ && sunny (na :: Γ) M | tApp u v => sunny Γ u && sunny Γ v @@ -1244,8 +1252,7 @@ Fixpoint sunny Γ (t : term) : bool := dupfree names && forallb (test_def (sunny (names ++ Γ))) mfix | tConstruct _ _ args => forallb (sunny Γ) args - | tConst _ => true - | _ => false + | _ => true end. Inductive wf : value -> Type := @@ -1363,6 +1370,13 @@ Proof. revert HE Hsunny. pattern E, s, v, Heval. revert E s v Heval. eapply eval_ind; intros; eauto; cbn in *; rtoProp; eauto using Forall. + - induction HE. + + cbn in *. congruence. + + unfold lookup in e. cbn in e. destruct x. + destruct eqb eqn:E. + * invs e. cbn in *; eauto. + * eapply IHHE. exact e. + - econstructor. - let X := match reverse goal with H : All _ _ -> _ -> _ |- _ => H end in do 2 forward X; eauto; inv X. let X1 := multimatch goal with H : _ |- _ => H end in @@ -1514,6 +1528,8 @@ Proof. Qed. *) +(*) + Lemma represents_add_fresh nms Γ E vs s t : Γ ;;; E ⊩ s ~ t -> sunny nms s -> @@ -1523,6 +1539,7 @@ Proof. revert Γ E s t. refine (@represents_ind _ (fun _ _ _ => True) _ _ _ _ _ _ _ _ _ _ _ _ _ _). all: intros; cbn in *; rtoProp; eauto. + - econstructor; eauto. - econstructor; eauto. eapply H; eauto. eapply sunny_subset; eauto. firstorder. - econstructor; eauto. eapply H0; eauto. @@ -1549,6 +1566,8 @@ Proof. eapply incl_appr, incl_refl. Qed. +*) + Lemma NoDup_In_1 {A} (l1 l2 : list A) a : NoDup (l1 ++ l2) -> In a l1 -> ~ In a l2. Proof. @@ -1853,6 +1872,8 @@ Proof. unfold cstr_arity in *. invs H. lia. clear - Hvs; induction Hvs; econstructor; eauto. eapply r. - invs Hrep; cbn in *; try congruence; rtoProp. + + econstructor. split; eauto. eapply eval_vbox. + + econstructor. split; eauto. econstructor. eauto. + econstructor. split; eauto. econstructor. + destruct args'; congruence. + solve_all. eexists. split. 2: econstructor; eauto. 4: solve_all. @@ -1868,5 +1889,130 @@ Proof. cbn in *. destruct H1 as (([? []] & ?) & ?). rewrite app_nil_r in r. all: eauto. - Unshelve. all: repeat econstructor. + Unshelve. all: repeat econstructor. Qed. + +Lemma concat_sing {X} l : + List.concat (map (fun x :X => [x]) l) = l. +Proof. + induction l; cbn in *; try congruence. +Qed. + +Lemma sunny_annotate Γ s : + sunny Γ (annotate Γ s). +Proof. + induction s in Γ |- * using EInduction.term_forall_list_ind; cbn; eauto; rtoProp. + - destruct nth_error; cbn; eauto. + - solve_all. + - split; eauto. destruct n; eauto. + unfold fresh. destruct in_dec; cbn; eauto. + eapply gen_fresh_fresh in i; eauto. + destruct in_dec; cbn; eauto. + unfold fresh. destruct in_dec; cbn; eauto. + eapply gen_fresh_fresh in i1; eauto. + unfold fresh. destruct in_dec; cbn; eauto. exfalso; eauto. + - split; eauto. destruct n; eauto. + unfold fresh. destruct in_dec; cbn; eauto. + eapply gen_fresh_fresh in i; eauto. + destruct in_dec; cbn; eauto. + unfold fresh. destruct in_dec; cbn; eauto. + eapply gen_fresh_fresh in i1; eauto. + unfold fresh. destruct in_dec; cbn; eauto. exfalso; eauto. + - split; eauto. + - solve_all. + - split; eauto. solve_all. rtoProp. repeat split; eauto. + + solve_all. eapply In_All. intros. + unfold fresh. destruct in_dec; cbn; eauto. + exfalso. eapply NoDup_gen_many_fresh; eauto. + + unfold dupfree. destruct dupfree_dec_ident; eauto. + exfalso. eapply n. + rewrite flat_map_concat_map. rewrite map_map. + rewrite concat_sing. + eapply NoDup_gen_many_fresh; eauto. + + rewrite flat_map_concat_map map_map concat_sing. + eapply sunny_subset. eapply H. + intros ? ? %in_app_iff. eapply in_app_iff. rewrite <- in_rev in H0. + eauto. + - repeat split; eauto. + 1:{ unfold map_def_name. generalize (annotate (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). + cbn. intros. solve_all. + clear. induction m in Γ |- *. + - cbn. econstructor. + - cbn. destruct a; cbn. destruct dname; cbn. + + econstructor; cbn. + unfold fresh. destruct in_dec; eauto; cbn. exfalso. + eapply gen_fresh_fresh; eauto. + specialize (IHm (gen_fresh "wildcard" Γ :: Γ)). + solve_all. destruct x, dname; cbn in *; try congruence. + unfold fresh in *. repeat (destruct in_dec; cbn in *; try congruence). + exfalso. eapply n. eauto. + + econstructor; cbn. + { destruct in_dec; cbn. + + unfold fresh. destruct in_dec; eauto; cbn. exfalso. + eapply gen_fresh_fresh; eauto. + + unfold fresh. destruct in_dec; eauto; cbn. exfalso. eauto. } + specialize (IHm ((if is_left (in_dec (ReflectEq_EqDec IdentOT.reflect_eq_string) i Γ) then gen_fresh i Γ else i) :: Γ)). + solve_all. destruct x, dname; cbn in *; try congruence. + destruct in_dec; cbn in *. + * unfold fresh in *. + repeat (destruct in_dec; cbn in *; try congruence). + exfalso. eapply n. eauto. + * unfold fresh in *. + repeat (destruct in_dec; cbn in *; try congruence). + exfalso. eapply n0. eauto. + } + { unfold map_def_name. generalize (annotate (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). + intros t0. + assert ((flat_map (λ d : def term, match dname d with + | nAnon => [] + | nNamed i => [i] + end) +(map2 (λ (d : def term) (na : ident), {| dname := nNamed na; dbody := t0 (dbody d); rarg := rarg d |}) m (gen_many_fresh Γ (map dname m)))) = (gen_many_fresh Γ (map dname m))) as ->. + { pose proof (gen_many_fresh_length Γ (map dname m)). rewrite map_length in H. revert H. + generalize (gen_many_fresh Γ (map dname m)). clear. induction m; destruct l; cbn; try congruence. + intros. f_equal. eapply IHm. lia. } + + unfold dupfree. intros. destruct dupfree_dec_ident; cbn; eauto. + exfalso. apply n0. + eapply NoDup_gen_many_fresh. + } + { + unfold map_def_name. + assert ((flat_map (λ d : def term, match dname d with + | nAnon => [] + | nNamed i => [i] + end) +(map2 (λ (d : def term) (na : ident), {| dname := nNamed na; dbody := annotate (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ) (dbody d); rarg := rarg d |}) m (gen_many_fresh Γ (map dname m)))) = (gen_many_fresh Γ (map dname m))) as ->. + { generalize (annotate (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). + pose proof (gen_many_fresh_length Γ (map dname m)). rewrite map_length in H. revert H. + generalize (gen_many_fresh Γ (map dname m)). clear. induction m; destruct l; cbn; try congruence. + intros. f_equal. eapply IHm. lia. } + + solve_all. + eapply (All_impl(P := (λ x : def term, test_def (sunny (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)) x))). + 2:{ intros x H. unfold test_def. eapply sunny_subset. eassumption. + intros ? ? % in_app_iff. eapply in_app_iff. rewrite <- in_rev. eauto. } + + generalize (List.rev (gen_many_fresh Γ (map dname m))). + pose proof (gen_many_fresh_length Γ (map dname m)). rewrite map_length in H. revert H. + generalize (gen_many_fresh Γ (map dname m)). clear - X. induction X. + + intros l. destruct l; cbn in *; try congruence. econstructor. + + intros []; cbn in *; try congruence. intros. econstructor; eauto. + } +Qed. + +Lemma eval_to_eval_named_full (Σ Σ' : global_context) s t : + wf_glob Σ -> + Forall (fun d => match d.2 with ConstantDecl (Build_constant_body (Some d)) => sunny [] d | _ => true end) Σ' -> + All2 (fun d d' => d.1 = d'.1 × match d.2 with ConstantDecl (Build_constant_body (Some body)) => + ∑ body', d'.2 = ConstantDecl (Build_constant_body (Some body')) × [] ;;; [] ⊩ body' ~ body + | decl => d'.2 = decl + end) Σ Σ' -> + EWcbvEval.eval Σ s t -> + wellformed Σ 0 s -> + ∑ v, ⊩ v ~ t × eval Σ' [] (annotate [] s) v. +Proof. + intros. eapply eval_to_eval_named; eauto. + eapply sunny_annotate. + eapply nclosed_represents. eauto. +Qed. \ No newline at end of file diff --git a/erasure/theories/Typed/Extraction.v b/erasure/theories/Typed/Extraction.v index 07d2524ff..2e7c75a9d 100644 --- a/erasure/theories/Typed/Extraction.v +++ b/erasure/theories/Typed/Extraction.v @@ -89,7 +89,7 @@ Program Definition extract_pcuic_env (ignore : kername -> bool) : result ExAst.global_env _ := let Σ := timed "Erasure" (fun _ => erase_global_decls_deps_recursive (declarations Σ) (universes Σ) (retroknowledge Σ) wfΣ seeds ignore) in if optimize_prop_discr params then - let Σ := timed "Removal of prop discrimination" (fun _ => OptimizePropDiscr.optimize_env Σ _) in + let Σ := timed "Removal of prop discrimination" (fun _ => OptimizePropDiscr.remove_match_on_box_env Σ _) in compose_transforms (extract_transforms params) Σ else Ok Σ. diff --git a/erasure/theories/Typed/OptimizePropDiscr.v b/erasure/theories/Typed/OptimizePropDiscr.v index a2fd1965c..b5036ae65 100644 --- a/erasure/theories/Typed/OptimizePropDiscr.v +++ b/erasure/theories/Typed/OptimizePropDiscr.v @@ -3,13 +3,13 @@ From MetaCoq.Erasure.Typed Require Import ExAst. From MetaCoq.Erasure Require Import EOptimizePropDiscr. -Definition optimize_constant_body Σ cst := +Definition remove_match_on_box_constant_body Σ cst := {| cst_type := cst_type cst; - cst_body := option_map (optimize Σ) (cst_body cst) |}. + cst_body := option_map (remove_match_on_box Σ) (cst_body cst) |}. -Definition optimize_decl Σ d := +Definition remove_match_on_box_decl Σ d := match d with - | ConstantDecl cst => ConstantDecl (optimize_constant_body Σ cst) + | ConstantDecl cst => ConstantDecl (remove_match_on_box_constant_body Σ cst) | _ => d end. @@ -36,21 +36,21 @@ Proof. now apply trans_env_fresh_global. Qed. -Program Definition optimize_env (Σ : global_env) (fgΣ : fresh_globals Σ) : global_env := - List.map (MCProd.on_snd (optimize_decl (EEnvMap.GlobalContextMap.make (trans_env Σ) _))) Σ. +Program Definition remove_match_on_box_env (Σ : global_env) (fgΣ : fresh_globals Σ) : global_env := + List.map (MCProd.on_snd (remove_match_on_box_decl (EEnvMap.GlobalContextMap.make (trans_env Σ) _))) Σ. Next Obligation. now apply trans_env_fresh_globals. Qed. Module Ee := EWcbvEval. -Lemma trans_env_optimize_env Σ fgΣ : - trans_env (optimize_env Σ fgΣ) = - EOptimizePropDiscr.optimize_env (EEnvMap.GlobalContextMap.make (trans_env Σ) (trans_env_fresh_globals _ fgΣ)). +Lemma trans_env_remove_match_on_box_env Σ fgΣ : + trans_env (remove_match_on_box_env Σ fgΣ) = + EOptimizePropDiscr.remove_match_on_box_env (EEnvMap.GlobalContextMap.make (trans_env Σ) (trans_env_fresh_globals _ fgΣ)). Proof. unfold trans_env. - unfold EOptimizePropDiscr.optimize_env. - unfold optimize_env. + unfold EOptimizePropDiscr.remove_match_on_box_env. + unfold remove_match_on_box_env. unfold MCProd.on_snd. cbn. rewrite !List.map_map. apply List.map_ext. @@ -62,7 +62,7 @@ Proof. now destruct o. Qed. -Lemma optimize_correct `{EWellformed.EEnvFlags} `{Ee.WcbvFlags} Σ fgΣ t v : +Lemma remove_match_on_box_correct `{EWellformed.EEnvFlags} `{Ee.WcbvFlags} Σ fgΣ t v : EWcbvEval.with_constructor_as_block = false -> ELiftSubst.closed t = true -> EGlobalEnv.closed_env (trans_env Σ) = true -> @@ -70,12 +70,12 @@ Lemma optimize_correct `{EWellformed.EEnvFlags} `{Ee.WcbvFlags} Σ fgΣ t v : @Prelim.Ee.eval _ (trans_env Σ) t v -> @Prelim.Ee.eval (EWcbvEval.disable_prop_cases _) - (trans_env (optimize_env Σ fgΣ)) - (optimize (EEnvMap.GlobalContextMap.make (trans_env Σ) (trans_env_fresh_globals _ fgΣ)) t) - (optimize (EEnvMap.GlobalContextMap.make (trans_env Σ) (trans_env_fresh_globals _ fgΣ)) v). + (trans_env (remove_match_on_box_env Σ fgΣ)) + (remove_match_on_box (EEnvMap.GlobalContextMap.make (trans_env Σ) (trans_env_fresh_globals _ fgΣ)) t) + (remove_match_on_box (EEnvMap.GlobalContextMap.make (trans_env Σ) (trans_env_fresh_globals _ fgΣ)) v). Proof. intros ? cl_t cl_env wfg ev. - rewrite trans_env_optimize_env. + rewrite trans_env_remove_match_on_box_env. remember (EEnvMap.GlobalContextMap.make _ _) as Σ0. - unshelve eapply EOptimizePropDiscr.optimize_correct;subst;cbn;eauto. + unshelve eapply EOptimizePropDiscr.remove_match_on_box_correct;subst;cbn;eauto. Qed. diff --git a/erasure/theories/Typed/TypeAnnotations.v b/erasure/theories/Typed/TypeAnnotations.v index 3815a4a8e..e6b195cd1 100644 --- a/erasure/theories/Typed/TypeAnnotations.v +++ b/erasure/theories/Typed/TypeAnnotations.v @@ -699,7 +699,7 @@ Module AnnotOptimizePropDiscr. intros ? a'; exact (f _ _ a'). Defined. - Definition annot_optimize Σ {t} (a : annots box_type t) : annots box_type (optimize Σ t). + Definition annot_remove_match_on_box Σ {t} (a : annots box_type t) : annots box_type (remove_match_on_box Σ t). Proof. revert t a. fix f 1. @@ -708,7 +708,7 @@ Module AnnotOptimizePropDiscr. - exact (a.1, f _ a.2). - exact (a.1, (f _ a.2.1, f _ a.2.2)). - exact (a.1, (f _ a.2.1, f _ a.2.2)). - - assert (br_annots : bigprod (fun br => annots box_type br.2) (map (on_snd (optimize Σ)) l)). + - assert (br_annots : bigprod (fun br => annots box_type br.2) (map (on_snd (remove_match_on_box Σ)) l)). { refine (bigprod_map _ a.2.2). intros ? a'; apply (f _ a'). } unfold isprop_ind. @@ -743,32 +743,32 @@ Module AnnotOptimizePropDiscr. intros ? a'; exact (f _ a'). Defined. - Definition annot_optimize_constant_body Σ {cst} (a : constant_body_annots box_type cst) : - constant_body_annots box_type (optimize_constant_body Σ cst). + Definition annot_remove_match_on_box_constant_body Σ {cst} (a : constant_body_annots box_type cst) : + constant_body_annots box_type (remove_match_on_box_constant_body Σ cst). Proof. - unfold constant_body_annots, optimize_constant_body in *. + unfold constant_body_annots, remove_match_on_box_constant_body in *. cbn. destruct ExAst.cst_body; cbn; [|exact tt]. - apply annot_optimize. + apply annot_remove_match_on_box. exact a. Defined. - Definition annot_optimize_decl Σ {decl} (a : global_decl_annots box_type decl) : - global_decl_annots box_type (optimize_decl Σ decl). + Definition annot_remove_match_on_box_decl Σ {decl} (a : global_decl_annots box_type decl) : + global_decl_annots box_type (remove_match_on_box_decl Σ decl). Proof. - unfold global_decl_annots, optimize_decl in *. + unfold global_decl_annots, remove_match_on_box_decl in *. destruct decl; [|exact tt|exact tt]. - apply annot_optimize_constant_body. + apply annot_remove_match_on_box_constant_body. exact a. Defined. - Definition annot_optimize_env Σ fgΣ (a : env_annots box_type Σ) : - env_annots box_type (optimize_env Σ fgΣ). + Definition annot_remove_match_on_box_env Σ fgΣ (a : env_annots box_type Σ) : + env_annots box_type (remove_match_on_box_env Σ fgΣ). Proof. - unfold env_annots, optimize_env. + unfold env_annots, remove_match_on_box_env. apply bigprod_map. - intros. - apply annot_optimize_decl. + apply annot_remove_match_on_box_decl. exact X. - exact a. Defined. @@ -803,7 +803,7 @@ Proof. unfold extract_pcuic_env. destruct optimize_prop_discr. + apply annot_compose_transforms; [|exact all]. - apply AnnotOptimizePropDiscr.annot_optimize_env. + apply AnnotOptimizePropDiscr.annot_remove_match_on_box_env. apply annotate_types_erase_global_decls_deps_recursive. + apply annotate_types_erase_global_decls_deps_recursive. Defined. From a813bffeff2c7167a096eb78e38a6eb5fb43150b Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Thu, 6 Jul 2023 15:08:46 +0200 Subject: [PATCH 32/65] Add pass implementing boxes as fixpoints --- erasure-plugin/theories/ETransform.v | 23 ++ erasure/_CoqProject.in | 1 + erasure/theories/EImplementBox.v | 584 +++++++++++++++++++++++++++ 3 files changed, 608 insertions(+) create mode 100644 erasure/theories/EImplementBox.v diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index 521481293..7ca17ed50 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -431,3 +431,26 @@ Next Obligation. cbn -[transform_blocks]. eapply transform_blocks_eval; cbn; eauto. Qed. + +From MetaCoq.Erasure Require Import EImplementBox. + +Program Definition implement_box_transformation (efl : EEnvFlags) + {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = true} : + Transform.t eprogram eprogram EAst.term EAst.term (eval_eprogram block_wcbv_flags) (eval_eprogram block_wcbv_flags) := + {| name := "transforming to constuctors as blocks"; + transform p _ := EImplementBox.implement_box_program p ; + pre p := wf_eprogram efl p ; + post p := wf_eprogram (switch_off_box efl) p ; + obseq g g' v v' := v' = implement_box v |}. + +Next Obligation. + intros. cbn in *. destruct p. split. + - eapply transform_wf_global; eauto. + - eapply transform_wellformed; eauto. +Qed. +Next Obligation. + red. intros. destruct pr. destruct H. + eexists. split; [ | eauto]. + econstructor. + eapply implement_box_eval; cbn; eauto. +Qed. \ No newline at end of file diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in index ed4879dcb..ed2993839 100644 --- a/erasure/_CoqProject.in +++ b/erasure/_CoqProject.in @@ -35,6 +35,7 @@ theories/EInlineProjections.v theories/EConstructorsAsBlocks.v theories/EWcbvEvalCstrsAsBlocksInd.v theories/EWcbvEvalCstrsAsBlocksFixLambdaInd.v +theories/EImplementBox.v theories/Typed/Annotations.v theories/Typed/ClosedAux.v diff --git a/erasure/theories/EImplementBox.v b/erasure/theories/EImplementBox.v new file mode 100644 index 000000000..3d854bbb3 --- /dev/null +++ b/erasure/theories/EImplementBox.v @@ -0,0 +1,584 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Utf8 Program. +From MetaCoq.Utils Require Import utils. +From MetaCoq.Common Require Import config Kernames BasicAst EnvMap. +From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. + +Local Open Scope string_scope. +Set Asymmetric Patterns. +Import MCMonadNotation. + +From Equations Require Import Equations. +Set Equations Transparent. +Local Set Keyed Unification. +From Coq Require Import ssreflect ssrbool. + +(** We assume [Prop size x < size y) := + | tRel i => EAst.tRel i + | tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => implement_box x)) + | tLambda na M => EAst.tLambda na (implement_box M) + | tApp u v := tApp (implement_box u) (implement_box v) + | tLetIn na b b' => EAst.tLetIn na (implement_box b) (implement_box b') + | tCase ind c brs => + let brs' := map_InP brs (fun x H => (x.1, implement_box x.2)) in + EAst.tCase (ind.1, 0) (implement_box c) brs' + | tProj p c => EAst.tProj {| proj_ind := p.(proj_ind); proj_npars := 0; proj_arg := p.(proj_arg) |} (implement_box c) + | tFix mfix idx => + let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := implement_box d.(dbody); rarg := d.(rarg) |}) in + EAst.tFix mfix' idx + | tCoFix mfix idx => + let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := implement_box d.(dbody); rarg := d.(rarg) |}) in + EAst.tCoFix mfix' idx + | tBox => iBox + | tVar n => EAst.tVar n + | tConst n => EAst.tConst n + | tConstruct ind i block_args => EAst.tConstruct ind i (map_InP block_args (fun d H => implement_box d)) + | tPrim p => EAst.tPrim p. + Proof. + all:try lia. + all:try apply (In_size); tea. + all:try lia. + - now apply (In_size id size). + - now eapply (In_size id size). + - eapply (In_size snd size) in H. cbn in *. lia. + Qed. + + End Def. + + Hint Rewrite @map_InP_spec : implement_box. + + Arguments eqb : simpl never. + + Opaque implement_box. + Opaque isEtaExp. + Opaque isEtaExp_unfold_clause_1. + + Lemma chop_firstn_skipn {A} n (l : list A) : chop n l = (firstn n l, skipn n l). + Proof using Type. + induction n in l |- *; destruct l; simpl; auto. + now rewrite IHn skipn_S. + Qed. + + Lemma chop_eq {A} n (l : list A) l1 l2 : chop n l = (l1, l2) -> l = l1 ++ l2. + Proof using Type. + rewrite chop_firstn_skipn. intros [= <- <-]. + now rewrite firstn_skipn. + Qed. + + Lemma closed_implement_box t k : closedn k t -> closedn k (implement_box t). + Proof using Type. + funelim (implement_box t); simp implement_box; rewrite <-?implement_box_equation_1; toAll; simpl; + intros; try easy; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + unfold test_def in *; + simpl closed in *; + try solve [simpl; subst; simpl closed; f_equal; auto; rtoProp; solve_all; solve_all]; try easy. + Qed. + + Hint Rewrite @forallb_InP_spec : isEtaExp. + Transparent isEtaExp_unfold_clause_1. + + Lemma implement_box_csubst a k b : + implement_box (ECSubst.csubst a k b) = ECSubst.csubst (implement_box a) k (implement_box b). + Proof using Type. + revert a k. + funelim (implement_box b); intros a k; cbn; simp implement_box; try easy. + - destruct Nat.compare => //. + - f_equal. rewrite !map_map_compose. solve_all. + eapply In_All. eauto. + - cbn. f_equal. rewrite !map_map. solve_all. + eapply In_All. intros ? ?. unfold map_def. cbn. f_equal. rewrite H; eauto. + - cbn. rewrite H0. f_equal. rewrite !map_map. solve_all. + eapply In_All. cbn. intros ? ?. f_equal. rewrite H; eauto. + - cbn. f_equal. rewrite !map_map. solve_all. + eapply In_All. intros ? ?. unfold map_def. cbn. f_equal. rewrite H; eauto. + f_equal. now rewrite map_length. + - cbn. f_equal. rewrite !map_map. solve_all. + eapply In_All. intros ? ?. unfold map_def. cbn. f_equal. rewrite H; eauto. + f_equal. now rewrite map_length. + Qed. + + Lemma implement_box_substl s t : + implement_box (substl s t) = substl (map implement_box s) (implement_box t). + Proof using Type. + induction s in t |- *; simpl; auto. + rewrite IHs //. f_equal. + now rewrite implement_box_csubst. + Qed. + + Lemma implement_box_iota_red pars args br : + implement_box (EGlobalEnv.iota_red pars args br) = EGlobalEnv.iota_red pars (map implement_box args) (on_snd implement_box br). + Proof using Type. + unfold EGlobalEnv.iota_red. + rewrite implement_box_substl //. + now rewrite map_rev map_skipn. + Qed. + + Lemma implement_box_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def implement_box) mfix) = map implement_box (EGlobalEnv.fix_subst mfix). + Proof using Type. + unfold EGlobalEnv.fix_subst. + rewrite map_length. + generalize #|mfix|. + induction n; simpl; auto. + f_equal; auto. now simp implement_box. + Qed. + + Lemma implement_box_cofix_subst mfix : EGlobalEnv.cofix_subst (map (map_def implement_box) mfix) = map implement_box (EGlobalEnv.cofix_subst mfix). + Proof using Type. + unfold EGlobalEnv.cofix_subst. + rewrite map_length. + generalize #|mfix|. + induction n; simpl; auto. + f_equal; auto. now simp implement_box. + Qed. + + Lemma implement_box_cunfold_fix mfix idx n f : + cunfold_fix mfix idx = Some (n, f) -> + cunfold_fix (map (map_def implement_box) mfix) idx = Some (n, implement_box f). + Proof using Type. + unfold cunfold_fix. + rewrite nth_error_map. + destruct nth_error eqn:heq. + intros [= <- <-] => /=. f_equal. f_equal. + rewrite implement_box_substl //. 2:congruence. + f_equal. f_equal. apply implement_box_fix_subst. + Qed. + + Lemma implement_box_cunfold_cofix mfix idx n f : + cunfold_cofix mfix idx = Some (n, f) -> + cunfold_cofix (map (map_def implement_box) mfix) idx = Some (n, implement_box f). + Proof using Type. + unfold cunfold_cofix. + rewrite nth_error_map. + destruct nth_error eqn:heq. + intros [= <- <-] => /=. f_equal. + rewrite implement_box_substl //. 2:congruence. + f_equal. f_equal. apply implement_box_cofix_subst. + Qed. + + Lemma implement_box_nth {n l d} : + implement_box (nth n l d) = nth n (map implement_box l) (implement_box d). + Proof using Type. + induction l in n |- *; destruct n; simpl; auto. + Qed. + +End implement_box. + +Definition implement_box_constant_decl cb := + {| cst_body := option_map implement_box cb.(cst_body) |}. + +Definition implement_box_decl d := + match d with + | ConstantDecl cb => ConstantDecl (implement_box_constant_decl cb) + | InductiveDecl idecl => d + end. + +Definition implement_box_env (Σ : global_declarations) := + map (on_snd (implement_box_decl)) Σ. + +Definition implement_box_program (p : eprogram) := + (implement_box_env p.1, implement_box p.2). + +Definition block_wcbv_flags := + {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := true |}. + +Local Hint Resolve wellformed_closed : core. + +Lemma wellformed_lookup_inductive_pars {efl : EEnvFlags} Σ kn mdecl : + has_cstr_params = false -> + wf_glob Σ -> + lookup_minductive Σ kn = Some mdecl -> mdecl.(ind_npars) = 0. +Proof. + intros hasp. + induction 1; cbn => //. + case: eqb_spec => [|]. + - intros ->. destruct d => //. intros [= <-]. + cbn in H0. unfold wf_minductive in H0. + rtoProp. cbn in H0. rewrite hasp in H0; now eapply eqb_eq in H0. + - intros _. eapply IHwf_glob. +Qed. + +Lemma wellformed_lookup_constructor_pars {efl : EEnvFlags} {Σ kn c mdecl idecl cdecl} : + has_cstr_params = false -> + wf_glob Σ -> + lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) -> mdecl.(ind_npars) = 0. +Proof. + intros hasp wf. cbn -[lookup_minductive]. + destruct lookup_minductive eqn:hl => //. + do 2 destruct nth_error => //. + eapply wellformed_lookup_inductive_pars in hl => //. congruence. +Qed. + +Lemma lookup_constructor_pars_args_spec {efl : EEnvFlags} {Σ ind n mdecl idecl cdecl} : + wf_glob Σ -> + lookup_constructor Σ ind n = Some (mdecl, idecl, cdecl) -> + lookup_constructor_pars_args Σ ind n = Some (mdecl.(ind_npars), cdecl.(cstr_nargs)). +Proof. + cbn -[lookup_constructor] => wfΣ. + destruct lookup_constructor as [[[mdecl' idecl'] [pars args]]|] eqn:hl => //. + intros [= -> -> <-]. cbn. f_equal. +Qed. + +Lemma wellformed_lookup_constructor_pars_args {efl : EEnvFlags} {Σ ind k n block_args} : + wf_glob Σ -> + has_cstr_params = false -> + wellformed Σ k (EAst.tConstruct ind n block_args) -> + ∑ args, lookup_constructor_pars_args Σ ind n = Some (0, args). +Proof. + intros wfΣ hasp wf. cbn -[lookup_constructor] in wf. + destruct lookup_constructor as [[[mdecl idecl] cdecl]|] eqn:hl => //. + exists cdecl.(cstr_nargs). + pose proof (wellformed_lookup_constructor_pars hasp wfΣ hl). + eapply lookup_constructor_pars_args_spec in hl => //. congruence. + destruct has_tConstruct => //. +Qed. + +Lemma constructor_isprop_pars_decl_params {efl : EEnvFlags} {Σ ind c b pars cdecl} : + has_cstr_params = false -> wf_glob Σ -> + constructor_isprop_pars_decl Σ ind c = Some (b, pars, cdecl) -> pars = 0. +Proof. + intros hasp hwf. + rewrite /constructor_isprop_pars_decl /lookup_constructor /lookup_inductive. + destruct lookup_minductive as [mdecl|] eqn:hl => /= //. + do 2 destruct nth_error => //. + eapply wellformed_lookup_inductive_pars in hl => //. congruence. +Qed. + +Lemma skipn_ge m {A} (l : list A) : + m >= length l -> skipn m l = []. +Proof. + induction l in m |- *. + - destruct m; reflexivity. + - cbn. destruct m; try lia. intros H. + eapply IHl. lia. +Qed. + +Lemma chop_all {A} (l : list A) m : + m >= length l -> chop m l = (l, nil). +Proof. + intros Hl. rewrite chop_firstn_skipn. + rewrite firstn_ge; try lia. rewrite skipn_ge; try lia. + eauto. +Qed. + +Lemma implement_box_isConstructApp {efl : EEnvFlags} {Σ : global_declarations} t : + isConstructApp (implement_box t) = isConstructApp t. +Proof. + induction t; try now cbn; eauto. + simp implement_box. + rewrite (isConstructApp_mkApps _ [t2]). + rewrite (isConstructApp_mkApps _ [_]). eauto. +Qed. + +Lemma implement_box_isPrimApp {efl : EEnvFlags} {Σ : global_declarations} t : + isPrimApp (implement_box t) = isPrimApp t. +Proof. + induction t; try now cbn; eauto. + simp implement_box. + rewrite (isPrimApp_mkApps _ [t2]). + rewrite (isPrimApp_mkApps _ [_]). eauto. +Qed. + +Lemma lookup_env_implement_box {Σ : global_declarations} kn : + lookup_env (implement_box_env Σ) kn = + option_map (implement_box_decl) (lookup_env Σ kn). +Proof. + unfold implement_box_env. + induction Σ at 1 2; simpl; auto. + case: eqb_spec => //. +Qed. + +Lemma implement_box_declared_constant {Σ : global_declarations} c decl : + declared_constant Σ c decl -> + declared_constant (implement_box_env Σ) c (implement_box_constant_decl decl). +Proof. + intros H. red in H; red. + rewrite lookup_env_implement_box H //. +Qed. + +Lemma lookup_constructor_implement_box Σ ind c : + lookup_constructor (implement_box_env Σ) ind c = + lookup_constructor Σ ind c. +Proof. + unfold lookup_constructor, lookup_inductive, lookup_minductive in *. + rewrite lookup_env_implement_box. + destruct lookup_env as [ [] | ]; cbn; congruence. +Qed. + +Lemma isLambda_implement_box c : isLambda c -> isLambda (implement_box c). +Proof. destruct c => //. Qed. + +Definition disable_box_term_flags (et : ETermFlags) := + {| has_tBox := false + ; has_tRel := true + ; has_tVar := has_tVar + ; has_tEvar := has_tEvar + ; has_tLambda := true + ; has_tLetIn := has_tLetIn + ; has_tApp := has_tApp + ; has_tConst := has_tConst + ; has_tConstruct := has_tConstruct + ; has_tCase := has_tCase + ; has_tProj := has_tProj + ; has_tFix := true + ; has_tCoFix := has_tCoFix + ; has_tPrim := has_tPrim + |}. + +Definition switch_off_box (efl : EEnvFlags) := + {| has_axioms := efl.(has_axioms) ; has_cstr_params := efl.(has_cstr_params) ; term_switches := disable_box_term_flags efl.(term_switches) ; cstr_as_blocks := efl.(cstr_as_blocks) |}. + +Lemma transform_wellformed' {efl : EEnvFlags} {Σ : list (kername × global_decl)} n t : + has_tApp -> + wf_glob Σ -> + @wellformed efl Σ n t -> + @wellformed (switch_off_box efl) Σ n (implement_box t). +Proof. + intros hasa. + revert n. funelim (implement_box t); simp_eta; cbn -[implement_box + lookup_inductive lookup_constructor lookup_constructor_pars_args + GlobalContextMap.lookup_constructor_pars_args isEtaExp]; intros m Hwf Hw; rtoProp; try split; eauto. + all: rewrite ?map_InP_spec; toAll; eauto; try now solve_all. + - unfold lookup_constructor_pars_args in *. + destruct (lookup_constructor Σ) as [[[]] | ]; try congruence; cbn - [implement_box]. + all: destruct cstr_as_blocks; cbn in *; rtoProp; try split; eauto. + + now rewrite map_length. + + solve_all. + + destruct block_args; cbn in *; eauto. + - repeat split; eauto. solve_all. + - unfold wf_fix in *. rtoProp. solve_all. solve_all. now eapply isLambda_implement_box. + - unfold wf_fix in *. rtoProp. solve_all. + len. solve_all. len. destruct x. + cbn -[implement_box isEtaExp] in *. rtoProp. eauto. + - unfold wf_fix in *. len. solve_all. rtoProp; intuition auto. + solve_all. +Qed. + +Lemma transform_wellformed_decl' {efl : EEnvFlags} {Σ : global_declarations} d : + has_tApp -> + wf_glob Σ -> + @wf_global_decl efl Σ d -> + @wf_global_decl (switch_off_box efl) Σ (implement_box_decl d). +Proof. + intros. + destruct d => //=. cbn. + destruct c as [[]] => //=. + eapply transform_wellformed'; tea. +Qed. + +From MetaCoq.Erasure Require Import EGenericMapEnv. + +Lemma transform_wellformed {efl : EEnvFlags} {Σ : global_declarations} n t : + has_tApp -> + wf_glob Σ -> + @wellformed efl Σ n t -> + @wellformed (switch_off_box efl) (implement_box_env Σ) n (implement_box t). +Proof. + intros. eapply gen_transform_wellformed_irrel; eauto. + eapply transform_wellformed'; eauto. +Qed. + +Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : global_declarations} : + has_tApp -> + wf_glob (efl := efl) Σ -> + forall d, + wf_global_decl (efl := efl) Σ d -> + wf_global_decl (efl := switch_off_box efl) (implement_box_env Σ) (implement_box_decl d). +Proof. + intros. + destruct d => /= //. + rewrite /isEtaExp_constant_decl. cbn in H1. + destruct (cst_body c) => /= //. + eapply transform_wellformed => //. +Qed. + +Lemma fresh_global_optimize_env {Σ : global_declarations} kn : + fresh_global kn Σ -> + fresh_global kn (implement_box_env Σ). +Proof. + induction 1; cbn; constructor; auto. +Qed. + +Lemma fresh_global_map_on_snd Σ f kn : + fresh_global kn Σ -> + fresh_global kn (map (on_snd f) Σ). +Proof. + induction 1; cbn; constructor; auto. +Qed. + +Lemma transform_wf_global {efl : EEnvFlags} {Σ : global_declarations} : + has_tApp -> + wf_glob (efl := efl) Σ -> wf_glob (efl := switch_off_box efl) (implement_box_env Σ). +Proof. + intros hasapp wfg. clear - hasapp wfg. + assert (extends Σ Σ). now exists []. + revert H wfg. generalize Σ at 2 3. + induction Σ; cbn; constructor; auto. + - eapply IHΣ; rtoProp; intuition eauto. + destruct H. subst Σ0. exists (x ++ [a]). now rewrite -app_assoc. + - epose proof (EExtends.extends_wf_glob _ H wfg); tea. + depelim H0. cbn. + eapply gen_transform_wellformed_decl_irrel; trea. + destruct d; cbn in *; eauto. + destruct (cst_body c); eauto. + cbn -[implement_box]. cbn in H1. + eapply transform_wellformed'; eauto. + - eapply fresh_global_map_on_snd. + eapply EExtends.extends_wf_glob in wfg; tea. now depelim wfg. +Qed. + +Transparent implement_box. + +Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t). +Proof. + induction t in l |- *; simpl; auto. rewrite IHt1. + unfold decompose_app. simpl. now rewrite (IHt1 [t2]). +Qed. + +Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1. +Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed. +Lemma tApp_mkApps f a : tApp f a = mkApps f [a]. +Proof. reflexivity. Qed. + +Require Import EWcbvEvalCstrsAsBlocksInd. + +Lemma implement_box_mkApps f args : + implement_box (mkApps f args) = mkApps (implement_box f) (map implement_box args). +Proof. + induction args in f |- *; simp implement_box. + - reflexivity. + - rewrite IHargs. now simp implement_box. +Qed. + +Lemma implement_box_eval {efl : EEnvFlags} (fl := block_wcbv_flags) : + with_constructor_as_block = true -> + has_cstr_params = false -> + has_tApp -> + forall (Σ : global_declarations), @wf_glob efl Σ -> + forall t t', + @wellformed efl Σ 0 t -> + EWcbvEval.eval Σ t t' -> + @EWcbvEval.eval block_wcbv_flags (implement_box_env Σ) (implement_box t) (implement_box t'). +Proof. + intros cstrbl prms hasapp Σ wfΣ. + eapply + (EWcbvEvalCstrsAsBlocksInd.eval_preserve_mkApps_ind fl cstrbl (efl := efl) Σ _ + (wellformed Σ) (Qpres := Qpreserves_wellformed efl _ wfΣ)) => //. + { intros. eapply EWcbvEval.eval_wellformed => //; tea. } + all:intros *. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + eapply eval_fix' => //. + + eauto. + + cbn. reflexivity. + + eauto. + + econstructor. econstructor => //. + eapply value_final. eapply eval_to_value; eauto. + unfold iBox. cbn -[implement_box]. unfold map_def. cbn -[implement_box]. + econstructor. cbn. eauto. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + econstructor; eauto. + now rewrite -implement_box_csubst. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + econstructor; eauto. + now rewrite -implement_box_csubst. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + assert (pars = 0) as -> by now (eapply constructor_isprop_pars_decl_params; eauto). + pose proof (Hcon := H1). + rewrite /constructor_isprop_pars_decl in H1. + destruct lookup_constructor as [[[]] | ] eqn:eqc; cbn in H1; invs H1. + eapply eval_iota_block => //. + + cbn [fst]. eapply e0. + + unfold constructor_isprop_pars_decl. + rewrite lookup_constructor_implement_box. cbn [fst]. + rewrite eqc //= H7 //. + + now rewrite map_InP_spec nth_error_map H2; eauto. + + rewrite map_InP_spec. len. + + rewrite H8. rewrite map_InP_spec. len. + + rewrite map_InP_spec. rewrite -implement_box_iota_red. now rewrite H8. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + eapply eval_fix' => //; eauto. rewrite map_InP_spec. + now eapply implement_box_cunfold_fix. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + eapply eval_cofix_case. + 2: now eapply implement_box_cunfold_cofix. + { rewrite implement_box_mkApps in e0. + simp implement_box in e0. rewrite map_InP_spec in e0. + cbn -[implement_box] in e0. + exact e0. + } + rewrite implement_box_mkApps in e. + simp implement_box in e. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + eapply eval_cofix_proj. + 2: now eapply implement_box_cunfold_cofix. { rewrite implement_box_mkApps in e0. + simp implement_box in e0. rewrite map_InP_spec in e0. + cbn -[implement_box] in e0. + exact e0. + } + rewrite implement_box_mkApps in e. + simp implement_box in e. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + econstructor. + eapply implement_box_declared_constant; eauto. + destruct decl. cbn in *. now rewrite H0. + eauto. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. rewrite map_InP_spec in e0. + unfold constructor_isprop_pars_decl in *. + destruct lookup_constructor as [[[mdecl idecl] cdecl']|] eqn:hc => //. + noconf H2. + pose proof (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ hc). + assert (ind_npars mdecl = 0). + { eapply wellformed_lookup_constructor_pars; tea. } + eapply eval_proj_block => //; tea. cbn. + + unfold constructor_isprop_pars_decl. + rewrite lookup_constructor_implement_box. cbn [fst]. + rewrite hc //= H1 H7. reflexivity. + + len. + + rewrite nth_error_map /=. rewrite H7 in H2; rewrite -H2 in H4; rewrite H4; eauto. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. + eapply eval_app_cong; eauto. + revert H1. + destruct f'; try now cbn; tauto. + intros H. cbn in H. + rewrite implement_box_isConstructApp; eauto. + rewrite implement_box_isPrimApp; eauto. + - intros; repeat match goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. + simp implement_box in *. rewrite !map_InP_spec. + eapply eval_construct_block; tea. eauto. + 2: len; eassumption. + rewrite lookup_constructor_implement_box; eauto. + eapply All2_All2_Set. + solve_all. now destruct b. + - intros. destruct t; try solve [constructor; cbn in H, H0 |- *; try congruence]. + cbn -[lookup_constructor] in H |- *. destruct l => //. +Qed. From 5bc51f5cb9f708ea3a6c8b6fcc1abe8120beed9a Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Thu, 6 Jul 2023 15:14:02 +0200 Subject: [PATCH 33/65] adapt name pass to not consider box --- erasure/theories/EWcbvEvalNamed.v | 56 ++++++------------------------- 1 file changed, 11 insertions(+), 45 deletions(-) diff --git a/erasure/theories/EWcbvEvalNamed.v b/erasure/theories/EWcbvEvalNamed.v index c3578d341..bab199936 100644 --- a/erasure/theories/EWcbvEvalNamed.v +++ b/erasure/theories/EWcbvEvalNamed.v @@ -28,7 +28,6 @@ Local Ltac inv H := inversion H; subst. (** ** Big step *named* version of weak cbv beta-zeta-iota-fix-delta reduction. *) Inductive value : Set := -| vBox | vClos (na : ident) (b : term) (env : list (ident * value)) | vConstruct (ind : inductive) (c : nat) (args : list (value)) | vRecClos (b : list (ident * term)) (idx : nat) (env : list (ident * value)). @@ -78,13 +77,6 @@ Section Wcbv. lookup Γ na = Some v -> eval Γ (tVar na) v - | eval_vbox : eval Γ tBox vBox - - | eval_box a t t' : - eval Γ a vBox -> - eval Γ t t' -> - eval Γ (tApp a t) vBox - (** Beta *) | eval_beta f na b a a' res Γ' : eval Γ f (vClos na b Γ') -> @@ -152,14 +144,6 @@ Section Wcbv. λ (P : ∀ (Γ : environment) (t : term) (v : value), eval Γ t v → Type) (f : ∀ (Γ : environment) (na : string) (v : value) (e : lookup Γ na = Some v), P Γ (tVar na) v (eval_var Γ na v e)) - (f_vbox : ∀ (Γ : environment) (e : eval Γ tBox vBox), P Γ tBox vBox e) - (f0 : ∀ (Γ : environment) (a t : term) - (t' : value) (e : eval Γ a vBox), - P Γ a vBox e - → ∀ e0 : eval Γ t t', - P Γ t t' e0 - → P Γ (tApp a t) vBox - (eval_box Γ a t t' e e0)) (f1 : ∀ (Γ : environment) (f1 : term) (na : ident) (b a : term) (a' res : value) (Γ' : list (ident × value)) (e : eval Γ f1 (vClos na b Γ')), P Γ f1 (vClos na b Γ') e → ∀ e0 : eval Γ a a', P Γ a a' e0 → ∀ e1 : eval (add na a' Γ') b res, P (add na a' Γ') b res e1 → P Γ (tApp f1 a) res (eval_beta Γ f1 na b a a' res Γ' e e0 e1)) @@ -254,8 +238,6 @@ Section Wcbv. fix F (Γ : environment) (t : term) (v : value) (e : eval Γ t v) {struct e} : P Γ t v e := match e as e0 in (eval _ t0 v0) return (P Γ t0 v0 e0) with | @eval_var _ na v0 e0 => f Γ na v0 e0 - | @eval_vbox _ => f_vbox Γ _ - | @eval_box _ a t0 t' e0 e1 => f0 Γ a t0 t' e0 (F Γ a vBox e0) e1 (F Γ t0 t' e1) | @eval_beta _ f10 na b a a' res Γ' e0 e1 e2 => f1 Γ f10 na b a a' res Γ' e0 (F Γ f10 (vClos na b Γ') e0) e1 (F Γ a a' e1) e2 (F (add na a' Γ') b res e2) | @eval_lambda _ na b => f2 Γ na b | @eval_zeta _ na b0 b0' b1 res e0 e1 => f3 Γ na b0 b0' b1 res e0 (F Γ b0 b0' e0) e1 (F (add na b0' Γ) b1 res e1) @@ -280,7 +262,6 @@ Definition ident_of_name (na : name) : ident := Reserved Notation "Γ ;;; E ⊩ s ~ t" (at level 50, E, s, t at next level). Inductive represents : list ident -> environment -> term -> term -> Set := -| represents_tBox Γ E : Γ ;;; E ⊩ tBox ~ tBox | represents_bound_tRel Γ n na E : nth_error Γ n = Some na -> Γ ;;; E ⊩ tVar na ~ tRel n | represents_unbound_tRel E na v Γ s : lookup E na = Some v -> represents_value v s -> Γ ;;; E ⊩ tVar na ~ s | represents_tLambda Γ E na na' b b' : (na :: Γ) ;;; E ⊩ b ~ b' -> Γ ;;; E ⊩ tLambda (nNamed na) b ~ tLambda na' b' @@ -300,7 +281,6 @@ Inductive represents : list ident -> environment -> term -> term -> Set := All2_Set (fun d d' => (List.rev nms ++ Γ) ;;; E ⊩ d.(dbody) ~ d'.(dbody)) mfix mfix' -> Γ ;;; E ⊩ tFix mfix idx ~ tFix mfix' idx with represents_value : value -> term -> Set := -| represents_value_tBox : represents_value vBox tBox | represents_value_tClos na E s t na' : [na] ;;; E ⊩ s ~ t -> represents_value (vClos na s E) (tLambda na' t) | represents_value_tConstruct vs ts ind c : All2_Set represents_value vs ts -> represents_value (vConstruct ind c vs) (tConstruct ind c ts) | represents_value_tFix vfix i E mfix : @@ -311,8 +291,7 @@ Program Definition represents_ind := (λ (P : ∀ (l : list ident) (e : environment) (t t0 : term), l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), represents_value v t → Type) - (f : ∀ (Γ : list ident) (E : environment), - P Γ E tBox tBox (represents_tBox Γ E)) (f0 : + (f0 : ∀ (Γ : list ident) (n : nat) (na : ident) @@ -374,7 +353,7 @@ Program Definition represents_ind := (IH : All2_over a0 (fun t t' : def term => P (List.rev nms ++ Γ) E (dbody t) (dbody t'))), P Γ E (tFix mfix idx) (tFix mfix' idx) (represents_tFix Γ E mfix mfix' idx nms Hbodies Hnodup a a0)) - (f9 : P0 vBox tBox represents_value_tBox) (f10 : + (f10 : ∀ (na : ident) (E : environment) (s t : term) @@ -401,7 +380,6 @@ Program Definition represents_ind := (l : list ident) (e : environment) (t t0 : term) (r : l;;; e ⊩ t ~ t0) {struct r} : P l e t t0 r := match r as r0 in (l0;;; e0 ⊩ t1 ~ t2) return (P l0 e0 t1 t2 r0) with - | represents_tBox Γ E => f Γ E | represents_bound_tRel Γ n na E e0 => f0 Γ n na E e0 | represents_unbound_tRel E na v Γ s e0 r0 => f1 E na v Γ s e0 r0 (F0 v s r0) @@ -423,7 +401,6 @@ Program Definition represents_ind := with F0 (v : value) (t : term) (r : represents_value v t) {struct r} : P0 v t r := match r as r0 in (represents_value v0 t0) return (P0 v0 t0 r0) with - | represents_value_tBox => f9 | represents_value_tClos na E s t0 na' r0 => f10 na E s t0 na' r0 (F [na] E s t0 r0) | represents_value_tConstruct vs ts ind c a => f11 vs ts ind c a _ @@ -451,8 +428,7 @@ Program Definition represents_value_ind := (λ (P : ∀ (l : list ident) (e : environment) (t t0 : term), l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), represents_value v t → Type) - (f : ∀ (Γ : list ident) (E : environment), - P Γ E tBox tBox (represents_tBox Γ E)) (f0 : + (f0 : ∀ (Γ : list ident) (n : nat) (na : ident) @@ -518,7 +494,7 @@ Program Definition represents_value_ind := (IH : All2_over a0 (fun t t' : def term => P (List.rev nms ++ Γ) E (dbody t) (dbody t'))), P Γ E (tFix mfix idx) (tFix mfix' idx) (represents_tFix Γ E mfix mfix' idx nms Hbodies Hnodup a a0)) - (f9 : P0 vBox tBox represents_value_tBox) (f10 : + (f10 : ∀ (na : ident) (E : environment) (s t : term) @@ -547,7 +523,6 @@ Program Definition represents_value_ind := (l : list ident) (e : environment) (t t0 : term) (r : l;;; e ⊩ t ~ t0) {struct r} : P l e t t0 r := match r as r0 in (l0;;; e0 ⊩ t1 ~ t2) return (P l0 e0 t1 t2 r0) with - | represents_tBox Γ E => f Γ E | represents_bound_tRel Γ n na E e0 => f0 Γ n na E e0 | represents_unbound_tRel E na v Γ s e0 r0 => f1 E na v Γ s e0 r0 (F0 v s r0) @@ -569,7 +544,6 @@ Program Definition represents_value_ind := with F0 (v : value) (t : term) (r : represents_value v t) {struct r} : P0 v t r := match r as r0 in (represents_value v0 t0) return (P0 v0 t0 r0) with - | represents_value_tBox => f9 | represents_value_tClos na E s t0 na' r0 => f10 na E s t0 na' r0 (F [na] E s t0 r0) | represents_value_tConstruct vs ts ind c a => f11 vs ts ind c a _ @@ -597,8 +571,7 @@ Definition rep_ind := (λ (P : ∀ (l : list ident) (e : environment) (t t0 : term), l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), represents_value v t → Type) - (f : ∀ (Γ : list ident) (E : environment), - P Γ E tBox tBox (represents_tBox Γ E)) (f0 : + (f0 : ∀ (Γ : list ident) (n : nat) (na : ident) @@ -664,7 +637,7 @@ Definition rep_ind := (IH : All2_over a0 (fun t t' : def term => P (List.rev nms ++ Γ) E (dbody t) (dbody t'))), P Γ E (tFix mfix idx) (tFix mfix' idx) (represents_tFix Γ E mfix mfix' idx nms Hbodies Hnodup a a0)) - (f9 : P0 vBox tBox represents_value_tBox) (f10 : + (f10 : ∀ (na : ident) (E : environment) (s t : term) @@ -691,8 +664,8 @@ Definition rep_ind := (IH : All2_over a (fun v d H => P (List.rev (map fst vfix)) E v.2 (dbody d) (snd H) ) ), P0 (vRecClos vfix i E) (tFix mfix i) (represents_value_tFix vfix i E mfix a)), - (represents_ind P P0 f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12, - represents_value_ind P P0 f f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12)). + (represents_ind P P0 f0 f1 f2 f3 f4 f5 f6 f7 f8 f10 f11 f12, + represents_value_ind P P0 f0 f1 f2 f3 f4 f5 f6 f7 f8 f10 f11 f12)). Local Notation "'⊩' v ~ s" := (represents_value v s) (at level 50). Local Hint Constructors represents : core. @@ -895,7 +868,7 @@ Fixpoint annotate_env Γ (Σ : global_declarations) := end. Definition extraction_term_flags := - {| has_tBox := true + {| has_tBox := false ; has_tRel := true ; has_tVar := false ; has_tEvar := false @@ -988,7 +961,7 @@ Lemma unfolds_bound : (forall Γ E s t, Γ ;;; E ⊩ s ~ t -> closedn #|Γ| t) × (forall v s, ⊩ v ~ s -> closedn 0 s). Proof. - refine (rep_ind _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros; cbn; rtoProp; eauto. + refine (rep_ind _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros; cbn; rtoProp; eauto. - eapply Nat.ltb_lt, nth_error_Some. congruence. - eapply closed_upwards; eauto. lia. - solve_all. induction a; cbn in *; econstructor; firstorder. @@ -1256,7 +1229,6 @@ Fixpoint sunny Γ (t : term) : bool := end. Inductive wf : value -> Type := -| wf_vBox : wf vBox | wf_vClos na b E : ~ In na (map fst E) -> sunny (na :: map fst E) b -> All (fun v => wf (snd v)) E -> wf (vClos na b E) | wf_vConstruct ind c args : All wf args -> wf (vConstruct ind c args) | wf_vRecClos vfix idx E : @@ -1376,7 +1348,6 @@ Proof. destruct eqb eqn:E. * invs e. cbn in *; eauto. * eapply IHHE. exact e. - - econstructor. - let X := match reverse goal with H : All _ _ -> _ -> _ |- _ => H end in do 2 forward X; eauto; inv X. let X1 := multimatch goal with H : _ |- _ => H end in @@ -1605,11 +1576,7 @@ Proof. all: try congruence. all: intros; rtoProp. all: repeat match reverse goal with [H : MCProd.and3 _ _ _ |- _] => destruct H end. - - invs Hrep. - + invs H2. - + cbn in Hsunny. rtoProp. edestruct s0 as (v & Hv1 & Hv2). 3: eauto. eauto. eauto. - edestruct s1 as (? & ? & ?); eauto. - invs Hv1. eexists; split; eauto. econstructor; eauto. + - cbn in i0. congruence. - invs Hrep. + invs H3. + cbn in Hsunny. rtoProp. @@ -1872,7 +1839,6 @@ Proof. unfold cstr_arity in *. invs H. lia. clear - Hvs; induction Hvs; econstructor; eauto. eapply r. - invs Hrep; cbn in *; try congruence; rtoProp. - + econstructor. split; eauto. eapply eval_vbox. + econstructor. split; eauto. econstructor. eauto. + econstructor. split; eauto. econstructor. + destruct args'; congruence. From 7565dd43f65a0bd0268c2404b6dc929ed8bc28ab Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Thu, 6 Jul 2023 15:38:40 +0200 Subject: [PATCH 34/65] remove assumption --- pcuic/theories/PCUICFirstorder.v | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index 0942d8141..758a4a2cc 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -622,19 +622,18 @@ Proof using Type. * intros hl. now eapply invert_cumul_prod_ind in hl. Qed. -Lemma firstorder_value_spec (Σ:global_env_ext) t i u args mind : +Lemma firstorder_value_spec (Σ:global_env_ext) t i u args : wf Σ -> wf_local Σ [] -> Σ ;;; [] |- t : mkApps (tInd i u) args -> PCUICWcbvEval.value Σ t -> - lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) -> @firstorder_ind Σ (firstorder_env Σ) i -> firstorder_value Σ [] t. Proof using Type. intros Hwf Hwfl Hty Hvalue. - revert mind i u args Hty. + revert i u args Hty. induction Hvalue as [ t Hvalue | t args' Hhead Hargs IH ] using PCUICWcbvEval.value_values_ind; - intros mind i u args Hty Hlookup Hfo. + intros i u args Hty Hfo. - destruct t; inversion_clear Hvalue. + exfalso. eapply inversion_Sort in Hty as (? & ? & Hcumul); eauto. now eapply invert_cumul_sort_ind in Hcumul. @@ -667,9 +666,10 @@ Proof using Type. destruct unfold_fix as [ [] | ]; auto. eapply nth_error_nil. + exfalso. eapply (typing_cofix_coind (args := [])) in Hty. red in Hty. red in Hfo. unfold firstorder_ind in Hfo. - rewrite Hlookup in Hfo. + destruct lookup_env eqn:E; try congruence. + destruct g; try congruence. eapply andb_true_iff in Hfo as [Hfo _]. - rewrite /check_recursivity_kind Hlookup in Hty. + rewrite /check_recursivity_kind E in Hty. now eapply (negb_False _ Hfo). + eapply inversion_Prim in Hty as [prim_ty [cdecl [wf hp hdecl [s []] cum]]]; eauto. now eapply invert_cumul_axiom_ind in cum; tea. @@ -697,7 +697,6 @@ Proof using Type. econstructor. inv X. eapply H0. tea. unshelve eapply declared_inductive_to_gen in d0; eauto. - exact i3. inv X. eapply IHspine; eauto. + exfalso. destruct PCUICWcbvEval.cunfold_fix as [[] | ] eqn:E; inversion H. @@ -708,9 +707,10 @@ Proof using Type. eapply nth_error_None. lia. + exfalso. eapply (typing_cofix_coind (args := args')) in Hty. red in Hfo. unfold firstorder_ind in Hfo. - rewrite Hlookup in Hfo. + destruct lookup_env eqn:E; try congruence. + destruct g; try congruence. eapply andb_true_iff in Hfo as [Hfo _]. - rewrite /check_recursivity_kind Hlookup in Hty. + rewrite /check_recursivity_kind E in Hty. now eapply (negb_False _ Hfo). Qed. From a35996168cf4dd16b13da4e1dcf9f4803cfb9f87 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Jul 2023 18:28:57 +0200 Subject: [PATCH 35/65] Fix definition of Transform.t's observational equivalence preservation --- common/theories/Transform.v | 13 ++++++++----- erasure-plugin/theories/ETransform.v | 18 +++++++++--------- erasure-plugin/theories/Erasure.v | 2 +- template-coq/theories/TemplateProgram.v | 2 +- template-pcuic/theories/PCUICTransform.v | 10 ++-------- 5 files changed, 21 insertions(+), 24 deletions(-) diff --git a/common/theories/Transform.v b/common/theories/Transform.v index cf56d02d6..5a4aeace8 100644 --- a/common/theories/Transform.v +++ b/common/theories/Transform.v @@ -25,11 +25,12 @@ Module Transform. Context {eval : program -> value -> Prop}. Context {eval' : program' -> value' -> Prop}. - Definition preserves_eval pre (transform : forall p : program, pre p -> program') obseq := + Definition preserves_eval pre (transform : forall p : program, pre p -> program') + (obseq : forall p : program, pre p -> program' -> value -> value' -> Prop) := forall p v (pr : pre p), eval p v -> let p' := transform p pr in - exists v', eval' p' v' /\ obseq p p' v v'. + exists v', eval' p' v' /\ obseq p pr p' v v'. Record t := { name : string; @@ -37,7 +38,7 @@ Module Transform. transform : forall p : program, pre p -> program'; post : program' -> Prop; correctness : forall input (p : pre input), post (transform input p); - obseq : program -> program' -> value -> value' -> Prop; + obseq : forall p : program, pre p -> program' -> value -> value' -> Prop; preservation : preserves_eval pre transform obseq; }. Definition run (x : t) (p : program) (pr : pre x p) : program' := @@ -63,7 +64,9 @@ Module Transform. transform p hp := run o' (run o p hp) (hpp _ (o.(correctness) _ hp)); pre := o.(pre); post := o'.(post); - obseq g g' v v' := exists g'' v'', o.(obseq) g g'' v v'' × o'.(obseq) g'' g' v'' v' + obseq g preg g' v v' := + exists v'', o.(obseq) g preg (run o g preg) v v'' × + o'.(obseq) (run o g preg) (hpp _ (o.(correctness) _ preg)) g' v'' v' |}. Next Obligation. intros o o' hpp inp pre. @@ -78,7 +81,7 @@ Module Transform. specialize (H0 (hpp _ (o.(correctness) _ pr)) ev). destruct H0 as [v'' [ev' obs']]. exists v''. constructor => //. - exists (transform o p pr), v'. now split. + exists v'. now split. Qed. End Comp. diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index 7ca17ed50..352a50101 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -204,7 +204,7 @@ Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t p transform p hp := let nhs := proj2 (proj2 hp) in @erase_program guard p (proj1 nhs) (proj2 nhs) (proj1 hp) ; post p := [/\ wf_eprogram_env all_env_flags p & EEtaExpandedFix.expanded_eprogram_env p]; - obseq g g' v v' := let Σ := g.1 in Σ ;;; [] |- v ⇝ℇ v' |}. + obseq p hp p' v v' := let Σ := p.1 in Σ ;;; [] |- v ⇝ℇ v' |}. Next Obligation. cbn -[erase_program]. @@ -271,7 +271,7 @@ Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : E transform p pre := p; pre p := wf_eprogram_env efl p /\ EEtaExpandedFix.expanded_eprogram_env p; post p := wf_eprogram_env efl p /\ EEtaExpandedFix.expanded_eprogram_env p; - obseq g g' v v' := v' = v |}. + obseq p hp p' v v' := v' = v |}. Next Obligation. cbn. eauto. Qed. Next Obligation. cbn. @@ -292,7 +292,7 @@ Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} (wi pre p := wf_eprogram efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_cstrs p); transform p pre := rebuild_wf_env p (proj1 pre); post p := wf_eprogram_env efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_env_cstrs p); - obseq g g' v v' := v = v' |}. + obseq p hp p' v v' := v = v' |}. Next Obligation. cbn. intros fl efl [] input [wf exp]; cbn; split => //. Qed. @@ -307,7 +307,7 @@ Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : transform p pre := ERemoveParams.strip_program p; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p; - obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}. + obseq p hp p' v v' := v' = (ERemoveParams.strip p.1 v) |}. Next Obligation. move=> fl wcon efl [Σ t] [wfp etap]. simpl. @@ -333,7 +333,7 @@ Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) {w transform p _ := (ERemoveParams.Fast.strip_env p.1, ERemoveParams.Fast.strip p.1 [] p.2); pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p; - obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}. + obseq p hp p' v v' := v' = (ERemoveParams.strip p.1 v) |}. Next Obligation. move=> fl wcon efl [Σ t] [wfp etap]. simpl. @@ -364,7 +364,7 @@ Program Definition remove_match_on_box_trans {fl : WcbvFlags} {wcon : with_const transform p _ := remove_match_on_box_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram efl p /\ EEtaExpanded.expanded_eprogram_cstrs p; - obseq g g' v v' := v' = EOptimizePropDiscr.remove_match_on_box g.1 v |}. + obseq p hp p' v v' := v' = EOptimizePropDiscr.remove_match_on_box p.1 v |}. Next Obligation. move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap]. @@ -390,7 +390,7 @@ Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcb transform p _ := EInlineProjections.optimize_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram (disable_projections_env_flag efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p; - obseq g g' v v' := v' = EInlineProjections.optimize g.1 v |}. + obseq p hp p' v v' := v' = EInlineProjections.optimize p.1 v |}. Next Obligation. move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap]. @@ -414,7 +414,7 @@ Program Definition constructors_as_blocks_transformation (efl : EEnvFlags) transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram (switch_cstr_as_blocks efl) p ; - obseq g g' v v' := v' = EConstructorsAsBlocks.transform_blocks g.1 v |}. + obseq p hp p' v v' := v' = EConstructorsAsBlocks.transform_blocks p.1 v |}. Next Obligation. move=> efl hasapp haspars hascstrs [Σ t] [] [wftp wft] /andP [etap etat]. @@ -441,7 +441,7 @@ Program Definition implement_box_transformation (efl : EEnvFlags) transform p _ := EImplementBox.implement_box_program p ; pre p := wf_eprogram efl p ; post p := wf_eprogram (switch_off_box efl) p ; - obseq g g' v v' := v' = implement_box v |}. + obseq p hp p' v v' := v' = implement_box v |}. Next Obligation. intros. cbn in *. destruct p. split. diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index 567ca5f4f..71d754645 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -47,7 +47,7 @@ Program Definition eta_expand K : Transform.t template_program_env template_prog pre := fun p => ∥ wt_template_program_env p ∥ /\ K (eta_expand_global_env p.1) ; transform p _ := EtaExpand.eta_expand_program p ; post := fun p => ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p /\ K p.1; - obseq p p' v v' := v' = EtaExpand.eta_expand p.1 [] v |}. + obseq p hp p' v v' := v' = EtaExpand.eta_expand p.1 [] v |}. Next Obligation. let p := match goal with H : template_program_env |- _ => H end in destruct p. split; [|split]; auto; now apply assume_welltyped_template_program_expansion. diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v index ed305267e..e873a3d6e 100644 --- a/template-coq/theories/TemplateProgram.v +++ b/template-coq/theories/TemplateProgram.v @@ -52,7 +52,7 @@ Program Definition build_template_program_env {cf : checker_flags} K : pre p := ∥ wt_template_program p ∥ /\ forall pf, K (GlobalEnvMap.make p.1 (wt_template_program_fresh p pf)) : Prop ; transform p pre := make_template_program_env p (proj1 pre); post p := ∥ wt_template_program_env p ∥ /\ K p.1; - obseq g g' v v' := v = v' |}. + obseq g preg g' v v' := v = v' |}. Next Obligation. cbn. exists v. cbn; split; auto. Qed. diff --git a/template-pcuic/theories/PCUICTransform.v b/template-pcuic/theories/PCUICTransform.v index 64ee2007f..359f8998b 100644 --- a/template-pcuic/theories/PCUICTransform.v +++ b/template-pcuic/theories/PCUICTransform.v @@ -18,9 +18,6 @@ Import Transform TemplateToPCUIC. Definition eval_pcuic_program (p : pcuic_program) (v : term) := ∥ PCUICWcbvEval.eval p.1.(trans_env_env) p.2 v ∥. -Definition template_to_pcuic_obseq (p : template_program) (p' : pcuic_program) (v : Ast.term) (v' : term) := - let Σ := Ast.Env.empty_ext p.1 in v' = trans (trans_global Σ) v. - Lemma trans_template_program_wt {cf : checker_flags} p (wtp : wt_template_program p) : wt_pcuic_program (trans_template_program p). Proof. move: p wtp. @@ -43,7 +40,7 @@ Program Definition template_to_pcuic_transform {cf : checker_flags} K : pre p := ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p /\ K (trans_global (Ast.Env.empty_ext p.1)) ; transform p _ := trans_template_program p ; post p := ∥ wt_pcuic_program p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p /\ K p.1; - obseq := template_to_pcuic_obseq |}. + obseq p _ p' v v':= v' = trans p'.1 v |}. Next Obligation. cbn. intros cf K p [[wtp] [etap ?]]. split; split. @@ -68,16 +65,13 @@ From MetaCoq.PCUIC Require Import PCUICExpandLets PCUICExpandLetsCorrectness. expansion of the old one, which is the identiy on normal forms. *) -Definition let_expansion_obseq (p : pcuic_program) (p' : pcuic_program) (v : term) (v' : term) := - v' = PCUICExpandLets.trans v. - Program Definition pcuic_expand_lets_transform {cf : checker_flags} K : self_transform pcuic_program term eval_pcuic_program eval_pcuic_program := {| name := "let expansion in branches/constructors"; pre p := ∥ wt_pcuic_program p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p /\ K (build_global_env_map (trans_global_env p.1.1), p.1.2) ; transform p hp := expand_lets_program p; post p := ∥ wt_pcuic_program (cf:=PCUICExpandLetsCorrectness.cf' cf) p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p /\ K p.1; - obseq := let_expansion_obseq |}. + obseq p _ p' v v' := v' = PCUICExpandLets.trans v |}. Next Obligation. intros cf K [Σ t] [[[wfext ht]] etap]. cbn. split. sq. unfold build_global_env_map. unfold global_env_ext_map_global_env_ext. simpl. From 06ca492ccf37fad84a62778f1517c0683515c5ee Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Tue, 11 Jul 2023 16:45:41 +0200 Subject: [PATCH 36/65] prove wellformedness of annotate --- erasure/theories/EWcbvEvalNamed.v | 106 +++++++++++++++++++++++++----- utils/theories/MCList.v | 16 +++-- 2 files changed, 99 insertions(+), 23 deletions(-) diff --git a/erasure/theories/EWcbvEvalNamed.v b/erasure/theories/EWcbvEvalNamed.v index bab199936..8496db6e2 100644 --- a/erasure/theories/EWcbvEvalNamed.v +++ b/erasure/theories/EWcbvEvalNamed.v @@ -289,7 +289,7 @@ where "Γ ;;; E ⊩ s ~ t" := (represents Γ E s t). Program Definition represents_ind := (λ (P : ∀ (l : list ident) (e : environment) (t t0 : term), - l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), + l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), represents_value v t → Type) (f0 : ∀ (Γ : list ident) @@ -426,7 +426,7 @@ Defined. Program Definition represents_value_ind := (λ (P : ∀ (l : list ident) (e : environment) (t t0 : term), - l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), + l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), represents_value v t → Type) (f0 : ∀ (Γ : list ident) @@ -569,7 +569,7 @@ Defined. Definition rep_ind := (λ (P : ∀ (l : list ident) (e : environment) (t t0 : term), - l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), + l;;; e ⊩ t ~ t0 → Type) (P0 : ∀ (v : value) (t : term), represents_value v t → Type) (f0 : ∀ (Γ : list ident) @@ -809,21 +809,21 @@ Definition map_def_name := {| dname := g (dname d); dbody := f (dbody d); rarg := rarg d |}. -Section Map2. +(* Section Map2. *) - Context {A B C : Type}. - Variable (f : A → B → C). - Fixpoint map2 (l : list A) (l' : list B) {struct l} : - list C := - match l with - | [] => [] - | hd :: tl => - match l' with - | [] => [] - | hd' :: tl' => f hd hd' :: map2 tl tl' - end - end. -End Map2. +(* Context {A B C : Type}. *) +(* Variable (f : A → B → C). *) +(* Fixpoint map2 (l : list A) (l' : list B) {struct l} : *) +(* list C := *) +(* match l with *) +(* | [] => [] *) +(* | hd :: tl => *) +(* match l' with *) +(* | [] => [] *) +(* | hd' :: tl' => f hd hd' :: map2 tl tl' *) +(* end *) +(* end. *) +(* End Map2. *) Fixpoint annotate (s : list ident) (u : term) {struct u} : term := match u with @@ -912,6 +912,76 @@ Proof. * intros x [<- | ?]. 1: eauto. eapply IHl in H. firstorder. Qed. +Definition named_extraction_term_flags := + {| has_tBox := false + ; has_tRel := false + ; has_tVar := true + ; has_tEvar := false + ; has_tLambda := true + ; has_tLetIn := true + ; has_tApp := true + ; has_tConst := true + ; has_tConstruct := true + ; has_tCase := true + ; has_tProj := false + ; has_tFix := true + ; has_tCoFix := false + ; has_tPrim := false + |}. + +Definition named_extraction_env_flags := + {| has_axioms := false; + term_switches := named_extraction_term_flags; + has_cstr_params := false ; + cstr_as_blocks := true |}. + +Lemma wellformed_annotate Σ Γ s : + wellformed (efl := extraction_env_flags) Σ #|Γ| s -> wellformed (efl := named_extraction_env_flags) Σ #|Γ| (annotate Γ s). +Proof. + intros Hwf. + induction s in Γ, Hwf |- * using EInduction.term_forall_list_ind; cbn in *; rtoProp; unshelve eauto. + - eapply Nat.ltb_lt in Hwf. destruct nth_error eqn:Eq; eauto. + eapply nth_error_None in Eq. lia. + - destruct n; cbn. 2: destruct in_dec. + all: eapply (IHs (_ :: Γ)); cbn; eauto. + - split; eauto. destruct n; cbn. 2: destruct in_dec; cbn. + all: eapply (IHs2 (_ :: Γ)); cbn; eauto. + - destruct lookup_env as [ [] | ]; cbn in *; eauto. + destruct nth_error as [ [] | ]; cbn in *; eauto. + destruct nth_error as [ [] | ]; cbn in *; eauto. + repeat split. len. solve_all. + - destruct lookup_env as [ [] | ]; cbn in *; eauto. + destruct nth_error as [ [] | ]; cbn in *; eauto. + repeat split. eauto. + solve_all. rewrite map_length. rewrite <- app_length. + eapply a0. len. rewrite gen_many_fresh_length. eauto. + - split. + { clear - H. generalize ((List.rev (gen_many_fresh Γ ( (map dname m))) ++ Γ)). + induction m in Γ, H |- *; cbn. + - econstructor. + - intros. destruct a; cbn in *. destruct dname; cbn; rtoProp; repeat split; eauto. + all: destruct dbody; cbn in *; eauto. + + } + { solve_all. unfold wf_fix in *. rtoProp. split. + rewrite map2_length gen_many_fresh_length map_length. + { eapply Nat.ltb_lt in H0. eapply Nat.ltb_lt. lia. } + solve_all. clear H0. unfold test_def in *. cbn in *. + eapply All_impl in H1. 2:{ intros ? [[] ]. + specialize (i (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). + revert i. rewrite ?List.rev_length app_length ?List.rev_length gen_many_fresh_length ?List.rev_length map_length. intros r. eapply r in i1. exact i1. + } + revert H1. + generalize ((List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). + intros. rewrite map2_length gen_many_fresh_length map_length Nat.min_id. + revert H1. generalize (#|m| + #|Γ|). + intros. + induction m in Γ, n, n0, l, H1 |- *. + - econstructor. + - invs H1. cbn. destruct a; cbn. destruct dname; cbn; econstructor; eauto. + } +Qed. + Lemma nclosed_represents Σ Γ E s : wellformed Σ #|Γ| s -> Γ ;;; E ⊩ annotate Γ s ~ s. Proof. @@ -1981,4 +2051,4 @@ Proof. intros. eapply eval_to_eval_named; eauto. eapply sunny_annotate. eapply nclosed_represents. eauto. -Qed. \ No newline at end of file +Qed. diff --git a/utils/theories/MCList.v b/utils/theories/MCList.v index 4bf7b7194..b3900805b 100644 --- a/utils/theories/MCList.v +++ b/utils/theories/MCList.v @@ -57,11 +57,17 @@ Next Obligation. simpl in H. auto with arith. Defined. -Fixpoint map2 {A B C} (f : A -> B -> C) (l : list A) (l' : list B) : list C := - match l, l' with - | hd :: tl, hd' :: tl' => f hd hd' :: map2 f tl tl' - | _, _ => [] - end. +Section map2. + + Context {A B C} (f : A -> B -> C). + + Fixpoint map2 (l : list A) (l' : list B) : list C := + match l, l' with + | hd :: tl, hd' :: tl' => f hd hd' :: map2 tl tl' + | _, _ => [] + end. + +End map2. Lemma map2_ext {A B C} (f g : A -> B -> C) (l : list A) (l' : list B) : (forall x y, f x y = g x y) -> From f1a254857c202fba06cd74d12b365e591321c2c2 Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Wed, 12 Jul 2023 16:08:14 +0200 Subject: [PATCH 37/65] wellformed_annotate_env --- erasure/theories/EWcbvEvalNamed.v | 50 ++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/erasure/theories/EWcbvEvalNamed.v b/erasure/theories/EWcbvEvalNamed.v index 8496db6e2..a6ca1034e 100644 --- a/erasure/theories/EWcbvEvalNamed.v +++ b/erasure/theories/EWcbvEvalNamed.v @@ -862,7 +862,7 @@ Fixpoint annotate (s : list ident) (u : term) {struct u} : term := Fixpoint annotate_env Γ (Σ : global_declarations) := match Σ with - | (na, ConstantDecl (Build_constant_body (Some b))) :: Σ => (na, ConstantDecl (Build_constant_body (Some (annotate Γ b)))) :: annotate_env (string_of_kername na :: Γ) Σ + | (na, ConstantDecl (Build_constant_body (Some b))) :: Σ => (na, ConstantDecl (Build_constant_body (Some (annotate Γ b)))) :: annotate_env (Γ) Σ | d :: Σ => d :: annotate_env Γ Σ | nil => nil end. @@ -935,33 +935,57 @@ Definition named_extraction_env_flags := has_cstr_params := false ; cstr_as_blocks := true |}. -Lemma wellformed_annotate Σ Γ s : - wellformed (efl := extraction_env_flags) Σ #|Γ| s -> wellformed (efl := named_extraction_env_flags) Σ #|Γ| (annotate Γ s). +Lemma lookup_annotate_env Γ Σ i d : + lookup_env Σ i = Some d -> + lookup_env (annotate_env Γ Σ) i = Some + match d with + | ConstantDecl {| cst_body := b |} => ConstantDecl {| cst_body := option_map (annotate Γ) b |} + | InductiveDecl m => InductiveDecl m + end. Proof. - intros Hwf. - induction s in Γ, Hwf |- * using EInduction.term_forall_list_ind; cbn in *; rtoProp; unshelve eauto. + induction Σ in i |- *; cbn; try congruence. + destruct a. cbn. + destruct (eqb_spec i k). + + subst. intros [= ->]. + destruct d as [ [ []] | ]; cbn; now rewrite eqb_refl. + + intros Hi % IHΣ. destruct d as [ [] | ]; cbn in *; + destruct g as [ [[]]| ]; cbn; destruct (eqb_spec i k); try congruence. +Qed. + +Local Hint Resolve incl_tl incl_appr incl_appl : core. + +Lemma wellformed_annotate' Σ Γ Γ' s : + incl Γ' Γ -> + wellformed (efl := extraction_env_flags) Σ #|Γ| s -> wellformed (efl := named_extraction_env_flags) (annotate_env Γ' Σ) #|Γ| (annotate Γ s). +Proof. + intros Hincl Hwf. + induction s in Γ, Hwf, Γ', Hincl |- * using EInduction.term_forall_list_ind; cbn in *; rtoProp; unshelve eauto. - eapply Nat.ltb_lt in Hwf. destruct nth_error eqn:Eq; eauto. eapply nth_error_None in Eq. lia. - destruct n; cbn. 2: destruct in_dec. all: eapply (IHs (_ :: Γ)); cbn; eauto. - split; eauto. destruct n; cbn. 2: destruct in_dec; cbn. all: eapply (IHs2 (_ :: Γ)); cbn; eauto. - - destruct lookup_env as [ [] | ]; cbn in *; eauto. + - destruct lookup_env as [ [] | ] eqn:E; cbn in *; eauto. + destruct c, cst_body; cbn in *; try congruence. + erewrite lookup_annotate_env; eauto. cbn; eauto. + - destruct lookup_env as [ [] | ] eqn:E; cbn in *; eauto. + erewrite lookup_annotate_env; eauto. cbn. destruct nth_error as [ [] | ]; cbn in *; eauto. destruct nth_error as [ [] | ]; cbn in *; eauto. repeat split. len. solve_all. - - destruct lookup_env as [ [] | ]; cbn in *; eauto. + - destruct lookup_env as [ [] | ] eqn:E; cbn in *; eauto. + erewrite lookup_annotate_env; eauto. cbn. destruct nth_error as [ [] | ]; cbn in *; eauto. repeat split. eauto. solve_all. rewrite map_length. rewrite <- app_length. - eapply a0. len. rewrite gen_many_fresh_length. eauto. + eapply a; eauto. len. rewrite gen_many_fresh_length. eauto. - split. { clear - H. generalize ((List.rev (gen_many_fresh Γ ( (map dname m))) ++ Γ)). induction m in Γ, H |- *; cbn. - econstructor. - intros. destruct a; cbn in *. destruct dname; cbn; rtoProp; repeat split; eauto. all: destruct dbody; cbn in *; eauto. - } { solve_all. unfold wf_fix in *. rtoProp. split. rewrite map2_length gen_many_fresh_length map_length. @@ -970,6 +994,7 @@ Proof. eapply All_impl in H1. 2:{ intros ? [[] ]. specialize (i (List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). revert i. rewrite ?List.rev_length app_length ?List.rev_length gen_many_fresh_length ?List.rev_length map_length. intros r. eapply r in i1. exact i1. + eapply incl_appr. eauto. } revert H1. generalize ((List.rev (gen_many_fresh Γ (map dname m)) ++ Γ)). @@ -982,6 +1007,12 @@ Proof. } Qed. +Lemma wellformed_annotate Σ Γ s : + wellformed (efl := extraction_env_flags) Σ #|Γ| s -> wellformed (efl := named_extraction_env_flags) (annotate_env Γ Σ) #|Γ| (annotate Γ s). +Proof. + eapply wellformed_annotate'. firstorder. +Qed. + Lemma nclosed_represents Σ Γ E s : wellformed Σ #|Γ| s -> Γ ;;; E ⊩ annotate Γ s ~ s. Proof. @@ -1385,7 +1416,6 @@ Proof. eapply IHt; eauto. intros ? []; cbn; eauto. - destruct n; eauto. cbn in *. rtoProp. repeat split; eauto. eapply IHt2; eauto. eapply incl_cons; cbn; eauto. - eapply incl_tl; eauto. - rtoProp; split; eauto. - solve_all. - rtoProp; split; solve_all; rtoProp; eauto; repeat split; solve_all. From 6a1428acb3f8073dc9f84a3b3f42e6fe8d6f8d1e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Jul 2023 09:58:23 +0200 Subject: [PATCH 38/65] WIP stronger global weakening theorems for optimizations --- erasure/_CoqProject.in | 1 + erasure/theories/EEnvMap.v | 48 +++- erasure/theories/EEtaExpanded.v | 7 +- erasure/theories/EEtaExpandedFix.v | 5 +- erasure/theories/EExtends.v | 18 +- erasure/theories/EGenericGlobalMap.v | 390 ++++++++++++++++++++++++++ erasure/theories/EGenericMapEnv.v | 59 ++-- erasure/theories/EGlobalEnv.v | 5 +- erasure/theories/EGlobalFragment.v | 143 ++++++++++ erasure/theories/EInlineProjections.v | 211 ++++++-------- erasure/theories/EOptimizePropDiscr.v | 17 +- erasure/theories/EWellformed.v | 34 ++- 12 files changed, 776 insertions(+), 162 deletions(-) create mode 100644 erasure/theories/EGenericGlobalMap.v create mode 100644 erasure/theories/EGlobalFragment.v diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in index ed2993839..3a16a4112 100644 --- a/erasure/_CoqProject.in +++ b/erasure/_CoqProject.in @@ -13,6 +13,7 @@ theories/EWcbvEvalNamed.v # theories/EWtAst.v theories/EGlobalEnv.v theories/EGenericMapEnv.v +theories/EGenericGlobalMap.v theories/EWellformed.v theories/EEnvMap.v theories/EWcbvEvalInd.v diff --git a/erasure/theories/EEnvMap.v b/erasure/theories/EEnvMap.v index c2c3875ad..23fa1759f 100644 --- a/erasure/theories/EEnvMap.v +++ b/erasure/theories/EEnvMap.v @@ -1,4 +1,4 @@ -From Coq Require Import ssreflect ssrbool. +From Coq Require Import ssreflect ssrbool Morphisms Setoid. From Equations Require Import Equations. From MetaCoq.Utils Require Import utils. From MetaCoq.Common Require Import Kernames EnvMap BasicAst. @@ -15,6 +15,52 @@ Module GlobalContextMap. repr : EnvMap.repr global_decls map; wf : EnvMap.fresh_globals global_decls }. + Program Definition empty : t := + {| global_decls := []; + map := EnvMap.empty |}. + Next Obligation. + constructor. + Qed. + + Program Definition add (Σ : GlobalContextMap.t) kn d (hpre : fresh_global kn Σ) : GlobalContextMap.t := + {| global_decls := (kn,d) :: Σ.(global_decls); + map := EnvMap.add kn d Σ.(map) |}. + Next Obligation. + simpl. unfold KernameMapFact.uncurry. + pose proof (Σ.(repr)). unfold EnvMap.repr in H. + now rewrite H. + Qed. + Next Obligation. + constructor => //. apply Σ.(wf). + Qed. + + Definition global_context_map_equal Σ Σ' := + Σ.(global_decls) = Σ'.(global_decls). + + #[global] Instance gceq : DefaultRelation global_context_map_equal := {}. + + Lemma global_context_map_ind (P : GlobalContextMap.t -> Prop) + (proper : Morphisms.Proper (global_context_map_equal ==> iff) P) + (Pnil : P empty) + (Pcons : + forall Σ kn d fr, + P Σ -> + P (add Σ kn d fr)) + Σ : P Σ. + Proof. + destruct Σ as [Σ ? ? ?]. + induction Σ in map0, repr0, wf0 |- *; set (Σ':= {| global_decls := _ |}). + - setoid_replace Σ' with empty => //. + - set (Σg := {| global_decls := Σ; map := EnvMap.of_global_env Σ; repr := EnvMap.repr_global_env _; + wf := fresh_globals_cons_inv wf0 |}). + destruct a as [kn d]. + assert (fresh_global kn Σ). now depelim wf0. + setoid_replace Σ' with (add Σg kn d H). + apply Pcons. apply IHΣ. + red. unfold Σ', add. + cbn. reflexivity. + Qed. + Definition lookup_env Σ kn := EnvMap.lookup kn Σ.(map). Lemma lookup_env_spec (Σ : t) kn : lookup_env Σ kn = EGlobalEnv.lookup_env Σ kn. diff --git a/erasure/theories/EEtaExpanded.v b/erasure/theories/EEtaExpanded.v index 90415ebc3..654e4e733 100644 --- a/erasure/theories/EEtaExpanded.v +++ b/erasure/theories/EEtaExpanded.v @@ -5,7 +5,7 @@ From Coq Require Import Utf8 Program. From MetaCoq.Utils Require Import utils. From MetaCoq.Common Require Import config Kernames EnvMap BasicAst. -From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EGlobalEnv EWellformed ELiftSubst ESpineView ECSubst EWcbvEval EWcbvEvalInd EProgram. +From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EGlobalEnv EExtends EWellformed ELiftSubst ESpineView ECSubst EWcbvEval EWcbvEvalInd EProgram. Local Open Scope string_scope. Set Asymmetric Patterns. @@ -372,7 +372,7 @@ Fixpoint isEtaExp_env (Σ : global_declarations) := Lemma isEtaExp_lookup_ext {Σ} {kn d}: isEtaExp_env Σ -> lookup_env Σ kn = Some d -> - ∑ Σ', extends Σ' Σ × isEtaExp_decl Σ' d. + ∑ Σ', extends_prefix Σ' Σ × isEtaExp_decl Σ' d. Proof. induction Σ; cbn. - move=> _; rewrite /declared_constant /lookup_env /= //. @@ -442,7 +442,8 @@ Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}: Proof. move=> etaΣ wfΣ. move/(isEtaExp_lookup_ext etaΣ) => [Σ' []] ext hd. - now eapply isEtaExp_extends_decl. + eapply isEtaExp_extends_decl; eauto. + now eapply extends_prefix_extends. Qed. Section expanded. diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v index 57656b29b..8c14b356c 100644 --- a/erasure/theories/EEtaExpandedFix.v +++ b/erasure/theories/EEtaExpandedFix.v @@ -946,7 +946,7 @@ Qed. Lemma isEtaExp_lookup_ext {Σ} {kn d}: isEtaExp_env Σ -> lookup_env Σ kn = Some d -> - ∑ Σ', extends Σ' Σ × isEtaExp_decl Σ' d. + ∑ Σ', extends_prefix Σ' Σ × isEtaExp_decl Σ' d. Proof. induction Σ; cbn. - move=> _; rewrite /declared_constant /lookup_env /= //. @@ -1017,7 +1017,8 @@ Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}: Proof. move=> etaΣ wfΣ. move/(isEtaExp_lookup_ext etaΣ) => [Σ' []] ext hd. - now eapply isEtaExp_extends_decl. + eapply isEtaExp_extends_decl; eauto. + now eapply extends_prefix_extends. Qed. Arguments lookup_inductive_pars_constructor_pars_args {Σ ind n pars args}. diff --git a/erasure/theories/EExtends.v b/erasure/theories/EExtends.v index 869687c06..a431160c6 100644 --- a/erasure/theories/EExtends.v +++ b/erasure/theories/EExtends.v @@ -45,13 +45,29 @@ Section EEnvFlags. split; eauto. eapply weakening_env_declared_inductive; eauto. Qed. - Lemma extends_wf_glob {Σ Σ'} : extends Σ Σ' -> wf_glob Σ' -> wf_glob Σ. + Lemma extends_wf_glob {Σ Σ'} : extends_prefix Σ Σ' -> wf_glob Σ' -> wf_glob Σ. Proof using Type. intros [? ->]. induction x; cbn; auto. intros wf; depelim wf. eauto. Qed. + Lemma extends_prefix_extends Σ Σ' : + extends_prefix Σ Σ' -> wf_glob Σ' -> + extends Σ Σ'. + Proof. + intros [Σ'' ->]. + induction Σ''; cbn; auto. + - unfold extends; tauto. + - intros wf; depelim wf. + specialize (IHΣ'' wf). + red in IHΣ''. intros ? ? H'; specialize (IHΣ'' _ _ H'). + cbn. + case: (eqb_spec kn0 kn). + + intros <-. now eapply lookup_env_Some_fresh in IHΣ''. + + now intros _. + Qed. + Definition global_subset (Σ Σ' : global_declarations) := forall kn d, lookup_env Σ kn = Some d -> lookup_env Σ' kn = Some d. diff --git a/erasure/theories/EGenericGlobalMap.v b/erasure/theories/EGenericGlobalMap.v new file mode 100644 index 000000000..4c80c5a2a --- /dev/null +++ b/erasure/theories/EGenericGlobalMap.v @@ -0,0 +1,390 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Utf8 Program. +From MetaCoq.Utils Require Import utils. +From MetaCoq.Common Require Import config Kernames BasicAst EnvMap. +From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. + +Local Open Scope string_scope. +Set Asymmetric Patterns. +Import MCMonadNotation. + +From Equations Require Import Equations. +Set Equations Transparent. +Local Set Keyed Unification. +Require Import ssreflect ssrbool. + +Class GenTransform := + gen_transform : GlobalContextMap.t -> term -> term. + +Section GenTransformEnv. + Context {GT : GenTransform}. + + Definition gen_transform_constant_decl Σ cb := + {| cst_body := option_map (gen_transform Σ) cb.(cst_body) |}. + + Definition gen_transform_decl Σ d := + match d with + | ConstantDecl cb => ConstantDecl (gen_transform_constant_decl Σ cb) + | InductiveDecl idecl => d + end. + + Definition gen_transform_env Σ := + map (on_snd (gen_transform_decl Σ)) Σ.(GlobalContextMap.global_decls). + + Program Fixpoint gen_transform_env' Σ : EnvMap.fresh_globals Σ -> global_context := + match Σ with + | [] => fun _ => [] + | hd :: tl => fun HΣ => + let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in + on_snd (gen_transform_decl Σg) hd :: gen_transform_env' tl (fresh_globals_cons_inv HΣ) + end. +End GenTransformEnv. + +Class GenTransformExtends (efl efl' : EEnvFlags) (GT : GenTransform) := + wellformed_gen_transform_extends : forall {Σ : GlobalContextMap.t} t, + forall n, @EWellformed.wellformed efl Σ n t -> + forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> + @wf_glob efl Σ -> @wf_glob efl Σ' -> + gen_transform Σ t = gen_transform Σ' t. + +Class GenTransformWf (efl efl' : EEnvFlags) (GT : GenTransform) := +{ gen_transform_pre : GlobalContextMap.t -> term -> Prop; + gtwf_axioms_efl : forall _ : is_true (@has_axioms efl), is_true (@has_axioms efl'); + gtwf_cstrs_efl : forall _ : is_true (@has_cstr_params efl), is_true (@has_cstr_params efl'); + + gen_transform_wellformed : forall {Σ : GlobalContextMap.t} n t, + has_tBox -> has_tRel -> gen_transform_pre Σ t -> + @wf_glob efl Σ -> @EWellformed.wellformed efl Σ n t -> + EWellformed.wellformed (efl := efl') (gen_transform_env Σ) n (gen_transform Σ t) }. + +Section sec. + Context {efl efl' gen_transform} {gt : GenTransformExtends efl efl' gen_transform}. + +Import EGlobalEnv EExtends. + + +Lemma wellformed_gen_transform_decl_extends {Σ : GlobalContextMap.t} t : + @wf_global_decl efl Σ t -> + forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> @wf_glob efl Σ -> @wf_glob efl Σ' -> + gen_transform_decl Σ t = gen_transform_decl Σ' t. +Proof. +destruct t => /= //. +intros wf Σ' ext wfΣ wf'. f_equal. unfold gen_transform_constant_decl. f_equal. +destruct (cst_body c) => /= //. f_equal. +now eapply wellformed_gen_transform_extends. +Qed. + +Lemma lookup_env_gen_transform_env_Some {Σ : GlobalContextMap.t} kn d : + @wf_glob efl Σ -> + lookup_env Σ kn = Some d -> + ∑ Σ' : GlobalContextMap.t, + [× extends_prefix Σ' Σ, @wf_global_decl efl Σ' d & + lookup_env (gen_transform_env Σ) kn = Some (gen_transform_decl Σ' d)]. +Proof. + destruct Σ as [Σ ? ? ?]. cbn. + revert map repr wf. + induction Σ in |- *; simpl; auto => //. + intros map repr fr wfg. + case: eqb_specT => //. + - intros ->. cbn. intros [= <-]. + exists (GlobalContextMap.make Σ (fresh_globals_cons_inv fr)). split. + now eexists [_]. + cbn. now depelim wfg. + f_equal. symmetry. eapply wellformed_gen_transform_decl_extends. cbn. now depelim wfg. + eapply (@extends_prefix_extends efl) => //. + cbn. now exists [a]. now depelim wfg. auto. + - intros _. + cbn in IHΣ. + specialize (IHΣ (EnvMap.of_global_env Σ) (EnvMap.repr_global_env _) (fresh_globals_cons_inv fr)). + forward IHΣ. now depelim wfg. + intros hl. specialize (IHΣ hl) as [Σ'' [ext wfgd hl']]. + exists Σ''. split => //. + * destruct ext as [? ->]. + now exists (a :: x). + * rewrite -hl'. f_equal. + clear -wfg gt. + eapply map_ext_in => kn hin. unfold on_snd. f_equal. + symmetry. eapply wellformed_gen_transform_decl_extends => //. cbn. + eapply lookup_env_In in hin. 2:now depelim wfg. + depelim wfg. eapply lookup_env_wellformed; tea. + eapply (@extends_prefix_extends efl) => //. + cbn. now exists [a]. now depelim wfg. +Qed. + +Lemma lookup_env_map_snd Σ f kn : lookup_env (List.map (on_snd f) Σ) kn = option_map f (lookup_env Σ kn). +Proof. +induction Σ; cbn; auto. +case: eqb_spec => //. +Qed. + +Lemma lookup_env_gen_transform_env_None {Σ : GlobalContextMap.t} kn : +lookup_env Σ kn = None -> +lookup_env (gen_transform_env Σ) kn = None. +Proof. +cbn. intros hl. rewrite lookup_env_map_snd hl //. +Qed. + +Lemma lookup_env_gen_transform {Σ : GlobalContextMap.t} kn : +@wf_glob efl Σ -> +lookup_env (gen_transform_env Σ) kn = option_map (gen_transform_decl Σ) (lookup_env Σ kn). +Proof. +intros wf. +destruct (lookup_env Σ kn) eqn:hl. +- eapply lookup_env_gen_transform_env_Some in hl as [Σ' [ext wf' hl']] => /=. + rewrite hl'. f_equal. + eapply wellformed_gen_transform_decl_extends; eauto. + eapply (@extends_prefix_extends efl); auto. + eapply extends_wf_glob; eauto. + auto. + +- cbn. now eapply lookup_env_gen_transform_env_None in hl. +Qed. + + +Lemma is_propositional_gen_transform {Σ : GlobalContextMap.t} ind : + @wf_glob efl Σ -> + inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (gen_transform_env Σ) ind. +Proof. + rewrite /inductive_isprop_and_pars => wf. + rewrite /lookup_inductive /lookup_minductive. + rewrite (lookup_env_gen_transform (inductive_mind ind) wf). + rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive + /GlobalContextMap.lookup_minductive. + destruct lookup_env as [[decl|]|] => //. +Qed. + +Lemma is_propositional_cstr_gen_transform {Σ : GlobalContextMap.t} ind c : + @wf_glob efl Σ -> + constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (gen_transform_env Σ) ind c. +Proof. + rewrite /constructor_isprop_pars_decl => wf. + rewrite /lookup_constructor /lookup_inductive /lookup_minductive. + rewrite (lookup_env_gen_transform (inductive_mind ind) wf). + rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive + /GlobalContextMap.lookup_minductive. + destruct lookup_env as [[decl|]|] => //. +Qed. + +Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end. +Proof. + induction l using rev_ind; cbn. + - now rewrite andb_true_r. + - rewrite mkApps_app /=. now destruct l => /= //; rewrite andb_false_r. +Qed. + +Lemma lookup_constructor_gen_transform {Σ : GlobalContextMap.t} {ind c} : + @wf_glob efl Σ -> + lookup_constructor Σ ind c = lookup_constructor (gen_transform_env Σ) ind c. +Proof. + intros wfΣ. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. + rewrite lookup_env_gen_transform // /=. destruct lookup_env => // /=. + destruct g => //. +Qed. + +Lemma lookup_projection_gen_transform {Σ : GlobalContextMap.t} {p} : + @wf_glob efl Σ -> + lookup_projection Σ p = lookup_projection (gen_transform_env Σ) p. +Proof. + intros wfΣ. rewrite /lookup_projection. + rewrite -lookup_constructor_gen_transform //. +Qed. + +Lemma constructor_isprop_pars_decl_inductive {Σ ind c} {prop pars cdecl} : + constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> + inductive_isprop_and_pars Σ ind = Some (prop, pars). +Proof. + rewrite /constructor_isprop_pars_decl /inductive_isprop_and_pars /lookup_constructor. + destruct lookup_inductive as [[mdecl idecl]|]=> /= //. + destruct nth_error => //. congruence. +Qed. + +Lemma constructor_isprop_pars_decl_constructor {Σ ind c} {mdecl idecl cdecl} : + lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> + constructor_isprop_pars_decl Σ ind c = Some (ind_propositional idecl, ind_npars mdecl, cdecl). +Proof. + rewrite /constructor_isprop_pars_decl. intros -> => /= //. +Qed. + +Lemma wf_mkApps (ha : has_tApp) Σ k f args : reflect (wellformed Σ k f /\ forallb (wellformed Σ k) args) (wellformed Σ k (mkApps f args)). +Proof. + rewrite wellformed_mkApps //. eapply andP. +Qed. + +Lemma extends_cons_inv Σ kn d Σ' : + extends ((kn, d) :: Σ) Σ' -> + fresh_global kn Σ -> + extends Σ Σ'. +Proof. + intros ext fr kn' d' hl. + apply ext. rewrite elookup_env_cons_fresh => //. + intros <-. now apply lookup_env_Some_fresh in hl. +Qed. + +Lemma extends_cons_wf Σ a : + @wf_glob efl (a :: Σ) -> + extends Σ (a :: Σ). +Proof. + intros hwf; depelim hwf. + now apply extends_fresh. +Qed. + +Lemma gen_transform_env_extends' {Σ Σ' : GlobalContextMap.t} : + extends Σ Σ' -> + @wf_glob efl Σ -> + @wf_glob efl Σ' -> + List.map (on_snd (gen_transform_decl Σ)) Σ.(GlobalContextMap.global_decls) = + List.map (on_snd (gen_transform_decl Σ')) Σ.(GlobalContextMap.global_decls). +Proof. + intros ext. + move=> wfΣ wfΣ'. + assert (Hext : extends Σ Σ); auto. red; tauto. + generalize wfΣ. + revert Hext. + generalize Σ at 1 3 5 6. + intros [Σ'' ? ? ?]. revert map repr wf. + induction Σ'' => //; intros map repr wf. cbn. + intros hin wfg. depelim wfg. + f_equal. + 2:{ eapply (IHΣ'' (EnvMap.of_global_env Σ'') (EnvMap.repr_global_env _) (fresh_globals_cons_inv wf)). + now apply extends_cons_inv in hin. now cbn. } + unfold on_snd. cbn. f_equal. + eapply wellformed_gen_transform_decl_extends => //. cbn. + eapply extends_wf_global_decl => //. 2:tea. + now apply extends_cons_inv in hin. +Qed. + +Lemma gen_transform_env_eq (Σ : GlobalContextMap.t) : @wf_glob efl Σ -> + gen_transform_env Σ = gen_transform_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). +Proof. + intros wf. + unfold gen_transform_env. + destruct Σ as [Σ ? ? ?]; cbn in *. + induction Σ in map, repr, wf0, wf |- * => //. + cbn. f_equal. + destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. + eapply wellformed_gen_transform_decl_extends => //. cbn. now depelim wf. + now apply extends_cons_wf. now depelim wf. + erewrite <- (IHΣ (EnvMap.of_global_env _) (EnvMap.repr_global_env _) (fresh_globals_cons_inv wf0)). + set (nΣ := {| GlobalContextMap.global_decls := Σ|}). + 2:now depelim wf. + symmetry. cbn. + change Σ with nΣ.(GlobalContextMap.global_decls). + eapply gen_transform_env_extends'; eauto. + now apply extends_cons_wf. now depelim wf. +Qed. + +Import EWellformed. + +Lemma gen_transform_wellformed_irrel {Σ : GlobalContextMap.t} t : + @wf_glob efl Σ -> + forall n, wellformed (efl := efl) Σ n t -> + wellformed (efl := efl) (gen_transform_env Σ) n t. +Proof. + intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. + all:try solve [intros; unfold wf_fix_gen in *; rtoProp; intuition eauto; solve_all]. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=. + destruct g eqn:hg => /= //. destruct (cst_body c); cbn; eauto. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. + destruct g eqn:hg => /= //; intros; rtoProp; eauto. + repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; eauto. solve_all. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=. + destruct g eqn:hg => /= //. subst g. + destruct nth_error => /= //. + intros; rtoProp; intuition auto; solve_all. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; repeat split; eauto. + destruct g eqn:hg => /= //. +Qed. + +Lemma gen_transform_wellformed_decl_irrel {Σ : GlobalContextMap.t} d : + @wf_glob efl Σ -> + wf_global_decl (efl:= efl) Σ d -> + wf_global_decl (efl := efl) (gen_transform_env Σ) d. +Proof. + intros wf; destruct d => /= //. + destruct (cst_body c) => /= //. + now eapply gen_transform_wellformed_irrel. +Qed. + +Context {GTWF : GenTransformWf efl efl' gen_transform}. + + +Definition Pre_decl Σ d := match d with ConstantDecl cb => match cb.(cst_body) with + | Some b => gen_transform_pre Σ b | _ => True end | _ => True end. + +Lemma gen_transform_decl_wf {Σ : GlobalContextMap.t} : + has_tBox -> has_tRel -> @wf_glob efl Σ -> + forall d, @wf_global_decl efl Σ d -> Pre_decl Σ d -> + wf_global_decl (efl := efl') (gen_transform_env Σ) (gen_transform_decl Σ d). +Proof. + intros hasb hasr wf d. + intros hd. intros pre. + move: hd. + destruct d => /= //. cbn in pre. + destruct (cst_body c) => /= //. + intros hwf. eapply gen_transform_wellformed => //. apply gtwf_axioms_efl. auto. + destruct m => //. cbn. unfold wf_minductive. + cbn. move/andP => [] hp //. rtoProp. solve_all. + eapply orb_true_iff. eapply orb_true_iff in hp as []; eauto. + left. eapply gtwf_cstrs_efl. now rewrite H. +Qed. + +Lemma fresh_global_gen_transform_env {Σ : GlobalContextMap.t} kn : + fresh_global kn Σ -> + fresh_global kn (gen_transform_env Σ). +Proof. + destruct Σ as [Σ ? ? ?]. + induction Σ in map, repr, wf |- *; auto. + intros fr; depelim fr. red. + now eapply Forall_map; cbn. +Qed. + +Fixpoint Pre_glob Σ : EnvMap.fresh_globals Σ -> Prop := + match Σ with + | nil => fun _ => True + | (kn, d) :: Σ => fun HΣ => + let Σg := GlobalContextMap.make Σ (fresh_globals_cons_inv HΣ) in + Pre_decl Σg d /\ Pre_glob Σ (fresh_globals_cons_inv HΣ) + end. + +Import GlobalContextMap (repr, map, global_decls, wf). +Lemma gen_transform_env_wf {Σ : GlobalContextMap.t} : + has_tBox -> has_tRel -> + @wf_glob efl Σ -> Pre_glob Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf) -> wf_glob (efl := efl') (gen_transform_env Σ). +Proof. + intros hasb hasrel wfg pre. + rewrite gen_transform_env_eq //. + destruct Σ as [Σ ? ? ?]. cbn in *. revert pre. + induction Σ in map0, repr0, wf0, wfg |- *; auto; cbn; constructor; auto. + - eapply IHΣ. eapply EnvMap.repr_global_env. now depelim wfg. + destruct a. apply pre. + - cbn. + set (Σp := GlobalContextMap.make Σ _). + specialize (IHΣ (GlobalContextMap.map Σp) (GlobalContextMap.repr Σp) (fresh_globals_cons_inv wf0)). + rewrite /= -(gen_transform_env_eq Σp) => //. now depelim wfg. + eapply gen_transform_decl_wf => //. now depelim wfg. cbn. now depelim wfg. + destruct a. apply pre. + - cbn. + set (Σp := {| global_decls := Σ; map := EnvMap.of_global_env Σ; repr := EnvMap.repr_global_env _; + wf := (fresh_globals_cons_inv wf0) |}). + rewrite /= -(gen_transform_env_eq Σp) => //. now depelim wfg. + eapply fresh_global_gen_transform_env. cbn. now depelim wf0. +Qed. + +(* Definition gen_transform_program (p : eprogram_env) := + (gen_transform_env p.1, gen_transform p.1 p.2). + +Definition gen_transform_program_wf (p : eprogram_env) {hastbox : has_tBox} {hastrel : has_tRel} : + wf_eprogram_env efl p -> wf_eprogram (efl') (gen_transform_program p). +Proof. + intros []; split. + now eapply gen_transform_env_wf. + cbn. eapply gen_transform_wellformed_irrel => //. now eapply gen_transform_wellformed. +Qed. *) + +End sec. \ No newline at end of file diff --git a/erasure/theories/EGenericMapEnv.v b/erasure/theories/EGenericMapEnv.v index 85a0f7446..c5a0b4853 100644 --- a/erasure/theories/EGenericMapEnv.v +++ b/erasure/theories/EGenericMapEnv.v @@ -55,16 +55,16 @@ Variable efl : EEnvFlags. Hypothesis wellformed_gen_transform_extends : forall {Σ : global_context} t, forall n, EWellformed.wellformed Σ n t -> -forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' -> +forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ -> wf_glob Σ' -> gen_transform Σ t = gen_transform Σ' t. Lemma wellformed_gen_transform_decl_extends {Σ : global_context} t : wf_global_decl Σ t -> -forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' -> +forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ -> wf_glob Σ' -> gen_transform_decl Σ t = gen_transform_decl Σ' t. Proof. destruct t => /= //. -intros wf Σ' ext wf'. f_equal. unfold gen_transform_constant_decl. f_equal. +intros wf Σ' ext wfΣ wf'. f_equal. unfold gen_transform_constant_decl. f_equal. destruct (cst_body c) => /= //. f_equal. now eapply wellformed_gen_transform_extends. Qed. @@ -73,7 +73,7 @@ Lemma lookup_env_gen_transform_env_Some {Σ : global_context} kn d : wf_glob Σ -> lookup_env Σ kn = Some d -> ∑ Σ' : global_context, - [× extends Σ' Σ, wf_global_decl Σ' d & + [× extends_prefix Σ' Σ, wf_global_decl Σ' d & lookup_env (gen_transform_env Σ) kn = Some (gen_transform_decl Σ' d)]. Proof. induction Σ in |- *; simpl; auto => //. @@ -83,7 +83,8 @@ case: eqb_specT => //. now eexists [_]. cbn. now depelim wfg. f_equal. symmetry. eapply wellformed_gen_transform_decl_extends. cbn. now depelim wfg. - cbn. now exists [a]. now cbn. + eapply extends_prefix_extends => //. + cbn. now exists [a]. now depelim wfg. auto. - intros _. cbn in IHΣ. forward IHΣ. now depelim wfg. intros hl. specialize (IHΣ hl) as [Σ'' [ext wfgd hl']]. @@ -96,7 +97,8 @@ case: eqb_specT => //. symmetry. eapply wellformed_gen_transform_decl_extends => //. cbn. eapply lookup_env_In in hin. 2:now depelim wfg. depelim wfg. eapply lookup_env_wellformed; tea. - cbn. now exists [a]. + eapply extends_prefix_extends => //. + cbn. now exists [a]. now depelim wfg. Qed. Lemma lookup_env_map_snd Σ f kn : lookup_env (List.map (on_snd f) Σ) kn = option_map f (lookup_env Σ kn). @@ -120,7 +122,10 @@ intros wf. destruct (lookup_env Σ kn) eqn:hl. - eapply lookup_env_gen_transform_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. - eapply wellformed_gen_transform_decl_extends; eauto. auto. + eapply wellformed_gen_transform_decl_extends; eauto. + eapply extends_prefix_extends; auto. + eapply extends_wf_glob; eauto. + auto. - cbn. now eapply lookup_env_gen_transform_env_None in hl. Qed. @@ -195,28 +200,45 @@ Proof. rewrite wellformed_mkApps //. eapply andP. Qed. +Lemma extends_cons_inv Σ kn d Σ' : + extends ((kn, d) :: Σ) Σ' -> + fresh_global kn Σ -> + extends Σ Σ'. +Proof. + intros ext fr kn' d' hl. + apply ext. rewrite elookup_env_cons_fresh => //. + intros <-. now apply lookup_env_Some_fresh in hl. +Qed. + +Lemma extends_cons_wf Σ a : + wf_glob (a :: Σ) -> + extends Σ (a :: Σ). +Proof. + intros hwf; depelim hwf. + now apply extends_fresh. +Qed. + Lemma gen_transform_env_extends' {Σ Σ' : global_context} : extends Σ Σ' -> + wf_glob Σ -> wf_glob Σ' -> List.map (on_snd (gen_transform_decl Σ)) Σ = List.map (on_snd (gen_transform_decl Σ')) Σ. Proof. intros ext. - move=> wfΣ. - assert (Hext : extends Σ Σ); auto. now exists []. - assert (Hwfg : wf_glob Σ). - { eapply extends_wf_glob. exact ext. tea. } - revert Hext Hwfg. + move=> wfΣ wfΣ'. + assert (Hext : extends Σ Σ); auto. red; tauto. + generalize wfΣ. + revert Hext. generalize Σ at 1 3 5 6. intros Σ''. induction Σ'' => //. cbn. intros hin wfg. depelim wfg. f_equal. - 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. } + 2:{ eapply IHΣ'' => //. now apply extends_cons_inv in hin. } unfold on_snd. cbn. f_equal. eapply wellformed_gen_transform_decl_extends => //. cbn. - eapply extends_wf_global_decl. 3:tea. - eapply extends_wf_glob; tea. - destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. + eapply extends_wf_global_decl => //. 2:tea. + now apply extends_cons_inv in hin. Qed. Lemma gen_transform_env_eq (Σ : global_context) : wf_glob Σ -> gen_transform_env Σ = gen_transform_env' Σ. @@ -226,11 +248,12 @@ Proof. induction Σ => //. cbn. f_equal. destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. - eapply wellformed_gen_transform_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn. + eapply wellformed_gen_transform_decl_extends => //. cbn. now depelim wf. + now apply extends_cons_wf. now depelim wf. erewrite <- IHΣ. 2:now depelim wf. symmetry. eapply gen_transform_env_extends'; eauto. - cbn. now exists [a]. + now apply extends_cons_wf. now depelim wf. Qed. Variable Pre : global_context -> term -> Prop. diff --git a/erasure/theories/EGlobalEnv.v b/erasure/theories/EGlobalEnv.v index 97b6cf818..18887b1f8 100644 --- a/erasure/theories/EGlobalEnv.v +++ b/erasure/theories/EGlobalEnv.v @@ -183,7 +183,10 @@ Definition closed_env (Σ : EAst.global_declarations) := (** Environment extension and uniqueness of declarations in well-formed global environments *) -Definition extends (Σ Σ' : global_declarations) := ∑ Σ'', Σ' = (Σ'' ++ Σ)%list. +Definition extends (Σ Σ' : global_declarations) := + (forall kn decl, lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl). + +Definition extends_prefix (Σ Σ' : global_declarations) := ∑ Σ'', Σ' = Σ'' ++ Σ. Definition fresh_global kn (Σ : global_declarations) := Forall (fun x => x.1 <> kn) Σ. diff --git a/erasure/theories/EGlobalFragment.v b/erasure/theories/EGlobalFragment.v new file mode 100644 index 000000000..4a287eba6 --- /dev/null +++ b/erasure/theories/EGlobalFragment.v @@ -0,0 +1,143 @@ +From MetaCoq.Utils Require Import utils. +From MetaCoq.Common Require Import config Kernames uGraph. +From MetaCoq.Erasure Require Import EGlobalEnv ErasureFunction. +From MetaCoq.Erasure Require Import EAstUtils EArities Extract Prelim EDeps ErasureProperties ErasureCorrectness. +From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICSafeReduce PCUICSafeRetyping PCUICRetypingEnvIrrelevance. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive + PCUICReduction PCUICReflect PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICCasesContexts + PCUICWeakeningConv PCUICWeakeningTyp PCUICContextConversionTyp PCUICTyping PCUICGlobalEnv PCUICInversion PCUICGeneration + PCUICConfluence PCUICConversion PCUICUnivSubstitutionTyp PCUICCumulativity PCUICSR PCUICSafeLemmata PCUICNormalization + PCUICValidity PCUICPrincipality PCUICElimination PCUICOnFreeVars PCUICWellScopedCumulativity PCUICSN PCUICEtaExpand. + +(* Σ is a fragment of Σ' if every lookup in Σ gives the same result as Σ' *) +Definition eglobal_env_fragment Σ Σ' : + (forall kn decl, lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl). + +(* we use the [match] trick to get typeclass resolution to pick up the right instances without leaving any evidence in the resulting term, and without having to pass them manually everywhere *) +Notation NormalizationIn_erase_global_decls X decls + := (match extraction_checker_flags, extraction_normalizing return _ with + | cf, no + => forall n, + n < List.length decls -> + let X' := iter abstract_pop_decls (S n) X in + forall kn cb pf, + List.hd_error (List.skipn n decls) = Some (kn, ConstantDecl cb) -> + let Xext := abstract_make_wf_env_ext X' (cst_universes cb) pf in + forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ + end) + (only parsing). + +Program Fixpoint erase_global + {X_type : abstract_env_impl} (X : X_type.π1) (decls : global_declarations) + {normalization_in : NormalizationIn_erase_global_decls X decls} + (prop : forall Σ : global_env, abstract_env_rel X Σ -> Σ.(declarations) = decls) + : E.global_declarations := + match decls with + | [] => [] + | (kn, ConstantDecl cb) :: decls => + let X' := abstract_pop_decls X in + let Xext := abstract_make_wf_env_ext X' (cst_universes cb) _ in + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) + let cb' := @erase_constant_body X_type Xext normalization_in' cb _ in + let X'' := erase_global X' decls _ in + ((kn, E.ConstantDecl (fst cb')) :: X'') + | (kn, InductiveDecl mib) :: decls => + let X' := abstract_pop_decls X in + let mib' := erase_mutual_inductive_body mib in + let X'' := erase_global X' decls _ in + ((kn, E.InductiveDecl mib') :: X'') + + end. +Next Obligation. + pose proof (abstract_env_wf _ H) as [wf]. + pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_wf _ HX) as [wfX]. + assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). + { now eexists. } + destruct (abstract_pop_decls_correct X decls prop' _ _ HX H) as [? []]. + clear H. specialize (prop _ HX). destruct x, Σ, H0; cbn in *. + subst. sq. destruct wfX. depelim o0. destruct o1. split => //. +Qed. +Next Obligation. + cbv [id]. + unshelve eapply (normalization_in 0); cbn; try reflexivity; try lia. +Defined. +Next Obligation. + pose proof (abstract_env_ext_wf _ H) as [wf]. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[? HX']]. + pose proof (abstract_env_wf _ HX') as [wfX']. + pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_wf _ HX) as [wfX]. + assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). + { now eexists. } + pose proof (abstract_pop_decls_correct X decls prop' _ _ HX HX') as [? []]. + pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ HX' H). + clear H HX'. specialize (prop _ HX). destruct x, Σ as [[] u], H0; cbn in *. + subst. sq. inversion H3. subst. clear H3. destruct wfX. cbn in *. + rewrite prop in o0. depelim o0. destruct o1. exact on_global_decl_d. +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + pose proof (abstract_env_exists X) as [[? HX]]. + assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). + { now eexists. } + now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. +pose proof (abstract_env_exists X) as [[? HX]]. +assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). +{ now eexists. } +now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + pose proof (abstract_env_exists X) as [[? HX]]. + assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). + { now eexists. } + now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. +pose proof (abstract_env_exists X) as [[? HX]]. +assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). +{ now eexists. } +now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). +Qed. + + + +Lemma erase_global_fast_fragment + X_type deps X decls {normalization_in} (prf:forall Σ : global_env, abstract_env_rel X Σ -> declarations Σ = decls) : + eglobal_env_fragment + (@ErasureFunction.erase_global_fast X_type deps X decls normalization_in prf) + (@E) + + + +Lemma erase_program_fst {guard : abstract_guard_impl} (p p' : pcuic_program) + {normalization_in : PCUICTyping.wf_ext p.1 -> PCUICSN.NormalizationIn p.1} + {normalization_in' : PCUICTyping.wf_ext p'.1 -> PCUICSN.NormalizationIn p'.1} +{normalization_in_adjust_universes : PCUICTyping.wf_ext p.1 -> + PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p.1} +{normalization_in_adjust_universes' : PCUICTyping.wf_ext p'.1 -> +PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn + p'.1} wt wt' : +p.1 = p'.1 -> +(erase_program p wt).1 = (erase_program p' wt').1. +Proof. +destruct p, p'; intros; subst. cbn in H. subst g0. +unfold erase_program. +assert (map_squash fst wt = map_squash fst wt') by apply proof_irrelevance. +rewrite -H. cbn. +epose proof ErasureFunction.erase_irrel_global_env. +Abort.Lemma erase_global_fragment Σ + diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v index bcb098d42..178225ad4 100644 --- a/erasure/theories/EInlineProjections.v +++ b/erasure/theories/EInlineProjections.v @@ -33,6 +33,30 @@ Definition switch_no_params (efl : EEnvFlags) := |}. Definition flags_after_projs := (switch_no_params all_env_flags). Local Existing Instance flags_after_projs. + +Definition disable_projections_term_flags (et : ETermFlags) := + {| has_tBox := has_tBox + ; has_tRel := has_tRel + ; has_tVar := has_tVar + ; has_tEvar := has_tEvar + ; has_tLambda := has_tLambda + ; has_tLetIn := has_tLetIn + ; has_tApp := has_tApp + ; has_tConst := has_tConst + ; has_tConstruct := has_tConstruct + ; has_tCase := true + ; has_tProj := false + ; has_tFix := has_tFix + ; has_tCoFix := has_tCoFix + ; has_tPrim := has_tPrim + |}. + +Definition disable_projections_env_flag (efl : EEnvFlags) := + {| has_axioms := efl.(@has_axioms); + term_switches := disable_projections_term_flags term_switches; + has_cstr_params := efl.(@has_cstr_params) ; + cstr_as_blocks := efl.(@cstr_as_blocks) |}. + Arguments lookup_projection : simpl never. Arguments GlobalContextMap.lookup_projection : simpl never. @@ -323,7 +347,7 @@ Lemma lookup_env_optimize_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} k wf_glob Σ -> GlobalContextMap.lookup_env Σ kn = Some d -> ∑ Σ' : GlobalContextMap.t, - [× extends Σ' Σ, wf_global_decl Σ' d & + [× extends_prefix Σ' Σ, wf_global_decl Σ' d & lookup_env (optimize_env Σ) kn = Some (optimize_decl Σ' d)]. Proof. rewrite GlobalContextMap.lookup_env_spec. @@ -336,7 +360,8 @@ Proof. now eexists [_]. cbn. now depelim wfg. f_equal. symmetry. eapply wellformed_optimize_decl_extends. cbn. now depelim wfg. - cbn. now exists [a]. now cbn. + eapply extends_prefix_extends. + cbn. now exists [a]. now cbn. now cbn. - intros _. set (Σ' := GlobalContextMap.make Σ (fresh_globals_cons_inv wf)). specialize (IHΣ (GlobalContextMap.map Σ') (GlobalContextMap.repr Σ') (GlobalContextMap.wf Σ')). @@ -351,7 +376,8 @@ Proof. symmetry. eapply wellformed_optimize_decl_extends => //. cbn. eapply lookup_env_In in hin. 2:now depelim wfg. depelim wfg. eapply lookup_env_wellformed; tea. - cbn. now exists [a]. + eapply extends_prefix_extends. + cbn. now exists [a]. now cbn. Qed. Lemma lookup_env_map_snd Σ f kn : lookup_env (List.map (on_snd f) Σ) kn = option_map f (lookup_env Σ kn). @@ -378,7 +404,8 @@ Proof. destruct (GlobalContextMap.lookup_env Σ kn) eqn:hl. - eapply lookup_env_optimize_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. - eapply wellformed_optimize_decl_extends; eauto. auto. + eapply wellformed_optimize_decl_extends; eauto. + now eapply extends_prefix_extends. auto. - cbn. now eapply lookup_env_optimize_env_None in hl. Qed. @@ -729,88 +756,7 @@ Proof. apply optimize_expanded_irrel. Qed. -Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : - extends Σ Σ' -> - wf_glob Σ' -> - List.map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls) = - List.map (on_snd (optimize_decl Σ')) Σ.(GlobalContextMap.global_decls). -Proof. - intros ext. - destruct Σ as [Σ map repr wf]; cbn in *. - move=> wfΣ. - assert (extends Σ Σ); auto. now exists []. - assert (wf_glob Σ). - { eapply extends_wf_glob. exact ext. tea. } - revert H H0. - generalize Σ at 1 3 5 6. intros Σ''. - induction Σ'' => //. cbn. - intros hin wfg. depelim wfg. - f_equal. - 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. } - unfold on_snd. cbn. f_equal. - eapply wellformed_optimize_decl_extends => //. cbn. - eapply extends_wf_global_decl. 3:tea. - eapply extends_wf_glob; tea. - destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. -Qed. - -Lemma optimize_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> optimize_env Σ = optimize_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). -Proof. - intros wf. - unfold optimize_env. - destruct Σ; cbn. cbn in wf. - induction global_decls in map, repr, wf0, wf |- * => //. - cbn. f_equal. - destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. - eapply wellformed_optimize_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn. - set (Σg' := GlobalContextMap.make global_decls (fresh_globals_cons_inv wf0)). - erewrite <- (IHglobal_decls (GlobalContextMap.map Σg') (GlobalContextMap.repr Σg')). - 2:now depelim wf. - set (Σg := {| GlobalContextMap.global_decls := _ :: _ |}). - symmetry. eapply (optimize_env_extends' (Σ := Σg') (Σ' := Σg)) => //. - cbn. now exists [a]. -Qed. - -Lemma optimize_env_expanded {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - wf_glob Σ -> expanded_global_env Σ -> expanded_global_env (optimize_env Σ). -Proof. - unfold expanded_global_env; move=> wfg. - rewrite optimize_env_eq //. - destruct Σ as [Σ map repr wf]. cbn in *. - clear map repr. - induction 1; cbn; constructor; auto. - cbn in IHexpanded_global_declarations. - unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. - set (Σ' := GlobalContextMap.make _ _). - rewrite -(optimize_env_eq Σ'). cbn. now depelim wfg. - eapply (optimize_expanded_decl_irrel (Σ := Σ')). now depelim wfg. - now unshelve eapply (optimize_expanded_decl (Σ:=Σ')). -Qed. - -Definition disable_projections_term_flags (et : ETermFlags) := - {| has_tBox := has_tBox - ; has_tRel := has_tRel - ; has_tVar := has_tVar - ; has_tEvar := has_tEvar - ; has_tLambda := has_tLambda - ; has_tLetIn := has_tLetIn - ; has_tApp := has_tApp - ; has_tConst := has_tConst - ; has_tConstruct := has_tConstruct - ; has_tCase := true - ; has_tProj := false - ; has_tFix := has_tFix - ; has_tCoFix := has_tCoFix - ; has_tPrim := has_tPrim - |}. - -Definition disable_projections_env_flag (efl : EEnvFlags) := - {| has_axioms := efl.(@has_axioms); - term_switches := disable_projections_term_flags term_switches; - has_cstr_params := efl.(@has_cstr_params) ; - cstr_as_blocks := efl.(@cstr_as_blocks) |}. - -Lemma optimize_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : +Lemma optimize_wellformed_term {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_tBox -> has_tRel -> wf_glob Σ -> EWellformed.wellformed Σ n t -> EWellformed.wellformed (efl := disable_projections_env_flag efl) Σ n (optimize Σ t). @@ -862,52 +808,81 @@ Proof. intros; rtoProp; intuition auto; solve_all. Qed. -Lemma optimize_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : +Lemma optimize_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : + has_tBox -> has_tRel -> + wf_glob Σ -> EWellformed.wellformed Σ n t -> + EWellformed.wellformed (efl := disable_projections_env_flag efl) (optimize_env Σ) n (optimize Σ t). +Proof. + intros. apply optimize_wellformed_irrel => //. + now apply optimize_wellformed_term. +Qed. + +From MetaCoq.Erasure Require Import EGenericGlobalMap. + +#[local] +Instance GT : GenTransform := { gen_transform := optimize }. +#[local] +Instance GTExt efl : GenTransformExtends efl (disable_projections_env_flag efl) GT. +Proof. + intros Σ t n wfΣ Σ' ext wf wf'. + unfold gen_transform, GT. + eapply wellformed_optimize_extends; tea. +Qed. +#[local] +Instance GTWf efl : GenTransformWf efl (disable_projections_env_flag efl) GT. +Proof. + refine {| gen_transform_pre := fun _ _ => True |}; auto. + intros Σ n t hasb hasr _ wfΣ wft. + now apply optimize_wellformed. +Defined. + +Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : + extends Σ Σ' -> wf_glob Σ -> - wf_global_decl (efl:= disable_projections_env_flag efl) Σ d -> - wf_global_decl (efl := disable_projections_env_flag efl) (optimize_env Σ) d. + wf_glob Σ' -> + List.map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls) = + List.map (on_snd (optimize_decl Σ')) Σ.(GlobalContextMap.global_decls). Proof. - intros wf; destruct d => /= //. - destruct (cst_body c) => /= //. - now eapply optimize_wellformed_irrel. + intros. + epose proof (gen_transform_env_extends' (gt := GTExt efl)). + now eapply H2. Qed. -Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> wf_glob Σ -> - forall d, wf_global_decl Σ d -> - wf_global_decl (efl := disable_projections_env_flag efl) (optimize_env Σ) (optimize_decl Σ d). +Lemma optimize_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> optimize_env Σ = optimize_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). Proof. - intros hasb hasr wf d. - intros hd. - eapply optimize_wellformed_decl_irrel; tea; eauto. - move: hd. - destruct d => /= //. - destruct (cst_body c) => /= //. - intros hwf. eapply optimize_wellformed => //. + intros wf. + now apply (gen_transform_env_eq (gt := GTExt efl)). Qed. -Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : - fresh_global kn Σ -> - fresh_global kn (optimize_env Σ). +Lemma optimize_env_expanded {efl : EEnvFlags} {Σ : GlobalContextMap.t} : + wf_glob Σ -> expanded_global_env Σ -> expanded_global_env (optimize_env Σ). Proof. - destruct Σ as [Σ map repr wf]; cbn in *. + unfold expanded_global_env; move=> wfg. + rewrite optimize_env_eq //. + destruct Σ as [Σ map repr wf]. cbn in *. + clear map repr. induction 1; cbn; constructor; auto. - now eapply Forall_map; cbn. + cbn in IHexpanded_global_declarations. + unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. + set (Σ' := GlobalContextMap.make _ _). + rewrite -(optimize_env_eq Σ'). cbn. now depelim wfg. + eapply (optimize_expanded_decl_irrel (Σ := Σ')). now depelim wfg. + now unshelve eapply (optimize_expanded_decl (Σ:=Σ')). +Qed. + +Lemma Pre_glob efl Σ wf : Pre_glob (GTWF:=GTWf efl) Σ wf. +Proof. + induction Σ => //. destruct a as [kn d]; cbn. + split => //. destruct d as [[[|]]|] => //=. Qed. Lemma optimize_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : has_tBox -> has_tRel -> wf_glob Σ -> wf_glob (efl := disable_projections_env_flag efl) (optimize_env Σ). Proof. - intros hasb hasrel. - intros wfg. rewrite optimize_env_eq //. - destruct Σ as [Σ map repr wf]; cbn in *. - clear map repr. - induction wfg; cbn; constructor; auto. - - rewrite /= -(optimize_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. - eapply optimize_decl_wf => //. - - rewrite /= -(optimize_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. - now eapply fresh_global_optimize_env. + intros hasb hasre wfg. + eapply (gen_transform_env_wf (gt := GTExt efl)) => //. + apply Pre_glob. Qed. Definition optimize_program (p : eprogram_env) := @@ -918,7 +893,7 @@ Definition optimize_program_wf {efl : EEnvFlags} (p : eprogram_env) {hastbox : h Proof. intros []; split. now eapply optimize_env_wf. - cbn. eapply optimize_wellformed_irrel => //. now eapply optimize_wellformed. + cbn. now eapply optimize_wellformed. Qed. Definition optimize_program_expanded {efl} (p : eprogram_env) : diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index 70ad8701c..0cd56240e 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -405,7 +405,7 @@ Lemma lookup_env_remove_match_on_box_env_Some {efl : EEnvFlags} {Σ : GlobalCont wf_glob Σ -> GlobalContextMap.lookup_env Σ kn = Some d -> ∑ Σ' : GlobalContextMap.t, - [× extends Σ' Σ, wf_global_decl Σ' d & + [× extends_prefix Σ' Σ, wf_global_decl Σ' d & lookup_env (remove_match_on_box_env Σ) kn = Some (remove_match_on_box_decl Σ' d)]. Proof. rewrite GlobalContextMap.lookup_env_spec. @@ -418,7 +418,8 @@ Proof. now eexists [_]. cbn. now depelim wfg. f_equal. symmetry. eapply wellformed_remove_match_on_box_decl_extends. cbn. now depelim wfg. - cbn. now exists [a]. now cbn. + eapply extends_prefix_extends. + cbn. now exists [a]. now cbn. now cbn. - intros _. set (Σ' := GlobalContextMap.make Σ (fresh_globals_cons_inv wf)). specialize (IHΣ (GlobalContextMap.map Σ') (GlobalContextMap.repr Σ') (GlobalContextMap.wf Σ')). @@ -433,7 +434,7 @@ Proof. symmetry. eapply wellformed_remove_match_on_box_decl_extends => //. cbn. eapply lookup_env_In in hin. 2:now depelim wfg. depelim wfg. eapply lookup_env_wellformed; tea. - cbn. now exists [a]. + cbn. eapply extends_prefix_extends => //. now exists [a]. Qed. Lemma lookup_env_map_snd Σ f kn : lookup_env (List.map (on_snd f) Σ) kn = option_map f (lookup_env Σ kn). @@ -460,7 +461,8 @@ Proof. destruct (GlobalContextMap.lookup_env Σ kn) eqn:hl. - eapply lookup_env_remove_match_on_box_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. - eapply wellformed_remove_match_on_box_decl_extends; eauto. auto. + eapply wellformed_remove_match_on_box_decl_extends; eauto. + now eapply extends_prefix_extends. auto. - cbn. now eapply lookup_env_remove_match_on_box_env_None in hl. Qed. @@ -780,7 +782,7 @@ Proof. Qed. Lemma remove_match_on_box_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : - extends Σ Σ' -> + extends_prefix Σ Σ' -> wf_glob Σ' -> List.map (on_snd (remove_match_on_box_decl Σ)) Σ.(GlobalContextMap.global_decls) = List.map (on_snd (remove_match_on_box_decl Σ')) Σ.(GlobalContextMap.global_decls). @@ -788,7 +790,7 @@ Proof. intros ext. destruct Σ as [Σ map repr wf]; cbn in *. move=> wfΣ. - assert (extends Σ Σ); auto. now exists []. + assert (extends_prefix Σ Σ); auto. now exists []. assert (wf_glob Σ). { eapply extends_wf_glob. exact ext. tea. } revert H H0. @@ -801,7 +803,10 @@ Proof. eapply wellformed_remove_match_on_box_decl_extends => //. cbn. eapply extends_wf_global_decl. 3:tea. eapply extends_wf_glob; tea. + eapply extends_prefix_extends. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. + eapply extends_wf_glob; tea. cbn. + eapply extends_prefix_extends; tea. Qed. Lemma remove_match_on_box_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> remove_match_on_box_env Σ = remove_match_on_box_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). diff --git a/erasure/theories/EWellformed.v b/erasure/theories/EWellformed.v index 61a253be2..693297e44 100644 --- a/erasure/theories/EWellformed.v +++ b/erasure/theories/EWellformed.v @@ -415,18 +415,9 @@ Lemma extends_lookup {efl} {Σ Σ' c decl} : lookup_env Σ c = Some decl -> lookup_env Σ' c = Some decl. Proof. - intros wfΣ' [Σ'' ->]. simpl. - induction Σ'' in wfΣ', c, decl |- *. - - simpl. auto. - - specialize (IHΣ'' c decl). forward IHΣ''. - + now inv wfΣ'. - + intros HΣ. specialize (IHΣ'' HΣ). - inv wfΣ'. simpl in *. - case: eqb_spec; intros e; subst; auto. - apply lookup_env_Some_fresh in IHΣ''; contradiction. + intros wfΣ' Hl; apply Hl. Qed. - Lemma extends_lookup_constructor {efl} {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> forall ind c b, lookup_constructor Σ ind c = Some b -> @@ -482,14 +473,33 @@ Proof. now eapply extends_wellformed. Qed. +Lemma extends_fresh Σ kn d : + fresh_global kn Σ -> + extends Σ ((kn, d) :: Σ). +Proof. + induction 1 in d |- *. red. cbn => //. + intros kn' decl. + cbn. + destruct (eqb_spec x.1 kn) => //. + destruct (eqb_spec kn' x.1) => //. + - intros [= <-]. subst kn'. + destruct (eqb_spec x.1 kn) => //. + - intros hl. + destruct (eqb_spec kn' kn) => //. + subst. eapply (IHForall d) in hl. + now cbn in hl; move: hl; rewrite eqb_refl. +Qed. + Lemma lookup_env_wellformed {efl} {Σ kn decl} : wf_glob Σ -> EGlobalEnv.lookup_env Σ kn = Some decl -> wf_global_decl Σ decl. Proof. induction Σ; cbn => //. intros wf. depelim wf => /=. destruct (eqb_spec kn kn0). - move=> [= <-]. eapply extends_wf_global_decl; tea. constructor; auto. now eexists [_]. + move=> [= <-]. eapply extends_wf_global_decl; tea. constructor; auto. + now apply extends_fresh. intros hn. eapply extends_wf_global_decl; tea. 3:eapply IHΣ => //. - now constructor. now eexists [_]. + now constructor. + now apply extends_fresh. Qed. From e09e64d8000785ece4336394a66bb4c501e1cbbb Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 21 Aug 2023 14:44:09 +0200 Subject: [PATCH 39/65] Allow modifying inductive decls in generic weakenability translation proofs. Now parameter stripping is a weakenable translation. --- erasure/theories/EConstructorsAsBlocks.v | 95 ++++++--------- erasure/theories/EGenericGlobalMap.v | 61 ++++++---- erasure/theories/EInlineProjections.v | 19 ++- erasure/theories/EOptimizePropDiscr.v | 146 ++++++++++++----------- erasure/theories/ERemoveParams.v | 84 +++++++------ erasure/theories/EWcbvEvalNamed.v | 2 +- 6 files changed, 208 insertions(+), 199 deletions(-) diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v index 98368c0d1..829d0d089 100644 --- a/erasure/theories/EConstructorsAsBlocks.v +++ b/erasure/theories/EConstructorsAsBlocks.v @@ -817,78 +817,55 @@ Proof. eapply transform_wellformed'; eauto. Qed. -(*Lemma optimize_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : - wf_glob Σ -> - wf_global_decl (efl := env_flags) Σ d -> - wf_global_decl (efl := env_flags_blocks) (transform_blocks_env Σ) d. -Proof. - intros wf; destruct d => /= //. - destruct (cst_body c) => /= //. - intros wf'. eapply transform_wellformed. -Qed. *) +From MetaCoq.Erasure Require Import EGenericGlobalMap. -Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - has_cstr_params = false -> - cstr_as_blocks = false -> - has_tApp -> - wf_glob (efl := efl) Σ -> - forall d, - wf_global_decl (efl := efl) Σ d -> - isEtaExp_decl Σ d -> - wf_global_decl (efl := switch_cstr_as_blocks efl) (transform_blocks_env Σ) (transform_blocks_decl Σ d). +#[local] +Instance GT : GenTransform := { gen_transform := transform_blocks }. +#[local] +Instance GTExt efl : has_tApp -> GenTransformExtends efl (switch_cstr_as_blocks efl) GT. Proof. - intros hasp cstrbl hasapp wf d. - destruct d => /= //. - rewrite /isEtaExp_constant_decl. - destruct (cst_body c) => /= //. - intros hwf etat. eapply transform_wellformed => //. + intros Σ t n wfΣ Σ' ext wf wf'. + unfold gen_transform, GT. + eapply transform_blocks_extends; tea. Qed. - -Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : - fresh_global kn Σ -> - fresh_global kn (transform_blocks_env Σ). +#[local] +Instance GTWf efl : + GenTransformWf efl (switch_cstr_as_blocks efl) GT. Proof. - destruct Σ as [Σ map repr wf]; cbn in *. - induction 1; cbn; constructor; auto. - now eapply Forall_map; cbn. -Qed. - -Lemma fresh_global_map_on_snd Σ f kn : - fresh_global kn Σ -> - fresh_global kn (map (on_snd f) Σ). + refine {| gen_transform_pre := fun Σ t => + has_tApp /\ + has_cstr_params = false /\ + cstr_as_blocks = false /\ + isEtaExp Σ t |}; auto. + intros Σ n t [hasapp [cstrp [cstrb pre]]] wfΣ wft. + apply transform_wellformed => //. +Defined. + +Lemma Pre_glob efl Σ wf : + has_cstr_params = false -> + cstr_as_blocks = false -> + has_tApp -> + EEtaExpanded.isEtaExp_env Σ -> + Pre_glob (GTWF:=GTWf efl) Σ wf. Proof. - induction 1; cbn; constructor; auto. + intros cstrp cstrb happ. + induction Σ => //. destruct a as [kn d]; cbn. + split => //. destruct d as [[[|]]|] => //=. + repeat split => //. move/andP: H => /= [] /=. + now rewrite /isEtaExp_constant_decl /=. + eapply IHΣ. now move/andP: H. Qed. Lemma transform_wf_global {efl : EEnvFlags} {Σ : GlobalContextMap.t} : has_cstr_params = false -> cstr_as_blocks = false -> - has_tApp -> + has_tApp -> has_tBox -> has_tRel -> EEtaExpanded.isEtaExp_env Σ -> wf_glob (efl := efl) Σ -> wf_glob (efl := switch_cstr_as_blocks efl) (transform_blocks_env Σ). Proof. - intros hasp cstrbl hasapp etag wfg. - destruct Σ as [Σ map repr wf]; cbn in *. - revert etag wfg. - assert (extends Σ Σ). now exists []. - revert H. - revert repr wf. generalize Σ at 1 2 4 6 7. - induction Σ; cbn; constructor; auto. - - eapply IHΣ; rtoProp; intuition auto. destruct H. subst Σ0. exists (x ++ [a]). now rewrite -app_assoc. - - set (Σm := {| GlobalContextMap.global_decls := _ |}). - clear IHΣ. - epose proof (EExtends.extends_wf_glob _ H wfg); tea. - depelim H0. - set (Σm' := GlobalContextMap.make Σ (wf_glob_fresh _ H0)). - pose proof (transform_blocks_decl_extends hasapp Σm' _ H1 Σm). - forward H3. cbn. destruct H. subst Σ0. exists (x ++ [(kn, d)]). now rewrite -app_assoc. - specialize (H3 wfg). rewrite -H3. - move/andP: etag => [etad etag]. - unshelve epose proof (@transform_wellformed_decl' _ Σm' d _ _ _ H0 H1 etad); tea. - cbn in H4. unfold Σm. - eapply gen_transform_wellformed_decl_irrel; trea. - - eapply fresh_global_map_on_snd. - eapply EExtends.extends_wf_glob in wfg; tea. now depelim wfg. + intros hasp cstrbl hasapp hasb hasr etag wfg. + unshelve eapply (gen_transform_env_wf (gt := GTExt efl _)) => //. exact hasapp. + eapply Pre_glob => //. Qed. Transparent transform_blocks. diff --git a/erasure/theories/EGenericGlobalMap.v b/erasure/theories/EGenericGlobalMap.v index 4c80c5a2a..4fde99a95 100644 --- a/erasure/theories/EGenericGlobalMap.v +++ b/erasure/theories/EGenericGlobalMap.v @@ -16,7 +16,11 @@ Local Set Keyed Unification. Require Import ssreflect ssrbool. Class GenTransform := - gen_transform : GlobalContextMap.t -> term -> term. + { gen_transform : GlobalContextMap.t -> term -> term; + gen_transform_inductive_decl : mutual_inductive_body -> mutual_inductive_body }. + +Class GenTransformId (G : GenTransform) := + gen_transform_inductive_decl_id : forall idecl, gen_transform_inductive_decl idecl = idecl. Section GenTransformEnv. Context {GT : GenTransform}. @@ -27,7 +31,7 @@ Section GenTransformEnv. Definition gen_transform_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (gen_transform_constant_decl Σ cb) - | InductiveDecl idecl => d + | InductiveDecl idecl => InductiveDecl (gen_transform_inductive_decl idecl) end. Definition gen_transform_env Σ := @@ -52,10 +56,11 @@ Class GenTransformExtends (efl efl' : EEnvFlags) (GT : GenTransform) := Class GenTransformWf (efl efl' : EEnvFlags) (GT : GenTransform) := { gen_transform_pre : GlobalContextMap.t -> term -> Prop; gtwf_axioms_efl : forall _ : is_true (@has_axioms efl), is_true (@has_axioms efl'); - gtwf_cstrs_efl : forall _ : is_true (@has_cstr_params efl), is_true (@has_cstr_params efl'); + gen_transform_inductive_decl_wf : + forall idecl, @wf_minductive efl idecl -> @wf_minductive efl' (gen_transform_inductive_decl idecl); gen_transform_wellformed : forall {Σ : GlobalContextMap.t} n t, - has_tBox -> has_tRel -> gen_transform_pre Σ t -> + gen_transform_pre Σ t -> @wf_glob efl Σ -> @EWellformed.wellformed efl Σ n t -> EWellformed.wellformed (efl := efl') (gen_transform_env Σ) n (gen_transform Σ t) }. @@ -143,6 +148,17 @@ destruct (lookup_env Σ kn) eqn:hl. Qed. +Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end. +Proof. + induction l using rev_ind; cbn. + - now rewrite andb_true_r. + - rewrite mkApps_app /=. now destruct l => /= //; rewrite andb_false_r. +Qed. + +Section GenTransformId. + + Context {gid : GenTransformId gen_transform}. + Lemma is_propositional_gen_transform {Σ : GlobalContextMap.t} ind : @wf_glob efl Σ -> inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (gen_transform_env Σ) ind. @@ -152,7 +168,8 @@ Proof. rewrite (lookup_env_gen_transform (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive /GlobalContextMap.lookup_minductive. - destruct lookup_env as [[decl|]|] => //. + destruct lookup_env as [[decl|]|] => //. cbn. + now rewrite gen_transform_inductive_decl_id. Qed. Lemma is_propositional_cstr_gen_transform {Σ : GlobalContextMap.t} ind c : @@ -164,15 +181,10 @@ Proof. rewrite (lookup_env_gen_transform (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive /GlobalContextMap.lookup_minductive. - destruct lookup_env as [[decl|]|] => //. + destruct lookup_env as [[decl|]|] => //=. + now rewrite gen_transform_inductive_decl_id. Qed. -Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end. -Proof. - induction l using rev_ind; cbn. - - now rewrite andb_true_r. - - rewrite mkApps_app /=. now destruct l => /= //; rewrite andb_false_r. -Qed. Lemma lookup_constructor_gen_transform {Σ : GlobalContextMap.t} {ind c} : @wf_glob efl Σ -> @@ -180,7 +192,7 @@ Lemma lookup_constructor_gen_transform {Σ : GlobalContextMap.t} {ind c} : Proof. intros wfΣ. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. rewrite lookup_env_gen_transform // /=. destruct lookup_env => // /=. - destruct g => //. + destruct g => //=. now rewrite gen_transform_inductive_decl_id. Qed. Lemma lookup_projection_gen_transform {Σ : GlobalContextMap.t} {p} : @@ -207,6 +219,8 @@ Proof. rewrite /constructor_isprop_pars_decl. intros -> => /= //. Qed. +End GenTransformId. + Lemma wf_mkApps (ha : has_tApp) Σ k f args : reflect (wellformed Σ k f /\ forallb (wellformed Σ k) args) (wellformed Σ k (mkApps f args)). Proof. rewrite wellformed_mkApps //. eapply andP. @@ -277,7 +291,7 @@ Qed. Import EWellformed. -Lemma gen_transform_wellformed_irrel {Σ : GlobalContextMap.t} t : +Lemma gen_transform_wellformed_irrel {genid : GenTransformId gen_transform} {Σ : GlobalContextMap.t} t : @wf_glob efl Σ -> forall n, wellformed (efl := efl) Σ n t -> wellformed (efl := efl) (gen_transform_env Σ) n t. @@ -290,18 +304,21 @@ Proof. - rewrite lookup_env_gen_transform //. destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. destruct g eqn:hg => /= //; intros; rtoProp; eauto. + rewrite gen_transform_inductive_decl_id. repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; eauto. solve_all. - rewrite lookup_env_gen_transform //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. + rewrite gen_transform_inductive_decl_id. destruct nth_error => /= //. intros; rtoProp; intuition auto; solve_all. - rewrite lookup_env_gen_transform //. destruct lookup_env eqn:hl => // /=; intros; rtoProp; repeat split; eauto. destruct g eqn:hg => /= //. + now rewrite gen_transform_inductive_decl_id. Qed. -Lemma gen_transform_wellformed_decl_irrel {Σ : GlobalContextMap.t} d : +Lemma gen_transform_wellformed_decl_irrel {genid : GenTransformId gen_transform} {Σ : GlobalContextMap.t} d : @wf_glob efl Σ -> wf_global_decl (efl:= efl) Σ d -> wf_global_decl (efl := efl) (gen_transform_env Σ) d. @@ -313,25 +330,22 @@ Qed. Context {GTWF : GenTransformWf efl efl' gen_transform}. - Definition Pre_decl Σ d := match d with ConstantDecl cb => match cb.(cst_body) with | Some b => gen_transform_pre Σ b | _ => True end | _ => True end. Lemma gen_transform_decl_wf {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> @wf_glob efl Σ -> + @wf_glob efl Σ -> forall d, @wf_global_decl efl Σ d -> Pre_decl Σ d -> wf_global_decl (efl := efl') (gen_transform_env Σ) (gen_transform_decl Σ d). Proof. - intros hasb hasr wf d. + intros wf d. intros hd. intros pre. move: hd. destruct d => /= //. cbn in pre. destruct (cst_body c) => /= //. intros hwf. eapply gen_transform_wellformed => //. apply gtwf_axioms_efl. auto. - destruct m => //. cbn. unfold wf_minductive. - cbn. move/andP => [] hp //. rtoProp. solve_all. - eapply orb_true_iff. eapply orb_true_iff in hp as []; eauto. - left. eapply gtwf_cstrs_efl. now rewrite H. + destruct m => //. cbn. + eapply gen_transform_inductive_decl_wf. Qed. Lemma fresh_global_gen_transform_env {Σ : GlobalContextMap.t} kn : @@ -354,10 +368,9 @@ Fixpoint Pre_glob Σ : EnvMap.fresh_globals Σ -> Prop := Import GlobalContextMap (repr, map, global_decls, wf). Lemma gen_transform_env_wf {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> @wf_glob efl Σ -> Pre_glob Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf) -> wf_glob (efl := efl') (gen_transform_env Σ). Proof. - intros hasb hasrel wfg pre. + intros wfg pre. rewrite gen_transform_env_eq //. destruct Σ as [Σ ? ? ?]. cbn in *. revert pre. induction Σ in map0, repr0, wf0, wfg |- *; auto; cbn; constructor; auto. diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v index 178225ad4..8f65984c3 100644 --- a/erasure/theories/EInlineProjections.v +++ b/erasure/theories/EInlineProjections.v @@ -287,7 +287,7 @@ Definition optimize_constant_decl Σ cb := Definition optimize_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (optimize_constant_decl Σ cb) - | InductiveDecl idecl => d + | InductiveDecl idecl => InductiveDecl idecl end. Definition optimize_env Σ := @@ -820,7 +820,12 @@ Qed. From MetaCoq.Erasure Require Import EGenericGlobalMap. #[local] -Instance GT : GenTransform := { gen_transform := optimize }. +Instance GT : GenTransform := { gen_transform := optimize; gen_transform_inductive_decl := id }. +#[local] +Instance GTID : GenTransformId GT. +Proof. + red. reflexivity. +Qed. #[local] Instance GTExt efl : GenTransformExtends efl (disable_projections_env_flag efl) GT. Proof. @@ -831,8 +836,8 @@ Qed. #[local] Instance GTWf efl : GenTransformWf efl (disable_projections_env_flag efl) GT. Proof. - refine {| gen_transform_pre := fun _ _ => True |}; auto. - intros Σ n t hasb hasr _ wfΣ wft. + refine {| gen_transform_pre := fun _ _ => has_tBox /\ has_tRel |}; auto. + intros Σ n t [] wfΣ wft. now apply optimize_wellformed. Defined. @@ -870,8 +875,10 @@ Proof. now unshelve eapply (optimize_expanded_decl (Σ:=Σ')). Qed. -Lemma Pre_glob efl Σ wf : Pre_glob (GTWF:=GTWf efl) Σ wf. +Lemma Pre_glob efl Σ wf : + has_tBox -> has_tRel -> Pre_glob (GTWF:=GTWf efl) Σ wf. Proof. + intros hasb hasr. induction Σ => //. destruct a as [kn d]; cbn. split => //. destruct d as [[[|]]|] => //=. Qed. @@ -882,7 +889,7 @@ Lemma optimize_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : Proof. intros hasb hasre wfg. eapply (gen_transform_env_wf (gt := GTExt efl)) => //. - apply Pre_glob. + now apply Pre_glob. Qed. Definition optimize_program (p : eprogram_env) := diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index 0cd56240e..565cdcfbd 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -780,68 +780,6 @@ Proof. unfold expanded_constant_decl => /=. apply remove_match_on_box_expanded_irrel. Qed. - -Lemma remove_match_on_box_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : - extends_prefix Σ Σ' -> - wf_glob Σ' -> - List.map (on_snd (remove_match_on_box_decl Σ)) Σ.(GlobalContextMap.global_decls) = - List.map (on_snd (remove_match_on_box_decl Σ')) Σ.(GlobalContextMap.global_decls). -Proof. - intros ext. - destruct Σ as [Σ map repr wf]; cbn in *. - move=> wfΣ. - assert (extends_prefix Σ Σ); auto. now exists []. - assert (wf_glob Σ). - { eapply extends_wf_glob. exact ext. tea. } - revert H H0. - generalize Σ at 1 3 5 6. intros Σ''. - induction Σ'' => //. cbn. - intros hin wfg. depelim wfg. - f_equal. - 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. } - unfold on_snd. cbn. f_equal. - eapply wellformed_remove_match_on_box_decl_extends => //. cbn. - eapply extends_wf_global_decl. 3:tea. - eapply extends_wf_glob; tea. - eapply extends_prefix_extends. - destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. - eapply extends_wf_glob; tea. cbn. - eapply extends_prefix_extends; tea. -Qed. - -Lemma remove_match_on_box_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> remove_match_on_box_env Σ = remove_match_on_box_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). -Proof. - intros wf. - unfold remove_match_on_box_env. - destruct Σ; cbn. cbn in wf. - induction global_decls in map, repr, wf0, wf |- * => //. - cbn. f_equal. - destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. - eapply wellformed_remove_match_on_box_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn. - set (Σg' := GlobalContextMap.make global_decls (fresh_globals_cons_inv wf0)). - erewrite <- (IHglobal_decls (GlobalContextMap.map Σg') (GlobalContextMap.repr Σg')). - 2:now depelim wf. - set (Σg := {| GlobalContextMap.global_decls := _ :: _ |}). - symmetry. eapply (remove_match_on_box_env_extends' (Σ := Σg') (Σ' := Σg)) => //. - cbn. now exists [a]. -Qed. - -Lemma remove_match_on_box_env_expanded {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - wf_glob Σ -> expanded_global_env Σ -> expanded_global_env (remove_match_on_box_env Σ). -Proof. - unfold expanded_global_env; move=> wfg. - rewrite remove_match_on_box_env_eq //. - destruct Σ as [Σ map repr wf]. cbn in *. - clear map repr. - induction 1; cbn; constructor; auto. - cbn in IHexpanded_global_declarations. - unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. - set (Σ' := GlobalContextMap.make _ _). - rewrite -(remove_match_on_box_env_eq Σ'). cbn. now depelim wfg. - eapply (remove_match_on_box_expanded_decl_irrel (Σ := Σ')). now depelim wfg. - now unshelve eapply (remove_match_on_box_expanded_decl (Σ:=Σ')). -Qed. - Lemma remove_match_on_box_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_tBox -> has_tRel -> wf_glob Σ -> EWellformed.wellformed Σ n t -> EWellformed.wellformed Σ n (remove_match_on_box Σ t). @@ -905,6 +843,67 @@ Proof. all:intros; rtoProp; intuition auto; solve_all. Qed. +From MetaCoq.Erasure Require Import EGenericGlobalMap. + +#[local] +Instance GT : GenTransform := { gen_transform := remove_match_on_box; gen_transform_inductive_decl := id }. +#[local] +Instance GTID : GenTransformId GT. +Proof. + red. reflexivity. +Qed. +#[local] +Instance GTExt efl : GenTransformExtends efl efl GT. +Proof. + intros Σ t n wfΣ Σ' ext wf wf'. + unfold gen_transform, GT. + eapply wellformed_remove_match_on_box_extends; tea. +Qed. +#[local] +Instance GTWf efl : GenTransformWf efl efl GT. +Proof. + refine {| gen_transform_pre := fun _ _ => has_tBox /\ has_tRel |}; auto. + intros Σ n t [] wfΣ wft. + eapply remove_match_on_box_wellformed_irrel => //. + now eapply remove_match_on_box_wellformed. +Defined. + +Lemma remove_match_on_box_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : + extends Σ Σ' -> + wf_glob Σ -> + wf_glob Σ' -> + List.map (on_snd (remove_match_on_box_decl Σ)) Σ.(GlobalContextMap.global_decls) = + List.map (on_snd (remove_match_on_box_decl Σ')) Σ.(GlobalContextMap.global_decls). +Proof. + intros ext wf. + eapply (gen_transform_env_extends' (gt := GTExt efl)) => //. +Qed. + +Lemma remove_match_on_box_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : + wf_glob Σ -> + remove_match_on_box_env Σ = remove_match_on_box_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). +Proof. + intros wf. + eapply (gen_transform_env_eq (gt := GTExt efl)) => //. +Qed. + +Lemma remove_match_on_box_env_expanded {efl : EEnvFlags} {Σ : GlobalContextMap.t} : + wf_glob Σ -> expanded_global_env Σ -> expanded_global_env (remove_match_on_box_env Σ). +Proof. + unfold expanded_global_env; move=> wfg. + rewrite remove_match_on_box_env_eq //. + destruct Σ as [Σ map repr wf]. cbn in *. + clear map repr. + induction 1; cbn; constructor; auto. + cbn in IHexpanded_global_declarations. + unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. + set (Σ' := GlobalContextMap.make _ _). + rewrite -(remove_match_on_box_env_eq Σ'). cbn. now depelim wfg. + eapply (remove_match_on_box_expanded_decl_irrel (Σ := Σ')). now depelim wfg. + now unshelve eapply (remove_match_on_box_expanded_decl (Σ:=Σ')). +Qed. + + Lemma remove_match_on_box_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : wf_glob Σ -> wf_global_decl Σ d -> wf_global_decl (remove_match_on_box_env Σ) d. @@ -936,23 +935,26 @@ Proof. now eapply Forall_map; cbn. Qed. + +Lemma Pre_glob efl Σ wf : + has_tBox -> has_tRel -> + Pre_glob (GTWF:=GTWf efl) Σ wf. +Proof. + intros hasb hasr. induction Σ => //. destruct a as [kn d]; cbn. + split => //. destruct d as [[[|]]|] => //=. +Qed. + Lemma remove_match_on_box_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : has_tBox -> has_tRel -> wf_glob Σ -> wf_glob (remove_match_on_box_env Σ). Proof. - intros hasb hasrel. - intros wfg. rewrite remove_match_on_box_env_eq //. - destruct Σ as [Σ map repr wf]; cbn in *. - clear map repr. - induction wfg; cbn; constructor; auto. - - rewrite /= -(remove_match_on_box_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. - eapply remove_match_on_box_decl_wf => //. - - rewrite /= -(remove_match_on_box_env_eq (GlobalContextMap.make Σ (fresh_globals_cons_inv wf))) //. - now eapply fresh_global_remove_match_on_box_env. + intros hasb hasrel wfg. + eapply (gen_transform_env_wf (gt := GTExt efl)) => //. + now apply Pre_glob. Qed. Definition remove_match_on_box_program (p : eprogram_env) := -(remove_match_on_box_env p.1, remove_match_on_box p.1 p.2). + (remove_match_on_box_env p.1, remove_match_on_box p.1 p.2). Definition remove_match_on_box_program_wf {efl} (p : eprogram_env) {hastbox : has_tBox} {hastrel : has_tRel} : wf_eprogram_env efl p -> wf_eprogram efl (remove_match_on_box_program p). diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v index c9f891c5e..bc5a6b529 100644 --- a/erasure/theories/ERemoveParams.v +++ b/erasure/theories/ERemoveParams.v @@ -1011,22 +1011,30 @@ Proof. now intros -> => /=. Qed. +Definition switch_no_params (efl : EEnvFlags) := + {| has_axioms := has_axioms; + has_cstr_params := false; + term_switches := term_switches ; + cstr_as_blocks := cstr_as_blocks + |}. (* Stripping preserves well-formedness directly, not caring about eta-expansion *) -Lemma strip_wellformed {Σ : GlobalContextMap.t} n t : - @wf_glob all_env_flags Σ -> - @wellformed all_env_flags Σ n t -> - @wellformed all_env_flags (strip_env Σ) n (strip Σ t). +Lemma strip_wellformed {efl} {Σ : GlobalContextMap.t} n t : + cstr_as_blocks = false -> + has_tApp -> + @wf_glob efl Σ -> + @wellformed efl Σ n t -> + @wellformed (switch_no_params efl) (strip_env Σ) n (strip Σ t). Proof. - intros wfΣ. + intros cab hasapp wfΣ. revert n. funelim (strip Σ t); try intros n. all:cbn -[strip lookup_constructor lookup_inductive]; simp_strip; intros. all:try solve[unfold wf_fix_gen in *; rtoProp; intuition auto; toAll; solve_all]. - cbn -[strip]; simp_strip. intros; rtoProp; intuition auto. rewrite lookup_env_strip. destruct lookup_env eqn:hl => // /=. - destruct g => /= //. - - cbn -[strip] in *. + destruct g => /= //. destruct (cst_body c) => //. + - rewrite cab in H |- *. cbn -[strip] in *. rewrite lookup_env_strip. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. destruct nth_error => //. destruct nth_error => //. @@ -1035,25 +1043,27 @@ Proof. destruct g eqn:hg => /= //. subst g. destruct nth_error => //. rtoProp; intuition auto. simp_strip. toAll; solve_all. + toAll. solve_all. - cbn -[strip] in H0 |- *. rewrite lookup_env_strip. destruct lookup_env eqn:hl => // /=. - destruct g eqn:hg => /= //. subst g. + destruct g eqn:hg => /= //. subst g. cbn in H0. now rtoProp. destruct nth_error => //. all:rtoProp; intuition auto. destruct EAst.ind_ctors => //. destruct nth_error => //. + all: eapply H; auto. - unfold wf_fix_gen in *. rewrite map_length. rtoProp; intuition auto. toAll; solve_all. now rewrite -strip_isLambda. toAll; solve_all. - unfold wf_fix in *. rewrite map_length; rtoProp; intuition auto. toAll; solve_all. - move:H1; rewrite !wellformed_mkApps //. rtoProp; intuition auto. - toAll; solve_all. + toAll; solve_all. toAll; solve_all. - move:H0; rewrite !wellformed_mkApps //. rtoProp; intuition auto. - move: H1. cbn. + move: H1. cbn. rewrite cab. rewrite lookup_env_strip. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. destruct nth_error => //. destruct nth_error => //. toAll; solve_all. eapply All_skipn. solve_all. - move:H0; rewrite !wellformed_mkApps //. rtoProp; intuition auto. - move: H1. cbn. + move: H1. cbn. rewrite cab. rewrite lookup_env_strip. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. destruct nth_error => //. destruct nth_error => //. @@ -1102,13 +1112,6 @@ Proof. now eapply strip_wellformed_irrel. Qed. -Definition switch_no_params (efl : EEnvFlags) := - {| has_axioms := has_axioms; - has_cstr_params := false; - term_switches := term_switches ; - cstr_as_blocks := false - |}. - Lemma strip_decl_wf (efl := all_env_flags) {Σ : GlobalContextMap.t} : wf_glob Σ -> forall d, wf_global_decl Σ d -> @@ -1212,30 +1215,36 @@ Proof. intros _ => //. Qed. +From MetaCoq.Erasure Require Import EGenericGlobalMap. + +#[local] +Instance GT : GenTransform := { gen_transform := strip; gen_transform_inductive_decl := strip_inductive_decl }. +#[local] +Instance GTExt efl : has_tApp -> GenTransformExtends efl efl GT. +Proof. + intros hasapp Σ t n wfΣ Σ' ext wf wf'. + unfold gen_transform, GT. + eapply strip_extends; tea. +Qed. +#[local] +Instance GTWf efl : GenTransformWf efl (switch_no_params efl) GT. +Proof. + refine {| gen_transform_pre := fun _ _ => has_tApp /\ cstr_as_blocks = false |}; auto. + - unfold wf_minductive; intros []. cbn. repeat rtoProp. intuition auto. + - intros Σ n t [? ?] wfΣ wft. unfold gen_transform_env, gen_transform. simpl. + eapply strip_wellformed => //. +Defined. + Lemma strip_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : has_tApp -> extends Σ Σ' -> + wf_glob Σ -> wf_glob Σ' -> List.map (on_snd (strip_decl Σ)) Σ.(GlobalContextMap.global_decls) = List.map (on_snd (strip_decl Σ')) Σ.(GlobalContextMap.global_decls). Proof. - intros hast ext. - destruct Σ as [Σ map repr wf]; cbn in *. - move=> wfΣ. - assert (extends Σ Σ); auto. now exists []. - assert (wf_glob Σ). - { eapply EExtends.extends_wf_glob. exact ext. tea. } - revert H H0. - generalize Σ at 1 3 5 6. intros Σ''. - induction Σ'' => //. cbn. - intros hin wfg. depelim wfg. - f_equal. - 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. } - unfold on_snd. cbn. f_equal. - eapply strip_decl_extends => //. - eapply extends_wf_global_decl. 3:tea. auto. cbn. - eapply EExtends.extends_wf_glob; tea. - destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. + intros hast ext wf. + now apply (gen_transform_env_extends' (gt := GTExt efl hast) ext). Qed. Lemma strip_env_eq (efl := all_env_flags) (Σ : GlobalContextMap.t) : wf_glob Σ -> strip_env Σ = strip_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). @@ -1246,13 +1255,14 @@ Proof. induction global_decls in map, repr, wf0, wf |- * => //. cbn. f_equal. destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. - eapply strip_decl_extends => //. cbn. cbn. now exists [(kn, d)]. cbn. now depelim wf. + eapply strip_decl_extends => //. cbn. cbn. eapply EExtends.extends_prefix_extends. now exists [(kn, d)]. auto. cbn. now depelim wf. set (Σg' := GlobalContextMap.make global_decls (fresh_globals_cons_inv wf0)). erewrite <- (IHglobal_decls (GlobalContextMap.map Σg') (GlobalContextMap.repr Σg')). 2:now depelim wf. set (Σg := {| GlobalContextMap.global_decls := _ :: _ |}). symmetry. eapply (strip_extends' (Σ := Σg') (Σ' := Σg)) => //. - cbn. now exists [a]. + cbn. eapply EExtends.extends_prefix_extends => //. now exists [a]. + cbn. now depelim wf. Qed. Lemma strip_env_wf (efl := all_env_flags) {Σ : GlobalContextMap.t} : diff --git a/erasure/theories/EWcbvEvalNamed.v b/erasure/theories/EWcbvEvalNamed.v index a6ca1034e..044e57def 100644 --- a/erasure/theories/EWcbvEvalNamed.v +++ b/erasure/theories/EWcbvEvalNamed.v @@ -955,7 +955,7 @@ Qed. Local Hint Resolve incl_tl incl_appr incl_appl : core. Lemma wellformed_annotate' Σ Γ Γ' s : - incl Γ' Γ -> + incl Γ' Γ -> wellformed (efl := extraction_env_flags) Σ #|Γ| s -> wellformed (efl := named_extraction_env_flags) (annotate_env Γ' Σ) #|Γ| (annotate Γ s). Proof. intros Hincl Hwf. From 805bbdad44325d51864e4df611efdcebce859616 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Aug 2023 01:42:55 +0200 Subject: [PATCH 40/65] Prove a more precise result about erase_global_decls with dependencies --- .vscode/metacoq.code-workspace | 2 + Makefile | 2 +- common/theories/Transform.v | 8 +- erasure-plugin/_CoqProject.in | 1 - erasure-plugin/theories/ETransform.v | 231 ++++++- erasure-plugin/theories/Erasure.v | 55 +- erasure/theories/EConstructorsAsBlocks.v | 91 +-- erasure/theories/EImplementBox.v | 77 +-- erasure/theories/EOptimizePropDiscr.v | 2 +- erasure/theories/EProgram.v | 42 ++ erasure/theories/ErasureFunction.v | 653 ++++++++++++++++---- erasure/theories/Typed/ErasureCorrectness.v | 5 +- template-coq/theories/TemplateProgram.v | 2 +- 13 files changed, 962 insertions(+), 209 deletions(-) diff --git a/.vscode/metacoq.code-workspace b/.vscode/metacoq.code-workspace index 2ce1e12f6..6a0a8cce3 100644 --- a/.vscode/metacoq.code-workspace +++ b/.vscode/metacoq.code-workspace @@ -10,6 +10,7 @@ "coqtop.args": [ + "-R", "safechecker-plugin/theories", "MetaCoq.SafeCheckerPlugin", "-R", "utils/theories", "MetaCoq.Utils", @@ -27,6 +28,7 @@ "-R", "safechecker/theories", "MetaCoq.SafeChecker", "-I", "erasure/src", "-R", "erasure/theories", "MetaCoq.Erasure", + "-R", "erasure-plugin/theories", "MetaCoq.ErasurePlugin", "-R", "translations", "MetaCoq.Translations", "-R", "test-suite/plugin-demo/theories", "MetaCoq.ExtractedPluginDemo", "-R", "test-suite", "MetaCoq.TestSuite" diff --git a/Makefile b/Makefile index e16daadc8..6da8df03b 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: printconf template-coq pcuic safechecker erasure +all: printconf template-coq pcuic safechecker erasure erasure-plugin -include Makefile.conf diff --git a/common/theories/Transform.v b/common/theories/Transform.v index 5a4aeace8..bbeb25d22 100644 --- a/common/theories/Transform.v +++ b/common/theories/Transform.v @@ -39,7 +39,7 @@ Module Transform. post : program' -> Prop; correctness : forall input (p : pre input), post (transform input p); obseq : forall p : program, pre p -> program' -> value -> value' -> Prop; - preservation : preserves_eval pre transform obseq; }. + preservation : preserves_eval pre transform obseq }. Definition run (x : t) (p : program) (pr : pre x p) : program' := time x.(name) (fun _ => x.(transform) p pr) tt. @@ -58,7 +58,8 @@ Module Transform. Local Obligation Tactic := idtac. Program Definition compose (o : t program program' value value' eval eval') (o' : t program' program'' value' value'' eval' eval'') - (hpp : (forall p, o.(post) p -> o'.(pre) p)) : t program program'' value value'' eval eval'' := + (hpp : (forall p, o.(post) p -> o'.(pre) p)) + : t program program'' value value'' eval eval'' := {| name := (o.(name) ^ " -> " ^ o'.(name))%bs; transform p hp := run o' (run o p hp) (hpp _ (o.(correctness) _ hp)); @@ -79,10 +80,11 @@ Module Transform. cbn in ev. destruct ev as [v' [ev]]. epose proof (o'.(preservation) (o.(transform) p pr) v'). specialize (H0 (hpp _ (o.(correctness) _ pr)) ev). - destruct H0 as [v'' [ev' obs']]. + destruct H0 as [v'' [ev' obs'']]. exists v''. constructor => //. exists v'. now split. Qed. + End Comp. Declare Scope transform_scope. diff --git a/erasure-plugin/_CoqProject.in b/erasure-plugin/_CoqProject.in index 24d1735f9..49d459d43 100644 --- a/erasure-plugin/_CoqProject.in +++ b/erasure-plugin/_CoqProject.in @@ -1,6 +1,5 @@ -R theories MetaCoq.ErasurePlugin - theories/ETransform.v theories/Erasure.v theories/Extraction.v diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index 352a50101..ba2e8c17f 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -256,6 +256,155 @@ Next Obligation. cbn; intros. sq. now subst. Qed. +Definition extends_eprogram (p p' : eprogram) := + extends p.1 p'.1 /\ p.2 = p'.2. + +Definition extends_eprogram_env (p p' : eprogram_env) := + extends p.1 p'.1 /\ p.2 = p'.2. + +Section PCUICEnv. (* Locally reuse the short names for PCUIC environment handling *) +Import PCUICAst.PCUICEnvironment. + +Lemma build_wf_env_from_env_eq {cf : checker_flags} (guard : abstract_guard_impl) (Σ : global_env_ext_map) (wfΣ : ∥ PCUICTyping.wf_ext Σ ∥) : + let wfe := build_wf_env_from_env Σ (map_squash (PCUICTyping.wf_ext_wf Σ) wfΣ) in + forall Σ' : global_env, Σ' ∼ wfe -> declarations Σ' = declarations Σ. +Proof. + cbn; intros. rewrite H. reflexivity. +Qed. + +Definition extends_global_env (Σ Σ' : global_env_ext_map) := + [/\ (forall kn decl, lookup_env Σ kn = Some decl ->lookup_env Σ' kn = Some decl), + Σ.(universes) = Σ'.(universes), Σ.2 = Σ'.2 & Σ.(retroknowledge) = Σ'.(retroknowledge)]. + +Definition extends_pcuic_program (p p' : pcuic_program) := + extends_global_env p.1 p'.1 /\ p.2 = p'.2. +Import ErasureFunction. +Import PCUICAst. +Lemma fresh_global_app kn Σ Σ' : fresh_global kn (Σ ++ Σ') -> + fresh_global kn Σ /\ fresh_global kn Σ'. +Proof. + induction Σ; cbn; intuition auto. + - constructor. + - depelim H. constructor => //. + now eapply Forall_app in H0. + - depelim H. + now eapply Forall_app in H0. +Qed. + +Lemma lookup_global_app_wf Σ Σ' kn : EnvMap.EnvMap.fresh_globals (Σ ++ Σ') -> + forall decl, lookup_global Σ' kn = Some decl -> lookup_global (Σ ++ Σ') kn = Some decl. +Proof. + induction Σ in kn |- *; cbn; auto. + intros fr; depelim fr. + intros decl hd; cbn. + destruct (eqb_spec kn kn0). + eapply PCUICWeakeningEnv.lookup_global_Some_fresh in hd. + subst. now eapply fresh_global_app in H as [H H']. + now eapply IHΣ. +Qed. + +Lemma strictly_extends_lookups {cf:checker_flags} (X X' : wf_env) (Σ Σ' : global_env) : + (forall (kn : kername) (decl decl' : global_decl), lookup_env Σ' kn = Some decl -> lookup_env Σ kn = Some decl' -> decl = decl') -> + retroknowledge Σ = retroknowledge Σ' -> + strictly_extends_decls X Σ -> strictly_extends_decls X' Σ' -> + PCUICTyping.wf Σ -> PCUICTyping.wf Σ' -> + equiv_env_inter X' X. +Proof. + intros hl hr [] [] wf wf'. + split. + - intros kn d. + unfold lookup_env in *. + destruct s as [? eq], s0 as [? eq']. + rewrite eq' eq in hl. + intros decl' hl' hl''. + specialize (hl kn d decl'). + eapply wf_fresh_globals in wf. + eapply wf_fresh_globals in wf'. + rewrite eq in wf; rewrite eq' in wf'. + eapply lookup_global_app_wf in hl'; tea. + eapply lookup_global_app_wf in hl''; tea. + eauto. + - rewrite /primitive_constant. now rewrite e0 e2 hr. +Qed. + +#[global] +Instance erase_transform_extends {guard : abstract_guard_impl} : + TransformExt.t (erase_transform (guard := guard)) extends_pcuic_program extends_eprogram_env. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. + destruct pr. + epose proof (erase_pcuic_program_normalization_helper p (map_squash fst s)). + destruct p as [Σ t]. destruct p' as [Σ' t']. + simpl in *. subst t'. red. split. + - destruct ext. red. + cbn. rewrite /ErasureFunction.erase_global_fast. + unshelve erewrite ErasureFunction.erase_global_deps_fast_spec. + { intros. intuition auto. eapply H11; tea. admit. admit. } + { intros. red in H4. cbn in H4. subst. reflexivity. } + destruct Σ'. cbn in *. subst u. + set (fst := ErasureFunction.erase _ _ _ _ _). + set (snd:= ErasureFunction.erase _ _ _ _ _). + assert (fst = snd). + { subst fst snd. symmetry. + eapply ErasureFunction.erase_irrel_global_env. + eapply ErasureFunction.equiv_env_inter_hlookup. + intros ? ? -> ->. cbn. + eapply ErasureFunction.equiv_env_inter_sym. + eapply ErasureFunction.extends_global_env_equiv_env. + cbn. split => //. + sq. unfold primitive_constant. now rewrite H3. } + clearbody fst snd. subst snd. + intros. + set (X := build_wf_env_from_env g _) in *. + destruct (lookup_env Σ kn) eqn:E. + unshelve epose proof (abstract_env_exists X). 3:tc. tc. + destruct H4 as [[Σ' ΣX]]. + unshelve epose proof (build_wf_env_from_env_eq _ (g, Σ.2) _ _ ΣX). cbn in H4. + epose proof (hl := ErasureFunction.lookup_env_erase_decl (optimized_abstract_env_impl) _ (EAstUtils.term_global_deps fst) _ _ _ kn g0 _ ΣX). + unfold lookup_env in E, hl. rewrite H4 in hl. specialize (hl (H0 _ _ E)). + forward hl. admit. + destruct g0. + + destruct hl as [X' [nin [pf [eq ext]]]]. + unshelve erewrite ErasureFunction.erase_global_deps_fast_spec. shelve. + { intros. red in H5. cbn in H5. subst. reflexivity. } + erewrite eq. + set (Xs := build_wf_env_from_env Σ.1 _) in *. + unshelve epose proof (abstract_env_exists Xs). 3:tc. tc. + destruct H5 as [[Σs Hs]]. + epose proof (hl' := ErasureFunction.lookup_env_erase_decl (optimized_abstract_env_impl) _ (EAstUtils.term_global_deps fst) _ _ _ kn _ _ Hs). + unshelve epose proof (build_wf_env_from_env_eq _ _ _ _ Hs). rewrite /lookup_env H5 in hl'. specialize (hl' E). + forward hl'. admit. cbn in hl'. + destruct hl' as [X'' [nin' [pf' [eq' ext']]]]. + erewrite eq' in H2. rewrite -H2. f_equal. f_equal. + f_equal. unfold erase_constant_decl. + eapply erase_constant_body_irrel. + eapply ErasureFunction.equiv_env_inter_hlookup. cbn. + intros ? ? H6 H7. + cbn in ext. specialize (ext _ _ eq_refl eq_refl) as [ext]. + specialize (ext' _ _ eq_refl eq_refl) as [ext']. + cbn in H6, H7. subst Σ0 Σ'0. cbn. split => //. + { intros kn' decl'. rewrite /lookup_env. + destruct (map_squash Datatypes.fst s). + destruct pr' as [pr' ?]. + destruct (map_squash Datatypes.fst pr'). + eapply strictly_extends_lookups. 2-3:tea. + intros kn'' ? ? hg hΣ. eapply H0 in hΣ. congruence. auto. + apply X0. apply X1. } + { rewrite /primitive_constant. + destruct ext as [_ _ ->]. + destruct ext' as [_ _ ->]. + now rewrite H3. } + + + - symmetry. + eapply ErasureFunction.erase_irrel_global_env. + intros Σg Σg' eq eq'. + destruct ext as [hl hu hr]. + destruct Σ as [m univs]. destruct Σ' as [m' univs']. simpl in *. + subst. cbn. destruct m, m'. cbn in *. split => //. sq. red. split => //. + unfold primitive_constant. now rewrite H. +Qed. +End PCUICEnv. + Obligation Tactic := idtac. (** This transformation is the identity on terms but changes the evaluation relation to one @@ -283,6 +432,13 @@ Next Obligation. now eapply EEtaExpandedFix.expanded_isEtaExp. Qed. +#[global] +Instance guarded_to_unguarded_fix_extends {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) : + TransformExt.t (guarded_to_unguarded_fix (wcon:=wcon) wguard) extends_eprogram_env term snd. +Proof. + red. intros p p' pr pr' [ext eq]. now rewrite /transform /=. +Qed. + Definition rebuild_wf_env {efl} (p : eprogram) (hwf : wf_eprogram efl p): eprogram_env := (GlobalContextMap.make p.1 (wf_glob_fresh p.1 (proj1 hwf)), p.2). @@ -300,6 +456,13 @@ Next Obligation. cbn. intros fl efl [] input v [] ev p'; exists v; split => //. Qed. +#[global] +Instance rebuild_wf_env_extends {fl : EWcbvEval.WcbvFlags} {efl : EEnvFlags} with_exp : + TransformExt.t (rebuild_wf_env_transform with_exp) extends_eprogram term snd. +Proof. + red. intros p p' pr pr' [ext eq]. now rewrite /transform /=. +Qed. + Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags): Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := @@ -326,7 +489,16 @@ Next Obligation. now move/andP: etap. Qed. -Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) {wcon : EWcbvEval.with_constructor_as_block = false} +#[global] +Instance remove_params_extends {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} + (efl := all_env_flags): + TransformExt.t (remove_params_optimization (wcon:=wcon)) extends_eprogram_env term snd. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite eq. + eapply strip_extends => //. apply pr'. rewrite -eq. apply pr. +Qed. + +Program Definition remove_params_fast_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags) : Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters (faster?)"; @@ -356,6 +528,16 @@ Next Obligation. now move/andP: etap. Qed. +#[global] +Instance remove_params_fast_extends {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} + (efl := all_env_flags): + TransformExt.t (remove_params_fast_optimization (wcon:=wcon)) extends_eprogram_env term snd. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite eq. + rewrite -!ERemoveParams.Fast.strip_fast. + eapply strip_extends => //. apply pr'. rewrite -eq. apply pr. +Qed. + Import EOptimizePropDiscr EWcbvEval. Program Definition remove_match_on_box_trans {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : @@ -381,6 +563,14 @@ Next Obligation. Unshelve. eauto. Qed. +#[global] +Instance remove_match_on_box_extends {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : + TransformExt.t (remove_match_on_box_trans (wcon:=wcon) (hastrel := hastrel) (hastbox := hastbox)) extends_eprogram_env term snd. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite -eq. + eapply wellformed_remove_match_on_box_extends; eauto. apply pr. apply pr'. +Qed. + From MetaCoq.Erasure Require Import EInlineProjections. Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) @@ -405,10 +595,19 @@ Next Obligation. cbn. eapply wfe. Unshelve. auto. Qed. +#[global] +Instance inline_projections_optimization_extends {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) + {hastrel : has_tRel} {hastbox : has_tBox} : + TransformExt.t (inline_projections_optimization (wcon:=wcon) (hastrel := hastrel) (hastbox := hastbox)) extends_eprogram_env term snd. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite -eq. + eapply wellformed_optimize_extends; eauto. apply pr. apply pr'. +Qed. + From MetaCoq.Erasure Require Import EConstructorsAsBlocks. -Program Definition constructors_as_blocks_transformation (efl : EEnvFlags) - {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : +Program Definition constructors_as_blocks_transformation {efl : EEnvFlags} + {has_app : has_tApp} {has_rel : has_tRel} {hasbox : has_tBox} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := {| name := "transforming to constuctors as blocks"; transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; @@ -417,13 +616,13 @@ Program Definition constructors_as_blocks_transformation (efl : EEnvFlags) obseq p hp p' v v' := v' = EConstructorsAsBlocks.transform_blocks p.1 v |}. Next Obligation. - move=> efl hasapp haspars hascstrs [Σ t] [] [wftp wft] /andP [etap etat]. + move=> efl hasapp hasrel hasbox haspars hascstrs [Σ t] [] [wftp wft] /andP [etap etat]. cbn in *. split. - eapply transform_wf_global; eauto. - eapply transform_wellformed; eauto. Qed. Next Obligation. - red. move=> efl hasapp haspars hascstrs [Σ t] /= v [[wfe1 wfe2] wft] [ev]. + red. move=> efl hasapp hasrel hasbox haspars hascstrs [Σ t] /= v [[wfe1 wfe2] wft] [ev]. eexists. split; [ | eauto]. unfold EEtaExpanded.expanded_eprogram_env_cstrs in *. revert wft. move => /andP // [e1 e2]. @@ -432,9 +631,18 @@ Next Obligation. eapply transform_blocks_eval; cbn; eauto. Qed. +#[global] +Instance constructors_as_blocks_extends (efl : EEnvFlags) + {has_app : has_tApp} {has_rel : has_tRel} {hasbox : has_tBox} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : + TransformExt.t (constructors_as_blocks_transformation (has_app := has_app) (has_rel := has_rel) (hasbox := hasbox) (has_pars := has_pars) (has_cstrblocks := has_cstrblocks)) extends_eprogram_env term snd. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite -eq. + eapply transform_blocks_extends; eauto. apply pr. apply pr'. +Qed. + From MetaCoq.Erasure Require Import EImplementBox. -Program Definition implement_box_transformation (efl : EEnvFlags) +Program Definition implement_box_transformation {efl : EEnvFlags} {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = true} : Transform.t eprogram eprogram EAst.term EAst.term (eval_eprogram block_wcbv_flags) (eval_eprogram block_wcbv_flags) := {| name := "transforming to constuctors as blocks"; @@ -446,11 +654,18 @@ Program Definition implement_box_transformation (efl : EEnvFlags) Next Obligation. intros. cbn in *. destruct p. split. - eapply transform_wf_global; eauto. - - eapply transform_wellformed; eauto. + - now eapply transform_wellformed'. Qed. Next Obligation. red. intros. destruct pr. destruct H. eexists. split; [ | eauto]. econstructor. eapply implement_box_eval; cbn; eauto. -Qed. \ No newline at end of file +Qed. + +#[global] +Instance implement_box_extends (efl : EEnvFlags) {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = true} : + TransformExt.t (implement_box_transformation (has_app := has_app) (has_pars := has_pars) (has_cstrblocks := has_cstrblocks)) extends_eprogram term snd. +Proof. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. now rewrite -eq. +Qed. diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index 71d754645..ce6e68ef0 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -6,6 +6,7 @@ From MetaCoq.Template Require Import EtaExpand TemplateProgram. From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram. From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl. From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness EPretty Extract. +From MetaCoq.Erasure Require Import EProgram. From MetaCoq.ErasurePlugin Require Import ETransform. Import PCUICProgram. @@ -90,7 +91,7 @@ Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl (* Rebuild the efficient lookup table *) rebuild_wf_env_transform (efl := efl) true ▷ (* First-order constructor representation *) - constructors_as_blocks_transformation efl (has_app := eq_refl) (has_pars := eq_refl) (has_cstrblocks := eq_refl). + constructors_as_blocks_transformation (efl := efl) (has_app := eq_refl) (has_pars := eq_refl) (has_rel := eq_refl) (hasbox := eq_refl) (has_cstrblocks := eq_refl). (* At the end of erasure we get a well-formed program (well-scoped globally and localy), without parameters in inductive declarations. The constructor applications are also transformed to a first-order @@ -105,6 +106,54 @@ Next Obligation. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. + +Definition transform_compose + {program program' program'' value value' value'' : Type} + {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} + {eval'' : program'' -> value'' -> Prop} + (o : t program program' value value' eval eval') + (o' : t program' program'' value' value'' eval' eval'') + (pre : forall p : program', post o p -> pre o' p) : + forall x p1, exists p3, + transform (compose o o' pre) x p1 = transform o' (transform o x p1) p3. +Proof. + cbn. intros. + unfold run, time. + eexists;reflexivity. +Qed. + +#[global] +Instance pcuic_expand_lets_transform_ext {cf : checker_flags} K : + TransformExt.t (pcuic_expand_lets_transform K) extends_pcuic_program PCUICAst.term snd. +Proof. + red. intros p p' pre pre' []. cbn. now rewrite H0. +Qed. + +Lemma verified_erasure_pipeline_extends {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + TransformExt.t verified_erasure_pipeline extends_pcuic_program EAst.term snd. +Proof. + unfold verified_erasure_pipeline. + eapply TransformExt.compose. + 2:eapply TransformExt.compose. + 2: typeclasses eauto. 2:typeclasses eauto. + 2:{ auto. } + repeat try (eapply TransformExt.compose; [|typeclasses eauto|]). + typeclasses eauto. + all:unfold extends_pcuic_program; cbn. + all:intros; intuition auto; try congruence. + red. cbn. + + + + + + + + + } + red. + + Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : Transform.t TemplateProgram.template_program pcuic_program Ast.term PCUICAst.term @@ -160,14 +209,14 @@ Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := E pcuic_expand_lets_transform (K _ T1) ▷ erase_transform ▷ guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ - remove_params_fast_optimization (wcon := eq_refl) _ ▷ + remove_params_fast_optimization (wcon := eq_refl) ▷ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ remove_match_on_box_trans (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ let efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags) in rebuild_wf_env_transform (efl := efl) true ▷ - constructors_as_blocks_transformation efl (has_app := eq_refl) (has_pars := eq_refl) (has_cstrblocks := eq_refl). + constructors_as_blocks_transformation (efl := efl) (has_app := eq_refl) (has_pars := eq_refl) (has_rel := eq_refl) (hasbox := eq_refl) (has_cstrblocks := eq_refl). Next Obligation. destruct H; split => //. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v index 829d0d089..a8cd21c0a 100644 --- a/erasure/theories/EConstructorsAsBlocks.v +++ b/erasure/theories/EConstructorsAsBlocks.v @@ -432,7 +432,7 @@ Definition transform_blocks_constant_decl Σ cb := Definition transform_blocks_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (transform_blocks_constant_decl Σ cb) - | InductiveDecl idecl => d + | InductiveDecl idecl => InductiveDecl idecl end. Definition transform_blocks_env Σ := @@ -657,6 +657,15 @@ Proof. rewrite lookup_env_transform_blocks H //. Qed. +Lemma lookup_inductive_transform_blocks Σ ind : + lookup_inductive (transform_blocks_env Σ) ind = + lookup_inductive Σ ind. +Proof. + unfold lookup_inductive, lookup_minductive in *. + rewrite lookup_env_transform_blocks. + destruct lookup_env as [ [] | ]; cbn; congruence. +Qed. + Lemma lookup_constructor_transform_blocks Σ ind c : lookup_constructor (transform_blocks_env Σ) ind c = lookup_constructor Σ ind c. @@ -669,45 +678,57 @@ Qed. Lemma isLambda_transform_blocks Σ c : isLambda c -> isLambda (transform_blocks Σ c). Proof. destruct c => //. Qed. -Lemma transform_wellformed' {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : +Lemma transform_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_cstr_params = false -> cstr_as_blocks = false -> has_tApp -> wf_glob Σ -> @wellformed efl Σ n t -> isEtaExp Σ t -> - @wellformed (switch_cstr_as_blocks efl) Σ n (transform_blocks Σ t). + @wellformed (switch_cstr_as_blocks efl) (transform_blocks_env Σ) n (transform_blocks Σ t). Proof. intros hasp cstrbl hasa. - revert n. funelim (transform_blocks Σ t); simp_eta; cbn -[transform_blocks - lookup_inductive lookup_constructor lookup_constructor_pars_args + revert n. move t after hasa. move Σ after hasa. + funelim (transform_blocks Σ t); simp_eta; cbn -[transform_blocks transform_blocks_env + lookup_inductive lookup_constructor lookup_constructor_pars_args lookup_constant GlobalContextMap.lookup_constructor_pars_args isEtaExp]; intros m Hwf Hw; rtoProp; try split; eauto. - all: rewrite ?map_InP_spec; toAll; eauto; try now solve_all. - - rewrite cstrbl in H0. destruct H2. unfold isEtaExp_app in H2. unfold lookup_constructor_pars_args in *. + all: rewrite ?map_InP_spec; toAll; intuition eauto; try now solve_all. + - rewrite /lookup_constant lookup_env_transform_blocks in H0 *. + destruct lookup_env => //=; cbn in H0. destruct g => //; rewrite /transform_blocks_decl //=. + destruct (cst_body c) => //. + - rewrite cstrbl in H0. + rewrite lookup_constructor_transform_blocks. + unfold isEtaExp_app in H3. unfold lookup_constructor_pars_args in *. destruct (lookup_constructor Σ) as [[[]] | ]; try congruence; cbn - [transform_blocks]. - 2: eauto. split; auto. cbn in H2. eapply Nat.leb_le in H2. - apply/eqb_spec. lia. - - destruct H5. solve_all. solve_all. + - rewrite cstrbl in H0. + unfold isEtaExp_app in H3. + rewrite /lookup_constructor_pars_args lookup_constructor_transform_blocks //=. + rewrite /lookup_constructor_pars_args in H3. + destruct lookup_constructor as [[[] ?]|]=> //. cbn in H3. + eapply Nat.leb_le in H3. intuition auto. apply/eqb_spec. lia. + - now rewrite lookup_inductive_transform_blocks. + - now rewrite lookup_constructor_transform_blocks. - unfold wf_fix in *. rtoProp. solve_all. solve_all. now eapply isLambda_transform_blocks. - unfold wf_fix in *. rtoProp. solve_all. len. solve_all. len. destruct x. cbn -[transform_blocks isEtaExp] in *. rtoProp. eauto. - unfold wf_fix in *. len. solve_all. rtoProp; intuition auto. solve_all. - - rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. intros. - eapply isEtaExp_mkApps in H3. rewrite decompose_app_mkApps in H3; eauto. + - rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. + eapply isEtaExp_mkApps in H1. rewrite decompose_app_mkApps in H1; eauto. destruct construct_viewc; eauto. cbn in d. eauto. - rtoProp. eauto. repeat solve_all. + split; rtoProp; intuition eauto. solve_all; intuition eauto. - Opaque isEtaExp. destruct chop eqn:Ec. rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. - cbn -[lookup_constructor transform_blocks ] in *. intros. rtoProp. - rewrite isEtaExp_Constructor in H2. - rtoProp. unfold isEtaExp_app in *. unfold lookup_constructor_pars_args in H2. + cbn -[lookup_constructor transform_blocks ] in *. rewrite cstrbl in H1. + rewrite lookup_constructor_transform_blocks. intros. rtoProp. + rewrite isEtaExp_Constructor in H0. + rtoProp. unfold isEtaExp_app in *. unfold lookup_constructor_pars_args in H0. repeat split; eauto; rewrite ?lookup_constructor_transform_blocks; eauto. * destruct lookup_constructor as [ [[]] | ] eqn:E; cbn -[transform_blocks] in *; eauto. invs Heq. rewrite chop_firstn_skipn in Ec. invs Ec. - rewrite firstn_length. len. eapply Nat.leb_le in H2. + rewrite firstn_length. len. eapply Nat.leb_le in H0. apply/eqb_spec. assert (ind_npars m0 = 0). { destruct lookup_env as [ [] | ] eqn:E'; try congruence. @@ -725,25 +746,30 @@ Proof. solve_all. eapply All_skipn. solve_all. - rewrite wellformed_mkApps in Hw; eauto. rtoProp. cbn in *. rtoProp. cbn in *. destruct lookup_env as [[] | ]; cbn in *; eauto; try congruence. + - rewrite lookup_constructor_transform_blocks. rewrite wellformed_mkApps in Hw => //. + move/andP: Hw => [wf _]. + simpl in wf. rtoProp; intuition auto. - rewrite isEtaExp_Constructor in H0. rtoProp. rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq; unfold lookup_constructor_pars_args in *. - destruct lookup_constructor as [ [[]] | ]; cbn in Heq; try congruence. - cbn. split; eauto. rewrite wellformed_mkApps in Hw; eauto. rtoProp. solve_all. + rewrite lookup_constructor_transform_blocks. + now destruct lookup_constructor as [ [[]] | ]; cbn in Heq; try congruence. + - rewrite wellformed_mkApps in Hw => //. apply isEtaExp_mkApps in H0. + rewrite decompose_app_mkApps in H0 => //. cbn in H0. rtoProp; intuition auto. solve_all. Qed. -Lemma transform_wellformed_decl' {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : +Lemma transform_wellformed_decl {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : has_cstr_params = false -> cstr_as_blocks = false -> has_tApp -> wf_glob Σ -> @wf_global_decl efl Σ d -> isEtaExp_decl Σ d -> - @wf_global_decl (switch_cstr_as_blocks efl) Σ (transform_blocks_decl Σ d). + @wf_global_decl (switch_cstr_as_blocks efl) (transform_blocks_env Σ) (transform_blocks_decl Σ d). Proof. intros wf wfd etad. destruct d => //=. cbn. destruct c as [[]] => //=. - eapply transform_wellformed'; tea. + eapply transform_wellformed; tea. Qed. From MetaCoq.Erasure Require Import EGenericMapEnv. @@ -804,23 +830,13 @@ Proof. eapply H0. Qed. -Lemma transform_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : - has_cstr_params = false -> - cstr_as_blocks = false -> - has_tApp -> - wf_glob Σ -> - @wellformed efl Σ n t -> - isEtaExp Σ t -> - @wellformed (switch_cstr_as_blocks efl) (transform_blocks_env Σ) n (transform_blocks Σ t). -Proof. - intros. eapply gen_transform_wellformed_irrel; eauto. - eapply transform_wellformed'; eauto. -Qed. - From MetaCoq.Erasure Require Import EGenericGlobalMap. #[local] -Instance GT : GenTransform := { gen_transform := transform_blocks }. +Instance GT : GenTransform := { gen_transform := transform_blocks; gen_transform_inductive_decl := id }. +#[local] +Instance GTID : GenTransformId GT. +Proof. red; reflexivity. Qed. #[local] Instance GTExt efl : has_tApp -> GenTransformExtends efl (switch_cstr_as_blocks efl) GT. Proof. @@ -838,9 +854,10 @@ Proof. cstr_as_blocks = false /\ isEtaExp Σ t |}; auto. intros Σ n t [hasapp [cstrp [cstrb pre]]] wfΣ wft. - apply transform_wellformed => //. + eapply transform_wellformed => //. Defined. + Lemma Pre_glob efl Σ wf : has_cstr_params = false -> cstr_as_blocks = false -> diff --git a/erasure/theories/EImplementBox.v b/erasure/theories/EImplementBox.v index 3d854bbb3..e843cd6ba 100644 --- a/erasure/theories/EImplementBox.v +++ b/erasure/theories/EImplementBox.v @@ -190,7 +190,7 @@ Definition implement_box_constant_decl cb := Definition implement_box_decl d := match d with | ConstantDecl cb => ConstantDecl (implement_box_constant_decl cb) - | InductiveDecl idecl => d + | InductiveDecl idecl => InductiveDecl idecl end. Definition implement_box_env (Σ : global_declarations) := @@ -325,6 +325,21 @@ Proof. destruct lookup_env as [ [] | ]; cbn; congruence. Qed. +Lemma lookup_inductive_implement_box Σ ind : + lookup_inductive (implement_box_env Σ) ind = + lookup_inductive Σ ind. +Proof. + unfold lookup_constructor, lookup_inductive, lookup_minductive in *. + rewrite lookup_env_implement_box. + destruct lookup_env as [ [] | ]; cbn; congruence. +Qed. + +Lemma lookup_constructor_pars_args_implement_box {efl : EEnvFlags} {Σ ind n} : + lookup_constructor_pars_args (implement_box_env Σ) ind n = lookup_constructor_pars_args Σ ind n. +Proof. + cbn -[lookup_constructor]. now rewrite lookup_constructor_implement_box. +Qed. + Lemma isLambda_implement_box c : isLambda c -> isLambda (implement_box c). Proof. destruct c => //. Qed. @@ -352,20 +367,23 @@ Lemma transform_wellformed' {efl : EEnvFlags} {Σ : list (kername × global_decl has_tApp -> wf_glob Σ -> @wellformed efl Σ n t -> - @wellformed (switch_off_box efl) Σ n (implement_box t). + @wellformed (switch_off_box efl) (implement_box_env Σ) n (implement_box t). Proof. intros hasa. revert n. funelim (implement_box t); simp_eta; cbn -[implement_box lookup_inductive lookup_constructor lookup_constructor_pars_args GlobalContextMap.lookup_constructor_pars_args isEtaExp]; intros m Hwf Hw; rtoProp; try split; eauto. all: rewrite ?map_InP_spec; toAll; eauto; try now solve_all. + - rewrite lookup_env_implement_box. destruct (lookup_env Σ n) => //. destruct g => //=. + destruct (cst_body c) => //=. - unfold lookup_constructor_pars_args in *. - destruct (lookup_constructor Σ) as [[[]] | ]; try congruence; cbn - [implement_box]. - all: destruct cstr_as_blocks; cbn in *; rtoProp; try split; eauto. - + now rewrite map_length. + rewrite lookup_constructor_implement_box. rewrite H2. intuition auto. + - rewrite lookup_constructor_pars_args_implement_box. len. + all: destruct cstr_as_blocks; rtoProp; try split; eauto. + solve_all. + destruct block_args; cbn in *; eauto. - - repeat split; eauto. solve_all. + - rewrite lookup_inductive_implement_box. intuition auto. solve_all. + - rewrite lookup_constructor_implement_box. intuition auto. - unfold wf_fix in *. rtoProp. solve_all. solve_all. now eapply isLambda_implement_box. - unfold wf_fix in *. rtoProp. solve_all. len. solve_all. len. destruct x. @@ -378,7 +396,7 @@ Lemma transform_wellformed_decl' {efl : EEnvFlags} {Σ : global_declarations} d has_tApp -> wf_glob Σ -> @wf_global_decl efl Σ d -> - @wf_global_decl (switch_off_box efl) Σ (implement_box_decl d). + @wf_global_decl (switch_off_box efl) (implement_box_env Σ) (implement_box_decl d). Proof. intros. destruct d => //=. cbn. @@ -386,40 +404,7 @@ Proof. eapply transform_wellformed'; tea. Qed. -From MetaCoq.Erasure Require Import EGenericMapEnv. - -Lemma transform_wellformed {efl : EEnvFlags} {Σ : global_declarations} n t : - has_tApp -> - wf_glob Σ -> - @wellformed efl Σ n t -> - @wellformed (switch_off_box efl) (implement_box_env Σ) n (implement_box t). -Proof. - intros. eapply gen_transform_wellformed_irrel; eauto. - eapply transform_wellformed'; eauto. -Qed. - -Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : global_declarations} : - has_tApp -> - wf_glob (efl := efl) Σ -> - forall d, - wf_global_decl (efl := efl) Σ d -> - wf_global_decl (efl := switch_off_box efl) (implement_box_env Σ) (implement_box_decl d). -Proof. - intros. - destruct d => /= //. - rewrite /isEtaExp_constant_decl. cbn in H1. - destruct (cst_body c) => /= //. - eapply transform_wellformed => //. -Qed. - -Lemma fresh_global_optimize_env {Σ : global_declarations} kn : - fresh_global kn Σ -> - fresh_global kn (implement_box_env Σ). -Proof. - induction 1; cbn; constructor; auto. -Qed. - -Lemma fresh_global_map_on_snd Σ f kn : +Lemma fresh_global_map_on_snd {Σ : global_context} f kn : fresh_global kn Σ -> fresh_global kn (map (on_snd f) Σ). Proof. @@ -430,19 +415,15 @@ Lemma transform_wf_global {efl : EEnvFlags} {Σ : global_declarations} : has_tApp -> wf_glob (efl := efl) Σ -> wf_glob (efl := switch_off_box efl) (implement_box_env Σ). Proof. - intros hasapp wfg. clear - hasapp wfg. - assert (extends Σ Σ). now exists []. + intros hasapp wfg. + assert (extends_prefix Σ Σ). now exists []. revert H wfg. generalize Σ at 2 3. induction Σ; cbn; constructor; auto. - eapply IHΣ; rtoProp; intuition eauto. destruct H. subst Σ0. exists (x ++ [a]). now rewrite -app_assoc. - epose proof (EExtends.extends_wf_glob _ H wfg); tea. depelim H0. cbn. - eapply gen_transform_wellformed_decl_irrel; trea. - destruct d; cbn in *; eauto. - destruct (cst_body c); eauto. - cbn -[implement_box]. cbn in H1. - eapply transform_wellformed'; eauto. + now eapply transform_wellformed_decl'. - eapply fresh_global_map_on_snd. eapply EExtends.extends_wf_glob in wfg; tea. now depelim wfg. Qed. diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index 565cdcfbd..af091df81 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -319,7 +319,7 @@ Definition remove_match_on_box_constant_decl Σ cb := Definition remove_match_on_box_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (remove_match_on_box_constant_decl Σ cb) - | InductiveDecl idecl => d + | InductiveDecl idecl => InductiveDecl idecl end. Definition remove_match_on_box_env Σ := diff --git a/erasure/theories/EProgram.v b/erasure/theories/EProgram.v index 699164a66..cd2d7cc49 100644 --- a/erasure/theories/EProgram.v +++ b/erasure/theories/EProgram.v @@ -51,3 +51,45 @@ Proof. intros wf; depelim wf. constructor; auto. Qed. +Module TransformExt. + Section Opt. + Context {program program' : Type}. + Context {value value' : Type}. + Context {eval : program -> value -> Prop}. + Context {eval' : program' -> value' -> Prop}. + Context (o : Transform.t program program' value value' eval eval'). + Context (extends : program -> program -> Prop). + Context (extends' : program' -> program' -> Prop). + + Class t := preserves_obs : forall p p' (pr : o.(pre) p) (pr' : o.(pre) p'), + extends p p' -> extends' (o.(transform) p pr) (o.(transform) p' pr'). + + End Opt. + + Section Comp. + Context {program program' program'' : Type}. + Context {value value' value'' : Type}. + Context {eval : program -> value -> Prop}. + Context {eval' : program' -> value' -> Prop}. + Context {eval'' : program'' -> value'' -> Prop}. + + Context {extends : program -> program -> Prop}. + Context {extends' : program' -> program' -> Prop}. + Context {extends'' : program'' -> program'' -> Prop}. + + Local Obligation Tactic := idtac. + #[global] + Instance compose (o : Transform.t program program' value value' eval eval') + (o' : Transform.t program' program'' value' value'' eval' eval'') + (oext : t o extends extends') + (o'ext : t o' extends' extends'') + (hpp : (forall p, o.(post) p -> o'.(pre) p)) + : t (Transform.compose o o' hpp) extends extends''. + Proof. red. + intros p p' pr pr' ext. + eapply o'ext. now apply oext. + Qed. + + End Comp. + +End TransformExt. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index b1d033023..10eceaf4b 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -764,25 +764,16 @@ Proof. destruct x => //. Qed. +Definition extends_global_env (Σ Σ' : PCUICAst.PCUICEnvironment.global_env) := + (forall kn decl, PCUICAst.PCUICEnvironment.lookup_env Σ kn = Some decl -> + PCUICAst.PCUICEnvironment.lookup_env Σ' kn = Some decl) /\ + (forall tag, primitive_constant Σ tag = primitive_constant Σ' tag). + Lemma is_erasableb_irrel_global_env {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} {X_type' X'} {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} {Γ t wt wt'} : - (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> - abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> + forall (hl : Hlookup X_type X X_type' X'), is_erasableb X_type X Γ t wt = is_erasableb X_type' X' Γ t wt'. Proof. - intro ext. - (* ext eqext. *) - assert (hl : Hlookup X_type X X_type' X'). - { red. intros Σ H Σ' H0. specialize (ext _ _ H H0) as [[X0] H1]. - split. intros kn decl decl' H2 H3. - rewrite -(abstract_env_lookup_correct' _ _ H). - rewrite -(abstract_env_lookup_correct' _ _ H0). - rewrite H2 H3. pose proof (abstract_env_ext_wf _ H) as [X1]. - eapply lookup_env_extends_NoDup in H3; try eapply NoDup_on_global_decls; try eapply X1; eauto; tc. cbv [PCUICEnvironment.fst_ctx] in *. congruence. - destruct X0. intros tag. - rewrite (abstract_primitive_constant_correct _ _ _ H). - rewrite (abstract_primitive_constant_correct _ _ _ H0). - unfold primitive_constant. - rewrite e0. congruence. } + intros hl. simp is_erasableb. set (obl := is_erasableb_obligation_2 _ _ _ _). clearbody obl. set(ty := (type_of_typing X_type' _ _ _ wt')) in *. @@ -809,12 +800,28 @@ Ltac iserasableb_irrel_env := generalize dependent H; rewrite (@is_erasableb_irrel_global_env _ _ _ _ _ _ _ _ wt wt') //; intros; rewrite Heq end. + (* + (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> + abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> + + assert (hl : Hlookup X_type X X_type' X'). + { red. intros Σ H Σ' H0. specialize (ext _ _ H H0) as [[X0] H1]. + split. intros kn decl decl' H2 H3. + rewrite -(abstract_env_lookup_correct' _ _ H). + rewrite -(abstract_env_lookup_correct' _ _ H0). + rewrite H2 H3. + red in X0. specialize (proj1 X0 kn decl' H3). congruence. + destruct X0. intros tag. + rewrite (abstract_primitive_constant_correct _ _ _ H). + rewrite (abstract_primitive_constant_correct _ _ _ H0). + now symmetry. } +*) + Lemma erase_irrel_global_env {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} {X_type' X'} {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} {Γ t wt wt'} : - (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> - abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> + forall (hl : Hlookup X_type X X_type' X'), erase X_type X Γ t wt = erase X_type' X' Γ t wt'. Proof. - intros ext. + intros hl. move: wt'. eapply (erase_elim X_type X (fun Γ t wt e => @@ -840,10 +847,9 @@ Proof. all:bang. Qed. -Lemma erase_constant_body_suffix {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} {X_type' X'} {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} {cb ondecl ondecl'} : -(forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> - abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> -erase_constant_body X_type X cb ondecl = erase_constant_body X_type' X' cb ondecl'. +Lemma erase_constant_body_irrel {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} {X_type' X'} {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} {cb ondecl ondecl'} : + forall (hl : Hlookup X_type X X_type' X'), + erase_constant_body X_type X cb ondecl = erase_constant_body X_type' X' cb ondecl'. Proof. intros ext. destruct cb => //=. @@ -884,22 +890,57 @@ Notation NormalizationIn_erase_global_decls X decls end) (only parsing). +Lemma normalization_in_inv {X_type : abstract_env_impl} (X : X_type.π1) + (decls : global_declarations) kn cb + (normalization_in : NormalizationIn_erase_global_decls X ((kn, ConstantDecl cb) :: decls)) : + NormalizationIn_erase_global_decls (abstract_pop_decls X) decls. +Proof. + cbv [id]. intros. + unshelve eapply (normalization_in (S n)); cbn; tea. lia. +Defined. + +Program Definition erase_constant_decl {X_type : abstract_env_impl} (X : X_type.π1) + (cb : constant_body) + (normalization_in : forall pf, + let Xext := abstract_make_wf_env_ext X (cst_universes cb) pf in + forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ) + (oncb : forall Σ : global_env, Σ ∼ X -> ∥ wf_ext (Σ, cst_universes cb) * on_constant_decl (lift_typing typing) (Σ, cst_universes cb) cb ∥) := + let Xext := abstract_make_wf_env_ext X (cst_universes cb) _ in + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) + @erase_constant_body X_type Xext normalization_in' cb _. +Next Obligation. +pose proof (abstract_env_wf _ H) as [wf]. +specialize (oncb _ H). destruct oncb. sq. intuition auto. +Qed. + +Next Obligation. + unfold id. intros. + unshelve eapply normalization_in; eauto. +Defined. + +Next Obligation. + destruct Σ as [Σ ext]. + pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_wf _ HX) as [wfX]. + pose proof (abstract_make_wf_env_ext_correct X (cst_universes cb) _ _ _ HX H). + noconf H0. + clear H; specialize (oncb _ HX). destruct oncb as [[]]; sq; auto. +Qed. + Program Fixpoint erase_global_decls {X_type : abstract_env_impl} (deps : KernameSet.t) (X : X_type.π1) (decls : global_declarations) {normalization_in : NormalizationIn_erase_global_decls X decls} (prop : forall Σ : global_env, abstract_env_rel X Σ -> Σ.(declarations) = decls) - : E.global_declarations := + : E.global_declarations * KernameSet.t := match decls with - | [] => [] + | [] => ([], deps) | (kn, ConstantDecl cb) :: decls => let X' := abstract_pop_decls X in if KernameSet.mem kn deps then - let Xext := abstract_make_wf_env_ext X' (cst_universes cb) _ in - let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) - let cb' := @erase_constant_body X_type Xext normalization_in' cb _ in + let cb' := @erase_constant_decl X_type X' cb _ _ in let deps := KernameSet.union deps (snd cb') in let X'' := erase_global_decls deps X' decls _ in - ((kn, E.ConstantDecl (fst cb')) :: X'') + (((kn, E.ConstantDecl (fst cb')) :: fst X''), snd X'') else erase_global_decls deps X' decls _ @@ -907,37 +948,26 @@ Program Fixpoint erase_global_decls let X' := abstract_pop_decls X in if KernameSet.mem kn deps then let mib' := erase_mutual_inductive_body mib in - let X'' := erase_global_decls deps X' decls _ in - ((kn, E.InductiveDecl mib') :: X'') + let X'':= erase_global_decls deps X' decls _ in + (((kn, E.InductiveDecl mib') :: fst X''), snd X'') else erase_global_decls deps X' decls _ end. -Next Obligation. - pose proof (abstract_env_wf _ H) as [wf]. - pose proof (abstract_env_exists X) as [[? HX]]. - pose proof (abstract_env_wf _ HX) as [wfX]. - assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). - { now eexists. } - destruct (abstract_pop_decls_correct X decls prop' _ _ HX H) as [? []]. - clear H. specialize (prop _ HX). destruct x, Σ, H0; cbn in *. - subst. sq. destruct wfX. depelim o0. destruct o1. split => //. -Qed. Next Obligation. cbv [id]. - unshelve eapply (normalization_in 0); cbn; try reflexivity; try lia. + unshelve eapply (normalization_in 0); tea; cbn; try reflexivity; try lia. Defined. Next Obligation. - pose proof (abstract_env_ext_wf _ H) as [wf]. - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[? HX']]. - pose proof (abstract_env_wf _ HX') as [wfX']. pose proof (abstract_env_exists X) as [[? HX]]. pose proof (abstract_env_wf _ HX) as [wfX]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } - pose proof (abstract_pop_decls_correct X decls prop' _ _ HX HX') as [? []]. - pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ HX' H). - clear H HX'. specialize (prop _ HX). destruct x, Σ as [[] u], H0; cbn in *. - subst. sq. inversion H3. subst. clear H3. destruct wfX. cbn in *. - rewrite prop in o0. depelim o0. destruct o1. exact on_global_decl_d. + pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). + destruct x, Σ as [[] u], H0; cbn in *. + subst. sq. inversion H1. subst. destruct wfX. cbn in *. + specialize (prop _ HX). + cbn in prop. + rewrite prop in o0. depelim o0. destruct o1. + split. 2:exact on_global_decl_d. split => //. Qed. Next Obligation. unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. @@ -984,16 +1014,30 @@ Lemma erase_global_decls_irr erase_global_decls deps X decls (normalization_in:=normalization_in') prf'. Proof. revert X deps normalization_in normalization_in' prf prf'. - induction decls; eauto. intros. destruct a as [kn []]; cbn. - - destruct KernameSet.mem; cbn. - erewrite erase_constant_body_suffix. f_equal. - eapply IHdecls. intros. - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[env wf]]. - rewrite (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H). - now rewrite (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H0). - apply IHdecls. - - destruct KernameSet.mem; cbn. f_equal. eapply IHdecls. - apply IHdecls. + induction decls; eauto. intros. destruct a as [kn []]. + - cbn. + set (ec := erase_constant_decl _ _ _ _). + set (ec' := erase_constant_decl _ _ _ _). + assert (ec = ec') as <-. + { subst ec ec'. + unfold erase_constant_decl. + erewrite erase_constant_body_irrel. reflexivity. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[env wf]]. + red. intros. + pose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H). + pose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H0). + split => //. + { intros. + rewrite -(abstract_env_lookup_correct' _ _ H). + rewrite -(abstract_env_lookup_correct' _ _ H0). now rewrite H1 H2. } + intros. + { rewrite (abstract_primitive_constant_correct _ _ _ H). + rewrite (abstract_primitive_constant_correct _ _ _ H0). + now rewrite H1 H2. } } + destruct KernameSet.mem; cbn. + f_equal; f_equal. f_equal; eapply IHdecls. + apply IHdecls. apply IHdecls. + - cbn. destruct KernameSet.mem; cbn. f_equal. f_equal. 1-2:f_equal. all:eapply IHdecls. Qed. Definition global_erased_with_deps (Σ : global_env) (Σ' : EAst.global_declarations) kn := @@ -1508,7 +1552,7 @@ Lemma erase_global_includes X_type (X:X_type.π1) deps decls {normalization_in} KernameSet.subset deps' deps -> forall Σ : global_env, abstract_env_rel X Σ -> let Σ' := erase_global_decls deps X decls (normalization_in:=normalization_in) prf in - includes_deps Σ Σ' deps'. + includes_deps Σ (fst Σ') deps'. Proof. intros ? sub Σ wfΣ; cbn. induction decls in X, H, sub, prf, deps, deps', Σ , wfΣ, normalization_in |- *. - simpl. intros i hin. elimtype False. @@ -1524,6 +1568,7 @@ Proof. elim: H0. intros -> [= <-]. * destruct d as [|]; [left|right]. { cbn. set (Xpop := abstract_pop_decls X). + unfold erase_constant_decl. set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]. epose proof (abstract_env_ext_exists Xmake) as [[Σmake wfmake]]. @@ -1594,6 +1639,7 @@ Proof. * intros ikn Hi. destruct d as [|]. ++ simpl. destruct (KernameSet.mem kn deps) eqn:eqkn. + unfold erase_constant_decl. set (Xpop := abstract_pop_decls X). set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. @@ -1667,7 +1713,7 @@ Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) erase_global_decls deps X decls (normalization_in:=normalization_in) prf = Σ' -> (forall Σ : global_env, abstract_env_rel X Σ -> Σ |-p t ⇓ v) -> forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> - exists v', Σ ;;; [] |- v ⇝ℇ v' /\ ∥ Σ' ⊢ t' ⇓ v' ∥. + exists v', Σ ;;; [] |- v ⇝ℇ v' /\ ∥ fst Σ' ⊢ t' ⇓ v' ∥. Proof. intros wt. intros HΣ' Hsub Ht' ev Σext wfΣex. @@ -1676,7 +1722,7 @@ Proof. destruct (wt _ wfΣex) as [T wt']. pose proof (abstract_env_ext_wf _ wfΣex) as [wfΣ]. specialize (H _ wfΣex). - unshelve epose proof (erase_global_erases_deps (Σ' := Σ') wfΣ wt' H _); cycle 2. + unshelve epose proof (erase_global_erases_deps (Σ' := fst Σ') wfΣ wt' H _); cycle 2. rewrite <- Ht'. eapply erase_global_includes; eauto. intros. eapply term_global_deps_spec in H; eauto. @@ -1802,7 +1848,7 @@ Local Hint Constructors expanded : expanded. Local Arguments erase_global_decls _ _ _ _ _ : clear implicits. -Lemma lookup_env_erase X_type X deps decls normalization_in prf kn d : +(*Lemma lookup_env_erase X_type X deps decls normalization_in prf kn d : KernameSet.In kn deps -> forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some (InductiveDecl d) -> EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = Some (EAst.InductiveDecl (erase_mutual_inductive_body d)). @@ -1834,18 +1880,352 @@ Proof. eapply IHdecls => //; eauto. eapply IHdecls => //; eauto. Qed. +*) + +Lemma lookup_env_erase_decl_None X_type X deps decls normalization_in prf kn : + forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = None -> + EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf).1 kn = None. +Proof. + intros Σ wfΣ. + pose proof (prf _ wfΣ). + unfold lookup_env. rewrite H. clear H. + rewrite /lookup_env. + induction decls in X, Σ , wfΣ ,prf, deps, normalization_in |- *. + - move=> /= //. + - destruct a as [kn' d']. + cbn -[erase_global_decls]. + case: (eqb_spec kn kn'); intros e'; subst. + intros [= ->]. + cbn. destruct d'. cbn. + case_eq (KernameSet.mem kn' deps); move => hin'; cbn. + + destruct (eqb_spec kn kn') => //. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. + + intros. set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. + + intros hin. + case_eq (KernameSet.mem kn' deps); move => hin'; cbn. + destruct (eqb_spec kn kn') => //. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. + intros. set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. +Qed. + +Lemma lookup_env_erase_global_diff X_type X deps decls kn kn' d' normalization_in prf : + kn <> kn' -> + exists deps' nin' prf', + KernameSet.Subset deps deps' /\ + EGlobalEnv.lookup_env (erase_global_decls X_type deps X ((kn', d') :: decls) normalization_in prf).1 kn = + EGlobalEnv.lookup_env (erase_global_decls X_type deps' (abstract_pop_decls X) decls nin' prf').1 kn /\ + (KernameSet.In kn (erase_global_decls X_type deps X ((kn', d') :: decls) normalization_in prf).2 -> + KernameSet.In kn (erase_global_decls X_type deps' (abstract_pop_decls X) decls nin' prf').2). +Proof. + intros hd. + simpl. destruct d'. + + destruct KernameSet.mem. cbn. + destruct (eqb_spec kn kn') => //. + do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. + auto. + do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. + auto. + + destruct KernameSet.mem. cbn. + destruct (eqb_spec kn kn') => //. + do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. auto. + do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. auto. +Qed. + +Lemma lookup_env_In_map_fst Σ kn decl : lookup_global Σ kn = Some decl -> In kn (map fst Σ). +Proof. + induction Σ; cbn => //. + case: eqb_spec. + + intros -> [= <-]. now left. + + intros _ hl. eauto. +Qed. + +Lemma erase_constant_decl_deps {X_type : abstract_env_impl} (X : X_type.π1) (cb : constant_body) normalization_in oncb : + forall Σ : global_env, abstract_env_rel X Σ -> + forall kn, KernameSet.In kn (erase_constant_decl X cb normalization_in oncb).2 -> In kn (map fst (declarations Σ)). +Proof. + intros Σ wfΣ kn. + unfold erase_constant_decl. + set (ec := erase_constant_body _ _ _ _). + destruct cb. destruct cst_body0. + 2:{ subst ec; cbn. KernameSetDecide.fsetdec. } + intros hc. + epose proof (erase_constant_body_correct' (@eq_refl _ (EAst.cst_body ec.1))). + subst ec. + set (ec := erase_constant_body _ _ _ _) in *. + set (X' := abstract_make_wf_env_ext _ _ _) in *. + pose proof (abstract_env_ext_exists X') as [[Σ' H']]. + pose proof (abstract_env_ext_wf _ H') as [wfΣ']. + specialize (H _ H') as [[t0 [T []]]]. + rewrite -e in hc. + destruct p as [hty her]. + epose proof (term_global_deps_spec wfΣ' hty her _ hc). + epose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ wfΣ H'). cbn in H0. subst Σ'. + red in H. destruct H as [[decl hl]]. + now eapply lookup_env_In_map_fst in hl. +Qed. + +Lemma in_erase_global_decls_acc X_type X deps decls kn normalization_in prf : + KernameSet.In kn (erase_global_decls X_type deps X decls normalization_in prf).2 -> + KernameSet.In kn deps \/ In kn (map fst decls). +Proof. + induction decls in X, prf, deps, normalization_in |- *. + cbn; auto. destruct a as [kn' []]. + + cbn. set (ec := erase_constant_decl _ _ _ _). + set (eg := erase_global_decls _ _ _ _ _ _). + set (eg' := erase_global_decls _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + * cbn; intros. specialize (IHdecls _ _ _ _ H0). + destruct IHdecls as [Hu|Hm]; auto. + eapply KernameSet.union_spec in Hu. destruct Hu; auto. + unfold ec in H1; cbn in H1. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + eapply erase_constant_decl_deps in H1; tea. + pose proof (abstract_env_exists X) as [[ΣX HX]]. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ HX wfpop). + intros. rewrite prf => //. now eexists. + now destruct H2 as [<- _]. + * intros hdeps hin. + eapply IHdecls in hin. intuition auto. + + cbn; set (eg := erase_global_decls _ _ _ _ _ _); + set (eg' := erase_global_decls _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + * cbn; intros. specialize (IHdecls _ _ _ _ H0). + destruct IHdecls as [Hu|Hm]; auto. + * intros hdeps hin. + eapply IHdecls in hin. intuition auto. +Qed. + +Lemma wf_fresh_globals {cf : checker_flags} (Σ : global_env) : wf Σ -> EnvMap.EnvMap.fresh_globals Σ.(declarations). +Proof. + destruct Σ as [univs Σ]; cbn. + move=> [] onu; cbn. induction 1; try destruct o; constructor; auto; constructor; eauto. +Qed. + +Lemma lookup_env_erase_decl X_type X deps decls normalization_in prf kn decl : + forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some decl -> + let er := erase_global_decls X_type deps X decls normalization_in prf in + KernameSet.In kn er.2 -> + match decl with + | ConstantDecl cb => + exists (X' : X_type.π1) nin pf, + (EGlobalEnv.lookup_env er.1 kn = + Some (EAst.ConstantDecl (fst (erase_constant_decl X' cb nin pf)))) /\ + (forall Σ Σ', Σ ∼ X -> Σ' ∼ X' -> ∥ strictly_extends_decls Σ' Σ ∥) + | InductiveDecl mib => + EGlobalEnv.lookup_env er.1 kn = + Some (EAst.InductiveDecl (erase_mutual_inductive_body mib)) + end. +Proof. + intros Σ wfΣ. pose proof (prf _ wfΣ). + unfold lookup_env. rewrite H. clear H. + rewrite /lookup_env. + induction decls in X, Σ , wfΣ ,prf, deps, decl, normalization_in |- *. + - move=> /= //. + - destruct a as [kn' d']. + cbn -[erase_global_decls]. + case: (eqb_spec kn kn'); intros e'; subst. + intros [= ->]. + destruct decl. + + cbn; set (ec := erase_constant_decl _ _ _ _); + set (eg := erase_global_decls _ _ _ _ _ _); + set (eg' := erase_global_decls _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + move/KernameSet.mem_spec => hin'; cbn. + ++ intros hin. cbn; rewrite eqb_refl; + do 3 eexists. split; [reflexivity|]. + intros ? ? hx hpop. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ hx hpop). intros. rewrite prf => //. now eexists. + destruct H as [? []]. unfold strictly_extends_decls. rewrite H. sq; split => //. clear ec eg eg' hin. specialize (prf _ hx). rewrite prf. + now eexists [_]. + ++ intros kn'deps kn'eg'. + eapply in_erase_global_decls_acc in kn'eg'. + destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. + elimtype False. clear -prf wfΣ H. + specialize (prf _ wfΣ). + pose proof (abstract_env_wf _ wfΣ) as []. eapply wf_fresh_globals in X0. + rewrite prf in X0. depelim X0. + apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. + + cbn; + set (eg := erase_global_decls _ _ _ _ _ _); + set (eg' := erase_global_decls _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + move/KernameSet.mem_spec => hin'; cbn. + ++ intros hin. cbn; rewrite eqb_refl; + do 3 eexists. + ++ intros kn'deps kn'eg'. + eapply in_erase_global_decls_acc in kn'eg'. + destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. + elimtype False. clear -prf wfΣ H. + specialize (prf _ wfΣ). + pose proof (abstract_env_wf _ wfΣ) as []. eapply wf_fresh_globals in X0. + rewrite prf in X0. depelim X0. + apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. + + intros hl hin. + epose proof (lookup_env_erase_global_diff X_type X deps decls kn kn' d' _ _ e'). + destruct H as [deps' [nin' [prf' [sub [hl' hin']]]]]. + eapply hin' in hin. + erewrite hl'. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + specialize (IHdecls Xpop deps'). specialize (IHdecls nin' prf' decl _ wfpop hl hin). + destruct decl; intuition auto. + destruct IHdecls as [X' [nin [pf []]]]. exists X', nin, pf. split => //. + intros. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H1 wfpop). intros. rewrite prf => //. now eexists. + specialize (H0 _ _ wfpop H2). destruct H0; sq. move: X0; rewrite /strictly_extends_decls. destruct H3 as [? []]. + rewrite H4 H0 H3. rewrite -(prf' _ wfpop). pose proof (prf _ H1). rewrite -H0 in H5. rewrite H5. + intros []; split => //. destruct s as [Σ'' eq]. eexists ((kn', d') :: Σ''). now rewrite eq. +Qed. + +(* +Lemma lookup_env_erase_decl X_type X deps decls normalization_in prf kn decl : + forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some decl -> + if KernameSet.mem kn deps then + match decl with + | ConstantDecl cb => + exists (X' : X_type.π1) nin pf, + EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = + Some (EAst.ConstantDecl (fst (erase_constant_decl X' cb nin pf))) + | InductiveDecl mib => + EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = + Some (EAst.InductiveDecl (erase_mutual_inductive_body mib)) + end + else + EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = None. +Proof. + intros Σ wfΣ. pose proof (prf _ wfΣ). + unfold lookup_env. rewrite H. clear H. + rewrite /lookup_env. + induction decls in X, Σ , wfΣ ,prf, deps, decl, normalization_in |- *. + - move=> /= //. + - destruct a as [kn' d']. + cbn -[erase_global_decls]. + case: (eqb_spec kn kn'); intros e'; subst. + intros [= ->]. + case_eq (KernameSet.mem kn' deps); move => hin'; cbn; rewrite hin'; cbn. + + destruct decl; cbn; rewrite eqb_refl //. + do 3 eexists. reflexivity. + + specialize (IHdecls (abstract_pop_decls X) deps). + destruct decl. + * match goal with + |- context [ erase_global_decls _ _ _ _ ?nin ?prf ] => specialize (IHdecls nin prf) + end. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + case_eq (lookup_global decls kn'). + intros g hg. + specialize (IHdecls g _ wfpop hg). now rewrite hin' in IHdecls. + epose proof (lookup_env_erase_decl_None X_type (abstract_pop_decls X) deps decls _ _ _ _ wfpop). + intros hl. eapply H. unfold lookup_env. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop). + intros. pose proof (prf _ H0). now eexists. + destruct H0. now rewrite H0. + * rewrite hin' in IHdecls. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + case_eq (lookup_global decls kn'). + intros g hg. + eapply IHdecls; tea. + epose proof (lookup_env_erase_decl_None X_type (abstract_pop_decls X) deps decls _ _ _ _ wfpop). + intros hl; eapply H. + unfold lookup_env. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop). + intros. pose proof (prf _ H0). now eexists. + destruct H0. now rewrite H0. + + intros hl. + epose proof (lookup_env_erase_global_diff X_type X deps decls kn kn' d' _ _ e'). + destruct H as [deps' [nin' [prf' [sub H]]]]. + erewrite H. + case_eq (KernameSet.mem kn deps) => //. + * move/KernameSet.mem_spec => hin. + assert (kndeps' : KernameSet.mem kn deps'). + { now apply KernameSet.mem_spec; eapply sub. } + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + specialize (IHdecls Xpop deps'). + epose proof (IHdecls _ _ decl _ wfpop hl) ; tea. rewrite kndeps' in H0. eapply H0. + * intros hin. rewrite hin in IHdecls. + + + ** intros g hl. eapply IHdecls. + destruct KernameSet.mem. cbn. + rewrite (negbTE (proj2 (neqb _ _) e')). + eapply IHdecls => //; eauto. eapply KernameSet.union_spec. left => //. + eapply IHdecls => //; eauto. + simpl. + + destruct KernameSet.mem. cbn. + rewrite (negbTE (proj2 (neqb _ _) e')). + eapply IHdecls => //; eauto. + eapply IHdecls => //; eauto. +Qed.*) + +Lemma in_deps_in_erase_global_decls X_type X deps decls normalization_in prf kn decl : + forall Σ, Σ ∼ X -> + lookup_env Σ kn = Some decl -> + KernameSet.In kn deps -> + KernameSet.In kn (erase_global_decls X_type deps X decls normalization_in prf).2. +Proof. + induction decls in X, deps, normalization_in, prf |- *. + - intros. rewrite /lookup_env prf in H0 => //. + - intros. cbn. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H wfpop). intros. rewrite prf => //. now eexists. + destruct H2 as [Hd [Hu Hr]]. + destruct a. destruct g. + + set (eg := erase_global_decls _ _ _ _ _ _); + set (eg' := erase_global_decls _ _ _ _ _ _). + case_eq (KernameSet.mem k deps). + * cbn. intros hm. + destruct (eqb_spec k kn). + ++ subst k. admit. + ++ eapply IHdecls. tea. + rewrite /lookup_env Hd. + rewrite /lookup_env (prf _ H) in H0. cbn in H0. + admit. + KernameSetDecide.fsetdec. + * intros hnin. eapply IHdecls; tea. + rewrite /lookup_env Hd. + rewrite /lookup_env (prf _ H) in H0. cbn in H0. admit. + + set (eg := erase_global_decls _ _ _ _ _ _); + set (eg' := erase_global_decls _ _ _ _ _ _). + case_eq (KernameSet.mem k deps). + * cbn. intros hm. + destruct (eqb_spec k kn). + ++ subst k. admit. + ++ eapply IHdecls. tea. + rewrite /lookup_env Hd. + rewrite /lookup_env (prf _ H) in H0. cbn in H0. + admit. + KernameSetDecide.fsetdec. + * intros hnin. eapply IHdecls; tea. + rewrite /lookup_env Hd. + rewrite /lookup_env (prf _ H) in H0. cbn in H0. admit. + +Admitted. Lemma erase_global_declared_constructor X_type X ind c mind idecl cdecl deps decls normalization_in prf: forall Σ : global_env, abstract_env_rel X Σ -> declared_constructor Σ (ind, c) mind idecl cdecl -> KernameSet.In ind.(inductive_mind) deps -> - EGlobalEnv.declared_constructor (erase_global_decls X_type deps X decls normalization_in prf) (ind, c) + EGlobalEnv.declared_constructor (erase_global_decls X_type deps X decls normalization_in prf).1 (ind, c) (erase_mutual_inductive_body mind) (erase_one_inductive_body idecl) (EAst.mkConstructor cdecl.(cstr_name) cdecl.(cstr_arity)). Proof. intros Σ wfΣ [[]] Hin. pose (abstract_env_wf _ wfΣ). sq. cbn in *. split. split. - unshelve eapply declared_minductive_to_gen in H; eauto. - red in H |- *. eapply lookup_env_erase; eauto. + red in H |- *. eapply (lookup_env_erase_decl _ _ _ _ _ _ _ (InductiveDecl mind)); eauto. + eapply in_deps_in_erase_global_decls; tea. - cbn. now eapply map_nth_error. - cbn. erewrite map_nth_error; eauto. @@ -1855,7 +2235,7 @@ Import EGlobalEnv. Lemma erase_global_decls_fresh X_type kn deps X decls normalization_in heq : let Σ' := erase_global_decls X_type deps X decls normalization_in heq in PCUICAst.fresh_global kn decls -> - fresh_global kn Σ'. + fresh_global kn Σ'.1. Proof. cbn. revert deps X normalization_in heq. @@ -1942,7 +2322,7 @@ Lemma erases_deps_erase (cf := config.extraction_checker_flags) let et := erase X_type X' Γ t wt in let deps := EAstUtils.term_global_deps et in forall Σ, (abstract_env_rel X Σ) -> - erases_deps Σ (erase_global_decls X_type deps X decls normalization_in prf) et. + erases_deps Σ (erase_global_decls X_type deps X decls normalization_in prf).1 et. Proof. intros et deps Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. @@ -1972,7 +2352,7 @@ Lemma erases_deps_erase_weaken (cf := config.extraction_checker_flags) let et := erase X_type X' Γ t wt in let tdeps := EAstUtils.term_global_deps et in forall Σ, (abstract_env_rel X Σ) -> - erases_deps Σ (erase_global_decls X_type (KernameSet.union deps tdeps) X decls normalization_in prf) et. + erases_deps Σ (erase_global_decls X_type (KernameSet.union deps tdeps) X decls normalization_in prf).1 et. Proof. intros et tdeps Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. @@ -2010,13 +2390,14 @@ Qed. Lemma erase_global_closed X_type X deps decls {normalization_in} prf : let X' := erase_global_decls X_type deps X decls normalization_in prf in - EGlobalEnv.closed_env X'. + EGlobalEnv.closed_env X'.1. Proof. revert X normalization_in prf deps. induction decls; [cbn; auto|]. intros X normalization_in prf deps. destruct a as [kn d]. destruct d as []; simpl; destruct KernameSet.mem; + unfold erase_constant_decl; set (Xpop := abstract_pop_decls X); try (set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); assert (normalization_in_Xmake : forall Σ : global_env_ext, wf_ext Σ -> Σ ∼_ext Xmake -> NormalizationIn Σ) @@ -2025,6 +2406,7 @@ Proof. rewrite [forallb _ _](IHdecls) // andb_true_r. rewrite /test_snd /EGlobalEnv.closed_decl /=. destruct c as [ty [] univs]; cbn. + unfold erase_constant_decl. set (obl := erase_constant_body_obligation_1 _ _ _ _ _). unfold erase_constant_body. cbn. clearbody obl. cbn in obl. 2:auto. @@ -2037,7 +2419,6 @@ Proof. now eapply PCUICClosedTyp.subject_closed in X0. + eapply IHdecls => //. + cbn [EGlobalEnv.closed_env forallb]. - rewrite {1}/test_snd {1}/EGlobalEnv.closed_decl /=. eapply IHdecls => //. + eapply IHdecls => //. Unshelve. eauto. @@ -2122,7 +2503,7 @@ Lemma erase_wellformed (efl := all_env_flags) {X_type X} decls {normalization_in (X' := abstract_make_wf_env_ext X univs wfΣ) {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} (t' := erase X_type X' Γ t wt) : -wellformed (erase_global_decls X_type (term_global_deps t') X decls normalization_in prf) #|Γ| t'. +wellformed (erase_global_decls X_type (term_global_deps t') X decls normalization_in prf).1 #|Γ| t'. Proof. cbn. epose proof (@erases_deps_erase X_type X univs wfΣ decls normalization_in prf _ Γ t wt). @@ -2144,7 +2525,7 @@ Lemma erase_wellformed_weaken (efl := all_env_flags) {X_type X} decls {normaliza {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} deps: let t' := erase X_type X' Γ t wt in - wellformed (erase_global_decls X_type (KernameSet.union deps (term_global_deps t')) X decls normalization_in prf) #|Γ| t'. + wellformed (erase_global_decls X_type (KernameSet.union deps (term_global_deps t')) X decls normalization_in prf).1 #|Γ| t'. Proof. set (t' := erase _ _ _ _ _). cbn. epose proof (@erases_deps_erase_weaken _ X univs wfΣ decls _ prf _ Γ t wt deps). @@ -2170,7 +2551,7 @@ Lemma erase_constant_body_correct'' {X_type X} {cb} {decls normalization_in prf} forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * - wellformed (efl:=all_env_flags) (erase_global_decls X_type (KernameSet.union deps (term_global_deps body)) X decls normalization_in prf) 0 body ∥. + wellformed (efl:=all_env_flags) (erase_global_decls X_type (KernameSet.union deps (term_global_deps body)) X decls normalization_in prf).1 0 body ∥. Proof. intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. destruct cb as [name [bod|] udecl]; simpl. @@ -2197,7 +2578,7 @@ Lemma erase_global_cst_decl_wf_glob X_type X deps decls normalization_in heq : forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, let ecb := erase_constant_body X_type X' cb hcb in let Σ' := erase_global_decls X_type (KernameSet.union deps ecb.2) X decls normalization_in heq in - (@wf_global_decl all_env_flags Σ' (EAst.ConstantDecl ecb.1) : Prop). + (@wf_global_decl all_env_flags Σ'.1 (EAst.ConstantDecl ecb.1) : Prop). Proof. intros cb wfΣ hcb X' normalization_in' ecb Σ'. unfold wf_global_decl. cbn. @@ -2213,7 +2594,7 @@ Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls normalization_in kn m (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> let m' := erase_mutual_inductive_body m in let Σ' := erase_global_decls X_type deps X decls normalization_in heq in - @wf_global_decl all_env_flags Σ' (EAst.InductiveDecl m'). + @wf_global_decl all_env_flags Σ'.1 (EAst.InductiveDecl m'). Proof. set (m' := erase_mutual_inductive_body m). set (Σ' := erase_global_decls _ _ _ _ _ _). simpl. @@ -2228,7 +2609,7 @@ Qed. Lemma erase_global_decls_wf_glob X_type X deps decls normalization_in heq : let Σ' := erase_global_decls X_type deps X decls normalization_in heq in - @wf_glob all_env_flags Σ'. + @wf_glob all_env_flags Σ'.1. Proof. cbn. pose proof (abstract_env_exists X) as [[Σ wf]]. @@ -2261,7 +2642,7 @@ Qed. Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {deps deps' decls normalization_in prf} : KernameSet.Subset deps deps' -> - EExtends.global_subset (erase_global_decls X_type deps X decls normalization_in prf) (erase_global_decls X_type deps' X decls normalization_in prf). + EExtends.global_subset (erase_global_decls X_type deps X decls normalization_in prf).1 (erase_global_decls X_type deps' X decls normalization_in prf).1. Proof. revert deps deps' X normalization_in prf. induction decls. cbn => //. @@ -2322,8 +2703,8 @@ Qed. Lemma expanded_weakening_global X_type X deps deps' decls normalization_in prf Γ t : KernameSet.Subset deps deps' -> - expanded (erase_global_decls X_type deps X decls normalization_in prf) Γ t -> - expanded (erase_global_decls X_type deps' X decls normalization_in prf) Γ t. + expanded (erase_global_decls X_type deps X decls normalization_in prf).1 Γ t -> + expanded (erase_global_decls X_type deps' X decls normalization_in prf).1 Γ t. Proof. intros hs. eapply expanded_ind; intros; try solve [econstructor; eauto]. @@ -2342,7 +2723,7 @@ Lemma expanded_erase (cf := config.extraction_checker_flags) forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, let et := (erase X_type X' [] t wtp) in let deps := EAstUtils.term_global_deps et in - expanded (erase_global_decls X_type deps X decls normalization_in prf) [] et. + expanded (erase_global_decls X_type deps X decls normalization_in prf).1 [] et. Proof. intros Σ wf hexp X' normalization_in'. pose proof (abstract_env_wf _ wf) as [wf']. @@ -2358,7 +2739,7 @@ Lemma expanded_erase_global (cf := config.extraction_checker_flags) deps {X_type X decls normalization_in prf} : forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded_global_env Σ -> - expanded_global_env (erase_global_decls X_type deps X decls normalization_in prf). + expanded_global_env (erase_global_decls X_type deps X decls normalization_in prf).1. Proof. intros Σ wf etaΣ. pose proof (prf _ wf). destruct Σ as [univ decls']. @@ -2373,6 +2754,7 @@ Proof. destruct (KernameSet.mem kn deps) eqn:eqkn; simpl; rewrite eqkn. constructor; [eapply IHetaΣ; auto|]. red. cbn. red. cbn in *. + unfold erase_constant_decl. set (deps' := KernameSet.union _ _). hidebody deps'. set (wfext := abstract_make_wf_env_ext _ _ _). hidebody wfext. destruct H. @@ -2412,11 +2794,11 @@ Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> (forall Σ : global_env, abstract_env_rel X Σ -> PCUICWcbvEval.eval Σ t v) -> - @Ee.eval Ee.default_wcbv_flags Σ' t' E.tBox -> ∥ isErasable Σext [] t ∥. + @Ee.eval Ee.default_wcbv_flags Σ'.1 t' E.tBox -> ∥ isErasable Σext [] t ∥. Proof. intros wt. intros. - destruct (erase_correct X_type X univs wfext _ _ Σ' _ _ decls prf wt H H0 H1 X0 _ H2) as [ev [eg [eg']]]. + destruct (erase_correct X_type X univs wfext _ _ Σ'.1 _ _ decls prf wt H H0 H1 X0 _ H2) as [ev [eg [eg']]]. pose proof (Ee.eval_deterministic H3 eg'). subst. pose proof (abstract_env_exists X) as [[? wf]]. destruct (wfext _ wf). destruct (wt _ H2) as [T wt']. @@ -2438,7 +2820,7 @@ Lemma erase_eval_to_box_eager (wfl := Ee.default_wcbv_flags) forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> (forall Σ : global_env, abstract_env_rel X Σ -> PCUICWcbvEval.eval Σ t v) -> - @Ee.eval Ee.default_wcbv_flags Σ' t' E.tBox -> t' = E.tBox. + @Ee.eval Ee.default_wcbv_flags Σ'.1 t' E.tBox -> t' = E.tBox. Proof. intros wt. intros. @@ -2544,7 +2926,7 @@ forall Σ, abstract_env_ext_rel Xext Σ -> erase_global_decls X_type deps X decls normalization_in prf = Σ' -> red Σ [] t v -> ¬ { t' & Σ ;;; [] |- v ⇝ t'} -> - forall wt', ∥ Σ' ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. + forall wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. Proof. intros wt Σ Hrel Hax Hty Hfo <- Hsub <- Hred Hirred wt'. destruct (firstorder_lookup_inv Hfo) as [mind Hdecl]. @@ -2575,7 +2957,7 @@ forall Σ, abstract_env_ext_rel Xext Σ -> KernameSet.subset (term_global_deps t') deps -> red Σ [] t v -> ¬ { v' & Σ ;;; [] |- v ⇝ v'} -> - exists wt', ∥ Σ' ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. + exists wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. Proof. intros wt Σ Hrel Hax Hty Hdecl Hfo Hsub Hred Hirred. unshelve eexists. @@ -2617,7 +2999,7 @@ forall Σ (wfΣ : abstract_env_ext_rel Xext Σ) @firstorder_ind Σ (firstorder_env Σ) i -> red Σ [] t v -> ¬ { v' & Σ ;;; [] |- v ⇝ v'} -> - exists wt', ∥ Σ' ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. + exists wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. Proof. intros. eapply erase_correct_strong; eauto. @@ -2691,7 +3073,7 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) {normalization_in : NormalizationIn_erase_global_decls_fast X decls} (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations := match decls with - | [] => [] + | [] => ([],deps) | (kn, ConstantDecl cb) :: decls => if KernameSet.mem kn deps then let Xext' := abstract_make_wf_env_ext X (cst_universes cb) _ in @@ -2699,7 +3081,7 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) let cb' := @erase_constant_body X_type Xext' normalization_in' cb _ in let deps := KernameSet.union deps (snd cb') in let Σ' := erase_global_decls_fast deps X_type X decls _ in - ((kn, E.ConstantDecl (fst cb')) :: Σ') + (((kn, E.ConstantDecl (fst cb')) :: Σ'.1), Σ'.2) else erase_global_decls_fast deps X_type X decls _ @@ -2707,7 +3089,7 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) if KernameSet.mem kn deps then let mib' := erase_mutual_inductive_body mib in let Σ' := erase_global_decls_fast deps X_type X decls _ in - ((kn, E.InductiveDecl mib') :: Σ') + (((kn, E.InductiveDecl mib') :: Σ'.1), Σ'.2) else erase_global_decls_fast deps X_type X decls _ end. Next Obligation. @@ -2832,7 +3214,7 @@ Definition same_principal_type {cf} {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} {Γ : context} {t} (p : PCUICSafeRetyping.principal_type X_type X Γ t) (p' : PCUICSafeRetyping.principal_type X_type' X' Γ t) := p.π1 = p'.π1. - +(* Definition Hlookup {cf} (X_type : abstract_env_impl) (X : X_type.π2.π1) (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) := forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> @@ -2840,7 +3222,38 @@ Definition Hlookup {cf} (X_type : abstract_env_impl) (X : X_type.π2.π1) forall kn decl decl', lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl' -> - abstract_env_lookup X kn = abstract_env_lookup X' kn. + abstract_env_lookup X kn = abstract_env_lookup X' kn. *) + + +(* When two environments agree on the intersection of their declarations *) +Definition equiv_env_inter Σ Σ' := + (forall kn decl decl', lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl' -> decl = decl') /\ + (forall tag : Primitive.prim_tag, primitive_constant Σ tag = primitive_constant Σ' tag). + +Lemma equiv_env_inter_sym Σ Σ' : + equiv_env_inter Σ Σ' <-> equiv_env_inter Σ' Σ. +Proof. + unfold equiv_env_inter. + intuition auto; symmetry; eauto. +Qed. + +(* When two environments agree on the intersection of their declarations *) +Lemma equiv_env_inter_hlookup {cf:checker_flags} (X_type : abstract_env_impl) (X : X_type.π2.π1) + (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) : + (forall Σ Σ', Σ ∼_ext X -> Σ' ∼_ext X' -> equiv_env_inter Σ Σ') -> Hlookup X_type X X_type' X'. +Proof. + intros hl Σ HX Σ' HX'. + specialize (hl _ _ HX HX') as [hl hr]. + split. + - intros kn decl decl'. + specialize (hl kn decl decl'). + rewrite <-(abstract_env_lookup_correct' _ _ HX). + rewrite <-(abstract_env_lookup_correct' _ _ HX'). + intros Hl Hl'. + rewrite Hl Hl'. f_equal. eauto. + - intros tag; rewrite (abstract_primitive_constant_correct _ _ _ HX) (abstract_primitive_constant_correct _ _ _ HX'). + apply hr. +Qed. (*Lemma erase_global_deps_suffix {deps} {Σ Σ' : wf_env} {decls hprefix hprefix'} : wf Σ -> wf Σ' -> @@ -2883,14 +3296,42 @@ Proof using Type. { clear -equ hprefix'. move: hprefix'. intros [? ?]. split => //. eexists (x ++ [(kn, ConstantDecl c)]). cbn. now rewrite -app_assoc. } - rewrite (erase_constant_body_suffix (Σ := wfΣx) (Σ' := wfΣdw) (ondecl' := ond') wfΣ extd') //. - rewrite (erase_constant_body_suffix (Σ := wfΣ'x) (Σ' := wfΣdw) (ondecl' := ond') wfΣ' extd'') //. } + rewrite (erase_constant_suffix (Σ := wfΣx) (Σ' := wfΣdw) (ondecl' := ond') wfΣ extd') //. + rewrite (erase_constant_body_irrel (Σ := wfΣ'x) (Σ' := wfΣdw) (ondecl' := ond') wfΣ' extd'') //. } destruct KernameSet.mem => //. f_equal. eapply IHdecls. destruct KernameSet.mem => //. f_equal. eapply IHdecls. Qed.*) +Lemma strictly_extends_decls_extends_global_env Σ Σ' : + wf Σ' -> + strictly_extends_decls Σ Σ' -> + extends_global_env Σ Σ'. +Proof. + intros wfΣ' [uni [Σ'' de] retr]. red. + cbn. unfold lookup_env. rewrite de /primitive_constant retr. + split => //. intros kn decl. + intros hl. + apply lookup_global_Some_iff_In_NoDup. + apply EnvMap.EnvMap.fresh_globals_iff_NoDup. + rewrite -de. now apply wf_fresh_globals. + apply lookup_global_Some_iff_In_NoDup in hl. + apply in_app_iff. now right. + apply EnvMap.EnvMap.fresh_globals_iff_NoDup. + apply wf_fresh_globals in wfΣ'. rewrite de in wfΣ'. + clear -wfΣ'. induction Σ''; auto. apply IHΣ''. + now depelim wfΣ'. +Qed. + +Lemma extends_global_env_equiv_env Σ Σ' : + extends_global_env Σ Σ' -> equiv_env_inter Σ Σ'. +Proof. + intros ext. split. intros kn decl decl' hl hl'. + destruct ext. apply H in hl. congruence. + now destruct ext. +Qed. + Lemma erase_global_deps_fast_spec_gen {deps} {X_type X X'} {decls normalization_in normalization_in' hprefix hprefix'} : (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> @@ -2907,7 +3348,7 @@ Proof using Type. { now eexists. } destruct a as [kn []]. - - cbn. + - cbn. unfold erase_constant_decl. set (obl := (erase_global_decls_fast_obligation_1 X_type X ((kn, ConstantDecl c) :: decls) _ hprefix kn c decls eq_refl)). set (eb := erase_constant_body _ _ _ _). @@ -2915,16 +3356,20 @@ Proof using Type. assert (eb = eb') as <-. { subst eb eb'. destruct (hprefix _ wfΣ) as [[Σ'' eq]]. - eapply erase_constant_body_suffix; cbn => //. - intros. + eapply erase_constant_body_irrel; cbn => //. + eapply equiv_env_inter_hlookup. + intros ? ? H2 H3. epose proof (abstract_make_wf_env_ext_correct X (cst_universes c) _ _ _ wfΣ H2). epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wfpop H3). - subst. split => //. - sq. apply strictly_extends_decls_extends_decls. red. cbn. - rewrite eq. rewrite <- H0, <- H1. split. symmetry. apply equ; eauto. - eexists (Σ'' ++ [(kn, ConstantDecl c)]). subst. now rewrite -app_assoc. subst. - symmetry. now apply equ. - } + subst. eapply equiv_env_inter_sym. + eapply extends_global_env_equiv_env. + pose proof (abstract_env_wf _ wfΣ) as []. + apply strictly_extends_decls_extends_global_env. + apply X0. red. + rewrite eq. rewrite <- H0, <- H1. split. cbn. symmetry; apply equ; eauto. + cbn. + eexists (Σ'' ++ [(kn, ConstantDecl c)]). cbn. subst. now rewrite -app_assoc. subst. + symmetry. now apply equ. } destruct KernameSet.mem => //; f_equal; eapply IHdecls. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. diff --git a/erasure/theories/Typed/ErasureCorrectness.v b/erasure/theories/Typed/ErasureCorrectness.v index 2d3079eee..70272cbf9 100644 --- a/erasure/theories/Typed/ErasureCorrectness.v +++ b/erasure/theories/Typed/ErasureCorrectness.v @@ -167,11 +167,12 @@ Proof. destruct decl; [left|right]. all: unfold declared_constant, declared_minductive, P.declared_constant, P.declared_minductive; cbn. + unfold Erasure.erase_constant_decl. all: unfold eq_kername in *. all: try rewrite eq_kername_refl. + eexists; split; [left;reflexivity|]. - unfold erase_constant_decl. - destruct flag_of_type; cbn in *. + unfold erase_constant_decl. + destruct flag_of_type; cbn in *. destruct conv_ar; cbn in *. destruct wfΣprev as [wfΣprev]. * destruct c eqn:Hc; cbn in *. diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v index e873a3d6e..2895858f6 100644 --- a/template-coq/theories/TemplateProgram.v +++ b/template-coq/theories/TemplateProgram.v @@ -47,7 +47,7 @@ Definition make_template_program_env {cf : checker_flags} (p : template_program) (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) Program Definition build_template_program_env {cf : checker_flags} K : - Transform.t template_program template_program_env Ast.term Ast.term eval_template_program eval_template_program_env := + Transform.t template_program template_program_env Ast.term Ast.term eval_template_program eval_template_program_env := {| name := "rebuilding environment lookup table"; pre p := ∥ wt_template_program p ∥ /\ forall pf, K (GlobalEnvMap.make p.1 (wt_template_program_fresh p pf)) : Prop ; transform p pre := make_template_program_env p (proj1 pre); From 8710ece55c005349ab135dccec7c99ce306cf11f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 28 Aug 2023 10:02:22 +0200 Subject: [PATCH 41/65] No need for ext proof for erasure --- erasure-plugin/theories/ETransform.v | 73 ++++--- erasure/theories/ErasureFunction.v | 291 +++++++++++++-------------- 2 files changed, 188 insertions(+), 176 deletions(-) diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index ba2e8c17f..3dcc50ac2 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -148,7 +148,7 @@ Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_ (fun Σ wfΣ => let '(sq (T; ty)) := wt in PCUICTyping.iswelltyped ty) in let Σ' := ErasureFunction.erase_global_fast (normalization_in:=_) optimized_abstract_env_impl (EAstUtils.term_global_deps t) wfe (p.1.(PCUICAst.PCUICEnvironment.declarations)) _ in - (EEnvMap.GlobalContextMap.make Σ' _, t). + (EEnvMap.GlobalContextMap.make Σ'.1 _, t). Next Obligation. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. Qed. Next Obligation. @@ -280,28 +280,6 @@ Definition extends_pcuic_program (p p' : pcuic_program) := extends_global_env p.1 p'.1 /\ p.2 = p'.2. Import ErasureFunction. Import PCUICAst. -Lemma fresh_global_app kn Σ Σ' : fresh_global kn (Σ ++ Σ') -> - fresh_global kn Σ /\ fresh_global kn Σ'. -Proof. - induction Σ; cbn; intuition auto. - - constructor. - - depelim H. constructor => //. - now eapply Forall_app in H0. - - depelim H. - now eapply Forall_app in H0. -Qed. - -Lemma lookup_global_app_wf Σ Σ' kn : EnvMap.EnvMap.fresh_globals (Σ ++ Σ') -> - forall decl, lookup_global Σ' kn = Some decl -> lookup_global (Σ ++ Σ') kn = Some decl. -Proof. - induction Σ in kn |- *; cbn; auto. - intros fr; depelim fr. - intros decl hd; cbn. - destruct (eqb_spec kn kn0). - eapply PCUICWeakeningEnv.lookup_global_Some_fresh in hd. - subst. now eapply fresh_global_app in H as [H H']. - now eapply IHΣ. -Qed. Lemma strictly_extends_lookups {cf:checker_flags} (X X' : wf_env) (Σ Σ' : global_env) : (forall (kn : kername) (decl decl' : global_decl), lookup_env Σ' kn = Some decl -> lookup_env Σ kn = Some decl' -> decl = decl') -> @@ -327,6 +305,49 @@ Proof. - rewrite /primitive_constant. now rewrite e0 e2 hr. Qed. + +Lemma lookup_env_In_map_fst Σ kn decl : EGlobalEnv.lookup_env Σ kn = Some decl -> In kn (map fst Σ). +Proof. + induction Σ; cbn => //. + case: eqb_spec. + + intros -> [= <-]. now left. + + intros _ hl. eauto. +Qed. + +Lemma in_erase_global_decls_acc {X_type : abstract_env_impl} (X : X_type.π1) deps decls kn normalization_in prf : + In kn (map fst (erase_global_decls deps X decls (normalization_in:=normalization_in) prf).1) -> + KernameSet.In kn (erase_global_decls deps X decls (normalization_in:=normalization_in) prf).2. +Proof. + induction decls in X, prf, deps, normalization_in |- *. + cbn; auto. destruct a as [kn' []]. + + cbn. set (ec := erase_constant_decl _ _ _ _). + set (eg := erase_global_decls _ _ _ _). + set (eg' := erase_global_decls _ _ _ _). + case_eq (KernameSet.mem kn' deps). + * cbn; intros. destruct H0. subst; auto. + eapply KernameSet.mem_spec in H. + +Admitted. + (*auto. + specialize (IHdecls _ _ _ _ H0). + unfold ec in H0; cbn in H0. + set (Xpop := abstract_pop_decls X) in *. + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + epose proof (abstract_env_exists X) as [[ΣX HX]]. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ HX wfpop). + intros. rewrite prf => //. now eexists. + destruct H1 as [<- ?]. auto. + * intros hdeps hin. + eapply IHdecls in hin. intuition auto. + + cbn; set (eg := erase_global_decls _ _ _ _); + set (eg' := erase_global_decls _ _ _ _). + case_eq (KernameSet.mem kn' deps). + * cbn; intros. intuition auto. now specialize (IHdecls _ _ _ _ H1). + * intros hdeps hin. + eapply IHdecls in hin. intuition auto. + Unshelve. all:tc. +Qed. +*) #[global] Instance erase_transform_extends {guard : abstract_guard_impl} : TransformExt.t (erase_transform (guard := guard)) extends_pcuic_program extends_eprogram_env. @@ -360,14 +381,14 @@ Proof. unshelve epose proof (abstract_env_exists X). 3:tc. tc. destruct H4 as [[Σ' ΣX]]. unshelve epose proof (build_wf_env_from_env_eq _ (g, Σ.2) _ _ ΣX). cbn in H4. - epose proof (hl := ErasureFunction.lookup_env_erase_decl (optimized_abstract_env_impl) _ (EAstUtils.term_global_deps fst) _ _ _ kn g0 _ ΣX). + epose proof (hl := ErasureFunction.lookup_env_erase_decl (optimized_abstract_env_impl) _ (EAstUtils.term_global_deps fst) (declarations g) _ _ kn g0 _ ΣX). unfold lookup_env in E, hl. rewrite H4 in hl. specialize (hl (H0 _ _ E)). - forward hl. admit. destruct g0. - + destruct hl as [X' [nin [pf [eq ext]]]]. + + destruct hl as [X' [nin [pf [eq ext]]]]; revgoals. unshelve erewrite ErasureFunction.erase_global_deps_fast_spec. shelve. { intros. red in H5. cbn in H5. subst. reflexivity. } erewrite eq. + 2:{ eapply lookup_env_In_map_fst in H2. eapply in_erase_global_decls_acc in H2. } set (Xs := build_wf_env_from_env Σ.1 _) in *. unshelve epose proof (abstract_env_exists Xs). 3:tc. tc. destruct H5 as [[Σs Hs]]. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 10eceaf4b..5edab27a3 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -927,6 +927,71 @@ Next Obligation. clear H; specialize (oncb _ HX). destruct oncb as [[]]; sq; auto. Qed. +(* When two environments agree on the intersection of their declarations *) +Definition equiv_decls_inter Σ Σ' := + (forall kn decl decl', EGlobalEnv.lookup_env Σ kn = Some decl -> EGlobalEnv.lookup_env Σ' kn = Some decl' -> decl = decl'). + +Definition equiv_env_inter Σ Σ' := + (forall kn decl decl', lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl' -> decl = decl') /\ + (forall tag : Primitive.prim_tag, primitive_constant Σ tag = primitive_constant Σ' tag). + +Lemma equiv_env_inter_sym Σ Σ' : + equiv_env_inter Σ Σ' <-> equiv_env_inter Σ' Σ. +Proof. + unfold equiv_env_inter. + intuition auto; symmetry; eauto. +Qed. + +(* When two environments agree on the intersection of their declarations *) +Lemma equiv_env_inter_hlookup {cf:checker_flags} (X_type : abstract_env_impl) (X : X_type.π2.π1) + (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) : + (forall Σ Σ', Σ ∼_ext X -> Σ' ∼_ext X' -> equiv_env_inter Σ Σ') -> Hlookup X_type X X_type' X'. +Proof. + intros hl Σ HX Σ' HX'. + specialize (hl _ _ HX HX') as [hl hr]. + split. + - intros kn decl decl'. + specialize (hl kn decl decl'). + rewrite <-(abstract_env_lookup_correct' _ _ HX). + rewrite <-(abstract_env_lookup_correct' _ _ HX'). + intros Hl Hl'. + rewrite Hl Hl'. f_equal. eauto. + - intros tag; rewrite (abstract_primitive_constant_correct _ _ _ HX) (abstract_primitive_constant_correct _ _ _ HX'). + apply hr. +Qed. + + +Definition Hlookup_env {cf:checker_flags} (X_type : abstract_env_impl) (X : X_type.π1) (X_type' : abstract_env_impl) + (X' : X_type'.π1) := + forall Σ : global_env, abstract_env_rel X Σ -> + forall Σ' : global_env, abstract_env_rel X' Σ' -> + equiv_env_inter Σ Σ'. + +Lemma erase_constant_decl_irrel {X_type : abstract_env_impl} (X : X_type.π1) (cb : constant_body) normalization_in oncb + (X' : X_type.π1) normalization_in' oncb' : + Hlookup_env X_type X X_type X' -> + erase_constant_decl X cb normalization_in oncb = erase_constant_decl X' cb normalization_in' oncb'. +Proof. + unfold erase_constant_decl. + intros hl. + apply erase_constant_body_irrel. + pose proof (abstract_env_exists X) as [[env wf]]. + pose proof (abstract_env_exists X') as [[env' wf']]. + red. intros. + specialize (hl _ wf _ wf') as [hl hp]. + pose proof (abstract_make_wf_env_ext_correct X (cst_universes cb) _ _ _ wf H). + pose proof (abstract_make_wf_env_ext_correct X' (cst_universes cb) _ _ _ wf' H0). + split => //. + { intros. + rewrite -(abstract_env_lookup_correct' _ _ H). + rewrite -(abstract_env_lookup_correct' _ _ H0). rewrite H3 H4. subst Σ Σ'. + now specialize (hl _ _ _ H3 H4). } + intros. + { rewrite (abstract_primitive_constant_correct _ _ _ H). + rewrite (abstract_primitive_constant_correct _ _ _ H0). + now rewrite H1 H2. } +Qed. + Program Fixpoint erase_global_decls {X_type : abstract_env_impl} (deps : KernameSet.t) (X : X_type.π1) (decls : global_declarations) {normalization_in : NormalizationIn_erase_global_decls X decls} @@ -1972,7 +2037,7 @@ Proof. now eapply lookup_env_In_map_fst in hl. Qed. -Lemma in_erase_global_decls_acc X_type X deps decls kn normalization_in prf : +Lemma in_erase_global_decls_acc X_type X deps decls kn normalization_in prf : KernameSet.In kn (erase_global_decls X_type deps X decls normalization_in prf).2 -> KernameSet.In kn deps \/ In kn (map fst decls). Proof. @@ -2086,132 +2151,85 @@ Proof. intros []; split => //. destruct s as [Σ'' eq]. eexists ((kn', d') :: Σ''). now rewrite eq. Qed. -(* -Lemma lookup_env_erase_decl X_type X deps decls normalization_in prf kn decl : - forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some decl -> - if KernameSet.mem kn deps then - match decl with - | ConstantDecl cb => - exists (X' : X_type.π1) nin pf, - EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = - Some (EAst.ConstantDecl (fst (erase_constant_decl X' cb nin pf))) - | InductiveDecl mib => - EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = - Some (EAst.InductiveDecl (erase_mutual_inductive_body mib)) - end - else - EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = None. +Lemma fresh_global_app kn Σ Σ' : fresh_global kn (Σ ++ Σ') -> + fresh_global kn Σ /\ fresh_global kn Σ'. Proof. - intros Σ wfΣ. pose proof (prf _ wfΣ). - unfold lookup_env. rewrite H. clear H. - rewrite /lookup_env. - induction decls in X, Σ , wfΣ ,prf, deps, decl, normalization_in |- *. - - move=> /= //. - - destruct a as [kn' d']. - cbn -[erase_global_decls]. - case: (eqb_spec kn kn'); intros e'; subst. - intros [= ->]. - case_eq (KernameSet.mem kn' deps); move => hin'; cbn; rewrite hin'; cbn. - + destruct decl; cbn; rewrite eqb_refl //. - do 3 eexists. reflexivity. - + specialize (IHdecls (abstract_pop_decls X) deps). - destruct decl. - * match goal with - |- context [ erase_global_decls _ _ _ _ ?nin ?prf ] => specialize (IHdecls nin prf) - end. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - case_eq (lookup_global decls kn'). - intros g hg. - specialize (IHdecls g _ wfpop hg). now rewrite hin' in IHdecls. - epose proof (lookup_env_erase_decl_None X_type (abstract_pop_decls X) deps decls _ _ _ _ wfpop). - intros hl. eapply H. unfold lookup_env. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop). - intros. pose proof (prf _ H0). now eexists. - destruct H0. now rewrite H0. - * rewrite hin' in IHdecls. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - case_eq (lookup_global decls kn'). - intros g hg. - eapply IHdecls; tea. - epose proof (lookup_env_erase_decl_None X_type (abstract_pop_decls X) deps decls _ _ _ _ wfpop). - intros hl; eapply H. - unfold lookup_env. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop). - intros. pose proof (prf _ H0). now eexists. - destruct H0. now rewrite H0. - + intros hl. - epose proof (lookup_env_erase_global_diff X_type X deps decls kn kn' d' _ _ e'). - destruct H as [deps' [nin' [prf' [sub H]]]]. - erewrite H. - case_eq (KernameSet.mem kn deps) => //. - * move/KernameSet.mem_spec => hin. - assert (kndeps' : KernameSet.mem kn deps'). - { now apply KernameSet.mem_spec; eapply sub. } - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - specialize (IHdecls Xpop deps'). - epose proof (IHdecls _ _ decl _ wfpop hl) ; tea. rewrite kndeps' in H0. eapply H0. - * intros hin. rewrite hin in IHdecls. - + induction Σ; cbn; intuition auto. + - constructor. + - depelim H. constructor => //. + now eapply Forall_app in H0. + - depelim H. + now eapply Forall_app in H0. +Qed. - ** intros g hl. eapply IHdecls. - destruct KernameSet.mem. cbn. - rewrite (negbTE (proj2 (neqb _ _) e')). - eapply IHdecls => //; eauto. eapply KernameSet.union_spec. left => //. - eapply IHdecls => //; eauto. - simpl. +Lemma lookup_global_app_wf Σ Σ' kn : EnvMap.EnvMap.fresh_globals (Σ ++ Σ') -> + forall decl, lookup_global Σ' kn = Some decl -> lookup_global (Σ ++ Σ') kn = Some decl. +Proof. + induction Σ in kn |- *; cbn; auto. + intros fr; depelim fr. + intros decl hd; cbn. + destruct (eqb_spec kn kn0). + eapply PCUICWeakeningEnv.lookup_global_Some_fresh in hd. + subst. now eapply fresh_global_app in H as [H H']. + now eapply IHΣ. +Qed. - destruct KernameSet.mem. cbn. - rewrite (negbTE (proj2 (neqb _ _) e')). - eapply IHdecls => //; eauto. - eapply IHdecls => //; eauto. -Qed.*) +Lemma strictly_extends_decls_lookup {Σ Σ'} : + wf Σ' -> + strictly_extends_decls Σ Σ' -> + forall kn d, lookup_env Σ kn = Some d -> + lookup_env Σ' kn = Some d. +Proof. + intros. + destruct X0 as [? []]. + rewrite /lookup_env in H *. rewrite e0. + erewrite lookup_global_app_wf. reflexivity. 2:eauto. + eapply wf_fresh_globals in X. now rewrite -e0. +Qed. -Lemma in_deps_in_erase_global_decls X_type X deps decls normalization_in prf kn decl : - forall Σ, Σ ∼ X -> - lookup_env Σ kn = Some decl -> +Lemma in_deps_in_erase_global_decls X_type X deps decls normalization_in prf kn : KernameSet.In kn deps -> KernameSet.In kn (erase_global_decls X_type deps X decls normalization_in prf).2. Proof. induction decls in X, deps, normalization_in, prf |- *. - - intros. rewrite /lookup_env prf in H0 => //. + - intros. now cbn. - intros. cbn. + pose proof (abstract_env_exists X) as [[Σ H']]. set (Xpop := abstract_pop_decls X). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H wfpop). intros. rewrite prf => //. now eexists. - destruct H2 as [Hd [Hu Hr]]. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H' wfpop). intros. rewrite prf => //. now eexists. + destruct H0 as [Hd [Hu Hr]]. destruct a. destruct g. + set (eg := erase_global_decls _ _ _ _ _ _); set (eg' := erase_global_decls _ _ _ _ _ _). case_eq (KernameSet.mem k deps). * cbn. intros hm. destruct (eqb_spec k kn). - ++ subst k. admit. - ++ eapply IHdecls. tea. - rewrite /lookup_env Hd. - rewrite /lookup_env (prf _ H) in H0. cbn in H0. - admit. - KernameSetDecide.fsetdec. + ++ subst k. eapply IHdecls. KernameSetDecide.fsetdec. + ++ eapply IHdecls. + KernameSetDecide.fsetdec. * intros hnin. eapply IHdecls; tea. - rewrite /lookup_env Hd. - rewrite /lookup_env (prf _ H) in H0. cbn in H0. admit. + set (eg := erase_global_decls _ _ _ _ _ _); set (eg' := erase_global_decls _ _ _ _ _ _). case_eq (KernameSet.mem k deps). * cbn. intros hm. destruct (eqb_spec k kn). - ++ subst k. admit. + ++ subst k. eapply KernameSet.mem_spec in hm. + now eapply IHdecls. ++ eapply IHdecls. tea. - rewrite /lookup_env Hd. - rewrite /lookup_env (prf _ H) in H0. cbn in H0. - admit. - KernameSetDecide.fsetdec. * intros hnin. eapply IHdecls; tea. - rewrite /lookup_env Hd. - rewrite /lookup_env (prf _ H) in H0. cbn in H0. admit. +Qed. + +Lemma erase_global_decls_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X:X_type.π1) ext wfX {normalization_in} decls nin prf Γ t wt v wv : + let Xext := abstract_make_wf_env_ext X ext wfX in + let t' := erase X_type Xext (normalization_in := normalization_in) Γ t wt in + let v' := erase X_type Xext (normalization_in := normalization_in) Γ v wv in + let eg := erase_global_decls X_type (term_global_deps t') X decls nin prf in + let eg' := erase_global_decls X_type (term_global_deps v') X decls nin prf in + eg.1 ⊢ t' ⇓ v' -> KernameSet.Subset eg'.2 eg.2. +Proof. + intros. clearbody t' v'. Admitted. Lemma erase_global_declared_constructor X_type X ind c mind idecl cdecl deps decls normalization_in prf: @@ -2603,7 +2621,7 @@ Proof. pose proof (abstract_env_wf _ wf) as [wfΣ]. assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). { eapply (erases_mutual (mdecl:=kn)); tea. } - eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ')) in H; tea. + eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ'.1)) in H; tea. rewrite -(heq _ wf). now destruct Σ. Qed. @@ -2798,7 +2816,7 @@ Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) Proof. intros wt. intros. - destruct (erase_correct X_type X univs wfext _ _ Σ'.1 _ _ decls prf wt H H0 H1 X0 _ H2) as [ev [eg [eg']]]. + destruct (erase_correct X_type X univs wfext _ _ Σ' _ _ decls prf wt H H0 H1 X0 _ H2) as [ev [eg [eg']]]. pose proof (Ee.eval_deterministic H3 eg'). subst. pose proof (abstract_env_exists X) as [[? wf]]. destruct (wfext _ wf). destruct (wt _ H2) as [T wt']. @@ -3071,7 +3089,7 @@ Qed. Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) X_type (X:X_type.π1) (decls : global_declarations) {normalization_in : NormalizationIn_erase_global_decls_fast X decls} - (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations := + (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations * KernameSet.t := match decls with | [] => ([],deps) | (kn, ConstantDecl cb) :: decls => @@ -3214,46 +3232,6 @@ Definition same_principal_type {cf} {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} {Γ : context} {t} (p : PCUICSafeRetyping.principal_type X_type X Γ t) (p' : PCUICSafeRetyping.principal_type X_type' X' Γ t) := p.π1 = p'.π1. -(* -Definition Hlookup {cf} (X_type : abstract_env_impl) (X : X_type.π2.π1) - (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) := - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> - forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> - forall kn decl decl', - lookup_env Σ kn = Some decl -> - lookup_env Σ' kn = Some decl' -> - abstract_env_lookup X kn = abstract_env_lookup X' kn. *) - - -(* When two environments agree on the intersection of their declarations *) -Definition equiv_env_inter Σ Σ' := - (forall kn decl decl', lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl' -> decl = decl') /\ - (forall tag : Primitive.prim_tag, primitive_constant Σ tag = primitive_constant Σ' tag). - -Lemma equiv_env_inter_sym Σ Σ' : - equiv_env_inter Σ Σ' <-> equiv_env_inter Σ' Σ. -Proof. - unfold equiv_env_inter. - intuition auto; symmetry; eauto. -Qed. - -(* When two environments agree on the intersection of their declarations *) -Lemma equiv_env_inter_hlookup {cf:checker_flags} (X_type : abstract_env_impl) (X : X_type.π2.π1) - (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) : - (forall Σ Σ', Σ ∼_ext X -> Σ' ∼_ext X' -> equiv_env_inter Σ Σ') -> Hlookup X_type X X_type' X'. -Proof. - intros hl Σ HX Σ' HX'. - specialize (hl _ _ HX HX') as [hl hr]. - split. - - intros kn decl decl'. - specialize (hl kn decl decl'). - rewrite <-(abstract_env_lookup_correct' _ _ HX). - rewrite <-(abstract_env_lookup_correct' _ _ HX'). - intros Hl Hl'. - rewrite Hl Hl'. f_equal. eauto. - - intros tag; rewrite (abstract_primitive_constant_correct _ _ _ HX) (abstract_primitive_constant_correct _ _ _ HX'). - apply hr. -Qed. (*Lemma erase_global_deps_suffix {deps} {Σ Σ' : wf_env} {decls hprefix hprefix'} : wf Σ -> wf Σ' -> @@ -3353,6 +3331,9 @@ Proof using Type. _ hprefix kn c decls eq_refl)). set (eb := erase_constant_body _ _ _ _). set (eb' := erase_constant_body _ _ _ _). + set (eg := erase_global_decls _ _ _ _ _ _). + set (eg' := erase_global_decls _ _ _ _ _ _). + assert (eb = eb') as <-. { subst eb eb'. destruct (hprefix _ wfΣ) as [[Σ'' eq]]. @@ -3370,20 +3351,30 @@ Proof using Type. cbn. eexists (Σ'' ++ [(kn, ConstantDecl c)]). cbn. subst. now rewrite -app_assoc. subst. symmetry. now apply equ. } - destruct KernameSet.mem => //; f_equal; eapply IHdecls. + destruct KernameSet.mem => //; f_equal; try eapply IHdecls. + f_equal. f_equal. eapply IHdecls. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + f_equal. eapply IHdecls. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - cbn. - destruct KernameSet.mem => //; f_equal; eapply IHdecls. + destruct KernameSet.mem => //; f_equal; try eapply IHdecls. + f_equal; f_equal; eapply IHdecls. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros. + f_equal; eapply IHdecls. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros; unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } + intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. Qed. Lemma erase_global_deps_fast_spec {deps} {X_type X} {decls normalization_in normalization_in' hprefix hprefix'} : @@ -3401,7 +3392,7 @@ Lemma expanded_erase_global_fast (cf := config.extraction_checker_flags) deps {X_type X decls normalization_in} {normalization_in':NormalizationIn_erase_global_decls X decls} {prf} : forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded_global_env Σ -> - expanded_global_env (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf). + expanded_global_env (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. Proof using Type. unfold erase_global_fast. erewrite erase_global_deps_fast_spec. @@ -3417,7 +3408,7 @@ Lemma expanded_erase_fast (cf := config.extraction_checker_flags) forall (normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ), let et := (erase X_type X' [] t wtp) in let deps := EAstUtils.term_global_deps et in - expanded (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf) [] et. + expanded (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1 [] et. Proof using Type. intros Σ wf hexp X' normalization_in'. pose proof (abstract_env_wf _ wf) as [?]. eapply (expanded_erases (Σ := (Σ, univs))); tea. @@ -3430,7 +3421,7 @@ Proof using Type. Qed. Lemma erase_global_fast_wf_glob X_type deps X decls normalization_in (normalization_in':NormalizationIn_erase_global_decls X decls) prf : - @wf_glob all_env_flags (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf). + @wf_glob all_env_flags (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. Proof using Type. unfold erase_global_fast; erewrite erase_global_deps_fast_spec. eapply erase_global_decls_wf_glob. @@ -3442,7 +3433,7 @@ Lemma erase_wellformed_fast (efl := all_env_flags) (X' := abstract_make_wf_env_ext X univs wfΣ) {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} : let t' := erase X_type X' Γ t wt in - wellformed (erase_global_fast X_type (term_global_deps t') X decls (normalization_in:=normalization_in) prf) #|Γ| t'. + wellformed (erase_global_fast X_type (term_global_deps t') X decls (normalization_in:=normalization_in) prf).1 #|Γ| t'. Proof using Type. intros. cbn. unfold erase_global_fast. erewrite erase_global_deps_fast_spec. From 7158506c5564b3f57b6240c385136a94a3ede002 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 28 Aug 2023 10:47:26 +0200 Subject: [PATCH 42/65] Strenghtened program extension preservation --- erasure-plugin/theories/ETransform.v | 154 +++++------------------ erasure/theories/EConstructorsAsBlocks.v | 10 ++ erasure/theories/EGenericGlobalMap.v | 18 +++ erasure/theories/EImplementBox.v | 19 ++- erasure/theories/EInlineProjections.v | 11 +- erasure/theories/EOptimizePropDiscr.v | 10 ++ erasure/theories/ERemoveParams.v | 11 ++ 7 files changed, 101 insertions(+), 132 deletions(-) diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index 3dcc50ac2..acef38110 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -314,116 +314,6 @@ Proof. + intros _ hl. eauto. Qed. -Lemma in_erase_global_decls_acc {X_type : abstract_env_impl} (X : X_type.π1) deps decls kn normalization_in prf : - In kn (map fst (erase_global_decls deps X decls (normalization_in:=normalization_in) prf).1) -> - KernameSet.In kn (erase_global_decls deps X decls (normalization_in:=normalization_in) prf).2. -Proof. - induction decls in X, prf, deps, normalization_in |- *. - cbn; auto. destruct a as [kn' []]. - + cbn. set (ec := erase_constant_decl _ _ _ _). - set (eg := erase_global_decls _ _ _ _). - set (eg' := erase_global_decls _ _ _ _). - case_eq (KernameSet.mem kn' deps). - * cbn; intros. destruct H0. subst; auto. - eapply KernameSet.mem_spec in H. - -Admitted. - (*auto. - specialize (IHdecls _ _ _ _ H0). - unfold ec in H0; cbn in H0. - set (Xpop := abstract_pop_decls X) in *. - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - epose proof (abstract_env_exists X) as [[ΣX HX]]. - unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ HX wfpop). - intros. rewrite prf => //. now eexists. - destruct H1 as [<- ?]. auto. - * intros hdeps hin. - eapply IHdecls in hin. intuition auto. - + cbn; set (eg := erase_global_decls _ _ _ _); - set (eg' := erase_global_decls _ _ _ _). - case_eq (KernameSet.mem kn' deps). - * cbn; intros. intuition auto. now specialize (IHdecls _ _ _ _ H1). - * intros hdeps hin. - eapply IHdecls in hin. intuition auto. - Unshelve. all:tc. -Qed. -*) -#[global] -Instance erase_transform_extends {guard : abstract_guard_impl} : - TransformExt.t (erase_transform (guard := guard)) extends_pcuic_program extends_eprogram_env. -Proof. - red. intros p p' pr pr' [ext eq]. rewrite /transform /=. - destruct pr. - epose proof (erase_pcuic_program_normalization_helper p (map_squash fst s)). - destruct p as [Σ t]. destruct p' as [Σ' t']. - simpl in *. subst t'. red. split. - - destruct ext. red. - cbn. rewrite /ErasureFunction.erase_global_fast. - unshelve erewrite ErasureFunction.erase_global_deps_fast_spec. - { intros. intuition auto. eapply H11; tea. admit. admit. } - { intros. red in H4. cbn in H4. subst. reflexivity. } - destruct Σ'. cbn in *. subst u. - set (fst := ErasureFunction.erase _ _ _ _ _). - set (snd:= ErasureFunction.erase _ _ _ _ _). - assert (fst = snd). - { subst fst snd. symmetry. - eapply ErasureFunction.erase_irrel_global_env. - eapply ErasureFunction.equiv_env_inter_hlookup. - intros ? ? -> ->. cbn. - eapply ErasureFunction.equiv_env_inter_sym. - eapply ErasureFunction.extends_global_env_equiv_env. - cbn. split => //. - sq. unfold primitive_constant. now rewrite H3. } - clearbody fst snd. subst snd. - intros. - set (X := build_wf_env_from_env g _) in *. - destruct (lookup_env Σ kn) eqn:E. - unshelve epose proof (abstract_env_exists X). 3:tc. tc. - destruct H4 as [[Σ' ΣX]]. - unshelve epose proof (build_wf_env_from_env_eq _ (g, Σ.2) _ _ ΣX). cbn in H4. - epose proof (hl := ErasureFunction.lookup_env_erase_decl (optimized_abstract_env_impl) _ (EAstUtils.term_global_deps fst) (declarations g) _ _ kn g0 _ ΣX). - unfold lookup_env in E, hl. rewrite H4 in hl. specialize (hl (H0 _ _ E)). - destruct g0. - + destruct hl as [X' [nin [pf [eq ext]]]]; revgoals. - unshelve erewrite ErasureFunction.erase_global_deps_fast_spec. shelve. - { intros. red in H5. cbn in H5. subst. reflexivity. } - erewrite eq. - 2:{ eapply lookup_env_In_map_fst in H2. eapply in_erase_global_decls_acc in H2. } - set (Xs := build_wf_env_from_env Σ.1 _) in *. - unshelve epose proof (abstract_env_exists Xs). 3:tc. tc. - destruct H5 as [[Σs Hs]]. - epose proof (hl' := ErasureFunction.lookup_env_erase_decl (optimized_abstract_env_impl) _ (EAstUtils.term_global_deps fst) _ _ _ kn _ _ Hs). - unshelve epose proof (build_wf_env_from_env_eq _ _ _ _ Hs). rewrite /lookup_env H5 in hl'. specialize (hl' E). - forward hl'. admit. cbn in hl'. - destruct hl' as [X'' [nin' [pf' [eq' ext']]]]. - erewrite eq' in H2. rewrite -H2. f_equal. f_equal. - f_equal. unfold erase_constant_decl. - eapply erase_constant_body_irrel. - eapply ErasureFunction.equiv_env_inter_hlookup. cbn. - intros ? ? H6 H7. - cbn in ext. specialize (ext _ _ eq_refl eq_refl) as [ext]. - specialize (ext' _ _ eq_refl eq_refl) as [ext']. - cbn in H6, H7. subst Σ0 Σ'0. cbn. split => //. - { intros kn' decl'. rewrite /lookup_env. - destruct (map_squash Datatypes.fst s). - destruct pr' as [pr' ?]. - destruct (map_squash Datatypes.fst pr'). - eapply strictly_extends_lookups. 2-3:tea. - intros kn'' ? ? hg hΣ. eapply H0 in hΣ. congruence. auto. - apply X0. apply X1. } - { rewrite /primitive_constant. - destruct ext as [_ _ ->]. - destruct ext' as [_ _ ->]. - now rewrite H3. } - + - - symmetry. - eapply ErasureFunction.erase_irrel_global_env. - intros Σg Σg' eq eq'. - destruct ext as [hl hu hr]. - destruct Σ as [m univs]. destruct Σ' as [m' univs']. simpl in *. - subst. cbn. destruct m, m'. cbn in *. split => //. sq. red. split => //. - unfold primitive_constant. now rewrite H. -Qed. End PCUICEnv. Obligation Tactic := idtac. @@ -455,7 +345,7 @@ Qed. #[global] Instance guarded_to_unguarded_fix_extends {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) : - TransformExt.t (guarded_to_unguarded_fix (wcon:=wcon) wguard) extends_eprogram_env term snd. + TransformExt.t (guarded_to_unguarded_fix (wcon:=wcon) wguard) extends_eprogram_env extends_eprogram_env. Proof. red. intros p p' pr pr' [ext eq]. now rewrite /transform /=. Qed. @@ -479,7 +369,7 @@ Qed. #[global] Instance rebuild_wf_env_extends {fl : EWcbvEval.WcbvFlags} {efl : EEnvFlags} with_exp : - TransformExt.t (rebuild_wf_env_transform with_exp) extends_eprogram term snd. + TransformExt.t (rebuild_wf_env_transform with_exp) extends_eprogram extends_eprogram_env. Proof. red. intros p p' pr pr' [ext eq]. now rewrite /transform /=. Qed. @@ -513,9 +403,10 @@ Qed. #[global] Instance remove_params_extends {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags): - TransformExt.t (remove_params_optimization (wcon:=wcon)) extends_eprogram_env term snd. + TransformExt.t (remove_params_optimization (wcon:=wcon)) extends_eprogram_env extends_eprogram. Proof. - red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite eq. + red. intros p p' pr pr' [ext eq]. rewrite /transform /= /strip_program. rewrite eq. + red. cbn -[strip_env strip]. split. eapply strip_extends_env => //. apply pr. apply pr'. eapply strip_extends => //. apply pr'. rewrite -eq. apply pr. Qed. @@ -552,10 +443,11 @@ Qed. #[global] Instance remove_params_fast_extends {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags): - TransformExt.t (remove_params_fast_optimization (wcon:=wcon)) extends_eprogram_env term snd. + TransformExt.t (remove_params_fast_optimization (wcon:=wcon)) extends_eprogram_env extends_eprogram. Proof. red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite eq. - rewrite -!ERemoveParams.Fast.strip_fast. + rewrite -!ERemoveParams.Fast.strip_fast -!ERemoveParams.Fast.strip_env_fast. + split => /=. eapply strip_extends_env => //. apply pr. apply pr'. eapply strip_extends => //. apply pr'. rewrite -eq. apply pr. Qed. @@ -586,9 +478,11 @@ Qed. #[global] Instance remove_match_on_box_extends {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : - TransformExt.t (remove_match_on_box_trans (wcon:=wcon) (hastrel := hastrel) (hastbox := hastbox)) extends_eprogram_env term snd. + TransformExt.t (remove_match_on_box_trans (wcon:=wcon) (hastrel := hastrel) (hastbox := hastbox)) extends_eprogram_env extends_eprogram. Proof. - red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite -eq. + red. intros p p' pr pr' [ext eq]. rewrite /transform /= /remove_match_on_box_program; split => /=. + eapply remove_match_on_box_extends_env => //. apply pr. apply pr'. + rewrite -eq. eapply wellformed_remove_match_on_box_extends; eauto. apply pr. apply pr'. Qed. @@ -619,9 +513,12 @@ Qed. #[global] Instance inline_projections_optimization_extends {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) {hastrel : has_tRel} {hastbox : has_tBox} : - TransformExt.t (inline_projections_optimization (wcon:=wcon) (hastrel := hastrel) (hastbox := hastbox)) extends_eprogram_env term snd. + TransformExt.t (inline_projections_optimization (wcon:=wcon) (hastrel := hastrel) (hastbox := hastbox)) extends_eprogram_env extends_eprogram. Proof. - red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite -eq. + red. intros p p' pr pr' [ext eq]. rewrite /transform /= /optimize_program /=. + split => /=. + eapply optimize_extends_env => //. apply pr. apply pr'. + rewrite -eq. eapply wellformed_optimize_extends; eauto. apply pr. apply pr'. Qed. @@ -655,9 +552,13 @@ Qed. #[global] Instance constructors_as_blocks_extends (efl : EEnvFlags) {has_app : has_tApp} {has_rel : has_tRel} {hasbox : has_tBox} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : - TransformExt.t (constructors_as_blocks_transformation (has_app := has_app) (has_rel := has_rel) (hasbox := hasbox) (has_pars := has_pars) (has_cstrblocks := has_cstrblocks)) extends_eprogram_env term snd. + TransformExt.t (constructors_as_blocks_transformation (has_app := has_app) (has_rel := has_rel) (hasbox := hasbox) (has_pars := has_pars) (has_cstrblocks := has_cstrblocks)) + extends_eprogram_env extends_eprogram. Proof. - red. intros p p' pr pr' [ext eq]. rewrite /transform /=. rewrite -eq. + red. intros p p' pr pr' [ext eq]. rewrite /transform /=. + split => //. eapply transform_blocks_env_extends => //. apply pr. apply pr'. + unfold transform_blocks_program => /=. + rewrite -eq. eapply transform_blocks_extends; eauto. apply pr. apply pr'. Qed. @@ -674,7 +575,7 @@ Program Definition implement_box_transformation {efl : EEnvFlags} Next Obligation. intros. cbn in *. destruct p. split. - - eapply transform_wf_global; eauto. + - eapply implement_box_env_wf_glob; eauto. - now eapply transform_wellformed'. Qed. Next Obligation. @@ -686,7 +587,10 @@ Qed. #[global] Instance implement_box_extends (efl : EEnvFlags) {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = true} : - TransformExt.t (implement_box_transformation (has_app := has_app) (has_pars := has_pars) (has_cstrblocks := has_cstrblocks)) extends_eprogram term snd. + TransformExt.t (implement_box_transformation (has_app := has_app) (has_pars := has_pars) (has_cstrblocks := has_cstrblocks)) extends_eprogram extends_eprogram. Proof. - red. intros p p' pr pr' [ext eq]. rewrite /transform /=. now rewrite -eq. + red. intros p p' pr pr' [ext eq]. rewrite /transform /= /implement_box_program /=. + split => /=. + eapply (implement_box_env_extends has_app ext). apply pr. apply pr'. + now rewrite -eq. Qed. diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v index a8cd21c0a..1fc9a4ab7 100644 --- a/erasure/theories/EConstructorsAsBlocks.v +++ b/erasure/theories/EConstructorsAsBlocks.v @@ -857,6 +857,16 @@ Proof. eapply transform_wellformed => //. Defined. +Lemma transform_blocks_env_extends {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : + has_tApp -> + extends Σ Σ' -> + wf_glob Σ -> + wf_glob Σ' -> + extends (transform_blocks_env Σ) (transform_blocks_env Σ'). +Proof. + intros hast ext wf. + now apply (gen_transform_extends (gt := GTExt efl hast) ext). +Qed. Lemma Pre_glob efl Σ wf : has_cstr_params = false -> diff --git a/erasure/theories/EGenericGlobalMap.v b/erasure/theories/EGenericGlobalMap.v index 4fde99a95..797eedcf3 100644 --- a/erasure/theories/EGenericGlobalMap.v +++ b/erasure/theories/EGenericGlobalMap.v @@ -289,6 +289,24 @@ Proof. now apply extends_cons_wf. now depelim wf. Qed. +Lemma gen_transform_extends {Σ Σ' : GlobalContextMap.t} : + extends Σ Σ' -> + @wf_glob efl Σ -> + @wf_glob efl Σ' -> + extends (gen_transform_env Σ) (gen_transform_env Σ'). +Proof. + intros ext. + unfold gen_transform_env. + intros wf wf'. + rewrite (gen_transform_env_extends' ext wf wf'). + intros kn d. specialize (ext kn). + rewrite lookup_env_map_snd. + destruct (lookup_env) eqn:E; cbn => //. + intros [= <-]. + specialize (ext _ eq_refl). + now rewrite lookup_env_map_snd ext /=. +Qed. + Import EWellformed. Lemma gen_transform_wellformed_irrel {genid : GenTransformId gen_transform} {Σ : GlobalContextMap.t} t : diff --git a/erasure/theories/EImplementBox.v b/erasure/theories/EImplementBox.v index e843cd6ba..b322d74d8 100644 --- a/erasure/theories/EImplementBox.v +++ b/erasure/theories/EImplementBox.v @@ -411,7 +411,7 @@ Proof. induction 1; cbn; constructor; auto. Qed. -Lemma transform_wf_global {efl : EEnvFlags} {Σ : global_declarations} : +Lemma implement_box_env_wf_glob {efl : EEnvFlags} {Σ : global_declarations} : has_tApp -> wf_glob (efl := efl) Σ -> wf_glob (efl := switch_off_box efl) (implement_box_env Σ). Proof. @@ -428,6 +428,23 @@ Proof. eapply EExtends.extends_wf_glob in wfg; tea. now depelim wfg. Qed. +From MetaCoq.Erasure Require Import EGenericGlobalMap. + +Lemma implement_box_env_extends {efl : EEnvFlags} {Σ Σ' : global_declarations} : + has_tApp -> + extends Σ Σ' -> + wf_glob Σ -> + wf_glob Σ' -> + extends (implement_box_env Σ) (implement_box_env Σ'). +Proof. + intros hast ext wf wf'. + intros kn d. + rewrite !lookup_env_map_snd. + specialize (ext kn). destruct (lookup_env) eqn:E => //=. + intros [= <-]. + rewrite (ext g) => //. +Qed. + Transparent implement_box. Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t). diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v index 8f65984c3..7d760e3b2 100644 --- a/erasure/theories/EInlineProjections.v +++ b/erasure/theories/EInlineProjections.v @@ -841,16 +841,15 @@ Proof. now apply optimize_wellformed. Defined. -Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : +Lemma optimize_extends_env {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : + has_tApp -> extends Σ Σ' -> wf_glob Σ -> wf_glob Σ' -> - List.map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls) = - List.map (on_snd (optimize_decl Σ')) Σ.(GlobalContextMap.global_decls). + extends (optimize_env Σ) (optimize_env Σ'). Proof. - intros. - epose proof (gen_transform_env_extends' (gt := GTExt efl)). - now eapply H2. + intros hast ext wf. + now apply (gen_transform_extends (gt := GTExt efl) ext). Qed. Lemma optimize_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> optimize_env Σ = optimize_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index af091df81..4e50ee4ca 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -879,6 +879,16 @@ Proof. eapply (gen_transform_env_extends' (gt := GTExt efl)) => //. Qed. +Lemma remove_match_on_box_extends_env {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : + extends Σ Σ' -> + wf_glob Σ -> + wf_glob Σ' -> + extends (remove_match_on_box_env Σ) (remove_match_on_box_env Σ'). +Proof. + intros ext wf. + now apply (gen_transform_extends (gt := GTExt efl) ext). +Qed. + Lemma remove_match_on_box_env_eq {efl : EEnvFlags} (Σ : GlobalContextMap.t) : wf_glob Σ -> remove_match_on_box_env Σ = remove_match_on_box_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v index bc5a6b529..4d6937bf0 100644 --- a/erasure/theories/ERemoveParams.v +++ b/erasure/theories/ERemoveParams.v @@ -1247,6 +1247,17 @@ Proof. now apply (gen_transform_env_extends' (gt := GTExt efl hast) ext). Qed. +Lemma strip_extends_env {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : + has_tApp -> + extends Σ Σ' -> + wf_glob Σ -> + wf_glob Σ' -> + extends (strip_env Σ) (strip_env Σ'). +Proof. + intros hast ext wf. + now apply (gen_transform_extends (gt := GTExt efl hast) ext). +Qed. + Lemma strip_env_eq (efl := all_env_flags) (Σ : GlobalContextMap.t) : wf_glob Σ -> strip_env Σ = strip_env' Σ.(GlobalContextMap.global_decls) Σ.(GlobalContextMap.wf). Proof. intros wf. From 3856b002c63bf90263b70f3d53d0ffdc470cc281 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 28 Aug 2023 18:02:39 +0200 Subject: [PATCH 43/65] Progress on pipeline theorem proof, main argument remains --- erasure-plugin/theories/Erasure.v | 79 ++-- erasure-plugin/theories/ErasureCorrectness.v | 448 +++++++++++++++++++ 2 files changed, 479 insertions(+), 48 deletions(-) create mode 100644 erasure-plugin/theories/ErasureCorrectness.v diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index ce6e68ef0..b44821921 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -58,25 +58,14 @@ Next Obligation. apply assume_preservation_template_program_env_expansion in ev as [ev']; eauto. Qed. -Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t pcuic_program EProgram.eprogram - PCUICAst.term EAst.term - PCUICTransform.eval_pcuic_program - (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := - (* a bunch of nonsense for normalization preconditions *) - let K ty (T : ty -> _) p - := let p := T p in - (PCUICTyping.wf_ext p -> PCUICSN.NormalizationIn p) /\ - (PCUICTyping.wf_ext p -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p) in - let T1 (p:global_env_ext_map) := p in - (* Branches of cases are expanded to bind only variables, constructor types are expanded accordingly *) - pcuic_expand_lets_transform (K _ T1) ▷ - (* Erasure of proofs terms in Prop and types *) - erase_transform ▷ +Program Definition verified_lambdabox_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + Transform.t EProgram.eprogram_env EProgram.eprogram EAst.term EAst.term + (EProgram.eval_eprogram_env {| with_prop_case := true; with_guarded_fix := true; with_constructor_as_block := false |}) + (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := (* Simulation of the guarded fixpoint rules with a single unguarded one: the only "stuck" fixpoints remaining are unapplied. This translation is a noop on terms and environments. *) - guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ + guarded_to_unguarded_fix (fl := default_wcbv_flags) (wcon := eq_refl) eq_refl ▷ (* Remove all constructor parameters *) remove_params_optimization (wcon := eq_refl) ▷ (* Rebuild the efficient lookup table *) @@ -87,11 +76,12 @@ Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ (* Inline projections to cases *) inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ - let efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags) in (* Rebuild the efficient lookup table *) - rebuild_wf_env_transform (efl := efl) true ▷ + rebuild_wf_env_transform (efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags)) true ▷ (* First-order constructor representation *) - constructors_as_blocks_transformation (efl := efl) (has_app := eq_refl) (has_pars := eq_refl) (has_rel := eq_refl) (hasbox := eq_refl) (has_cstrblocks := eq_refl). + constructors_as_blocks_transformation + (efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags)) + (has_app := eq_refl) (has_pars := eq_refl) (has_rel := eq_refl) (hasbox := eq_refl) (has_cstrblocks := eq_refl). (* At the end of erasure we get a well-formed program (well-scoped globally and localy), without parameters in inductive declarations. The constructor applications are also transformed to a first-order @@ -107,6 +97,25 @@ Next Obligation. Qed. +Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + Transform.t pcuic_program EProgram.eprogram + PCUICAst.term EAst.term + PCUICTransform.eval_pcuic_program + (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := + (* a bunch of nonsense for normalization preconditions *) + let K ty (T : ty -> _) p + := let p := T p in + (PCUICTyping.wf_ext p -> PCUICSN.NormalizationIn p) /\ + (PCUICTyping.wf_ext p -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p) in + let T1 (p:global_env_ext_map) := p in + (* Branches of cases are expanded to bind only variables, constructor types are expanded accordingly *) + pcuic_expand_lets_transform (K _ T1) ▷ + (* Erasure of proofs terms in Prop and types *) + erase_transform ▷ + verified_lambdabox_pipeline. + +Import EGlobalEnv EWellformed. + Definition transform_compose {program program' program'' value value' value'' : Type} {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} @@ -122,38 +131,12 @@ Proof. eexists;reflexivity. Qed. -#[global] -Instance pcuic_expand_lets_transform_ext {cf : checker_flags} K : - TransformExt.t (pcuic_expand_lets_transform K) extends_pcuic_program PCUICAst.term snd. +Lemma verified_lambdabox_pipeline_extends {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : + TransformExt.t verified_lambdabox_pipeline extends_eprogram_env extends_eprogram. Proof. - red. intros p p' pre pre' []. cbn. now rewrite H0. + unfold verified_lambdabox_pipeline. tc. Qed. -Lemma verified_erasure_pipeline_extends {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - TransformExt.t verified_erasure_pipeline extends_pcuic_program EAst.term snd. -Proof. - unfold verified_erasure_pipeline. - eapply TransformExt.compose. - 2:eapply TransformExt.compose. - 2: typeclasses eauto. 2:typeclasses eauto. - 2:{ auto. } - repeat try (eapply TransformExt.compose; [|typeclasses eauto|]). - typeclasses eauto. - all:unfold extends_pcuic_program; cbn. - all:intros; intuition auto; try congruence. - red. cbn. - - - - - - - - - } - red. - - Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : Transform.t TemplateProgram.template_program pcuic_program Ast.term PCUICAst.term diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v new file mode 100644 index 000000000..01c4ac15e --- /dev/null +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -0,0 +1,448 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Program ssreflect ssrbool. +From MetaCoq.Common Require Import Transform config. +From MetaCoq.Utils Require Import bytestring utils. +From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram. +From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl. +From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness EPretty Extract. +From MetaCoq Require Import ETransform EConstructorsAsBlocks. +From MetaCoq.Erasure Require Import EWcbvEvalNamed. +From MetaCoq.ErasurePlugin Require Import Erasure. +Import PCUICProgram. +(* Import TemplateProgram (template_eta_expand). + *) +Import PCUICTransform (template_to_pcuic_transform, pcuic_expand_lets_transform). + +(* This is the total erasure function + + let-expansion of constructor arguments and case branches + + shrinking of the global environment dependencies + + the optimization that removes all pattern-matches on propositions. *) + +Import Transform. + +Obligation Tactic := program_simpl. + +#[local] Existing Instance extraction_checker_flags. + +Import EWcbvEval. + +Lemma transform_compose_assoc + {program program' program'' program''' value value' value'' value''' : Type} + {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} + {eval'' : program'' -> value'' -> Prop} + {eval''' : program''' -> value''' -> Prop} + (o : t program program' value value' eval eval') + (o' : t program' program'' value' value'' eval' eval'') + (o'' : t program'' program''' value'' value''' eval'' eval''') + (prec : forall p : program', post o p -> pre o' p) + (prec' : forall p : program'', post o' p -> pre o'' p) : + forall x p1, + transform (compose o (compose o' o'' prec') prec) x p1 = + transform (compose (compose o o' prec) o'' prec') x p1. +Proof. + cbn. intros. + unfold run, time. + f_equal. f_equal. + apply proof_irrelevance. +Qed. + +Lemma obseq_compose_assoc + {program program' program'' program''' value value' value'' value''' : Type} + {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} + {eval'' : program'' -> value'' -> Prop} + {eval''' : program''' -> value''' -> Prop} + (o : t program program' value value' eval eval') + (o' : t program' program'' value' value'' eval' eval'') + (o'' : t program'' program''' value'' value''' eval'' eval''') + (prec : forall p : program', post o p -> pre o' p) + (prec' : forall p : program'', post o' p -> pre o'' p) : + forall x p1 p2 v1 v2, obseq (compose o (compose o' o'' prec') prec) x p1 p2 v1 v2 <-> + obseq (compose (compose o o' prec) o'' prec') x p1 p2 v1 v2. +Proof. + cbn. intros. + unfold run, time. + intros. firstorder. exists x1. split. + exists x0. split => //. + assert (correctness o' (transform o x p1) + (prec (transform o x p1) (correctness o x p1)) = + (Transform.Transform.compose_obligation_1 o o' prec x p1)). apply proof_irrelevance. + now rewrite -H. + + exists x1. split => //. + exists x0. split => //. + assert (correctness o' (transform o x p1) + (prec (transform o x p1) (correctness o x p1)) = + (Transform.Transform.compose_obligation_1 o o' prec x p1)). apply proof_irrelevance. + now rewrite H. +Qed. + +Import EEnvMap.GlobalContextMap. +Lemma make_irrel Σ fr fr' : EEnvMap.GlobalContextMap.make Σ fr = EEnvMap.GlobalContextMap.make Σ fr'. +Proof. + unfold make. f_equal. + apply proof_irrelevance. +Qed. + +Lemma eval_value {efl : WcbvFlags} Σ v v' : + value Σ v -> eval Σ v v' -> v = v'. +Proof. + intros isv ev. + now pose proof (eval_deterministic ev (value_final _ isv)). +Qed. + +Ltac destruct_compose := + match goal with + |- context [ transform (compose ?x ?y ?pre) ?p ?pre' ] => + let pre'' := fresh in + let H := fresh in + destruct (transform_compose x y pre p pre') as [pre'' H]; + rewrite H; clear H; revert pre'' + (* rewrite H'; clear H'; *) + (* revert pre'' *) + end. + +Ltac destruct_compose_no_clear := + match goal with + |- context [ transform (compose ?x ?y ?pre) ?p ?pre' ] => + let pre'' := fresh in + let H := fresh in + destruct (transform_compose x y pre p pre') as [pre'' H]; + rewrite H; revert pre'' H + end. + +(* +Section TransformValue. + Context {program program' : Type}. + Context {value value' : Type}. + Context {eval : program -> value -> Prop}. + Context {eval' : program' -> value' -> Prop}. + Context (t : Transform.t program program' value value' eval eval'). + + Lemma preserves_value p : value p.1 p.2 (transform t p) + + Definition preserves_eval pre (transform : forall p : program, pre p -> program') + (obseq : forall p : program, pre p -> program' -> value -> value' -> Prop) := + forall p v (pr : pre p), + eval p v -> + let p' := transform p pr in + exists v', eval' p' v' /\ obseq p pr p' v v'. + + Record t := + { name : string; + +Lemma transform_value *) + + +Inductive is_construct_app : EAst.term -> Prop := +| is_cstr_app_cstr kn c args : Forall is_construct_app args -> is_construct_app (EAst.tConstruct kn c args) +| is_cstr_app_app f a : is_construct_app f -> is_construct_app a -> is_construct_app (EAst.tApp f a). + +Section lambdabox_theorem. + + Context (Σ Σ' : EEnvMap.GlobalContextMap.t) (v : EAst.term). + + Context (p : pre verified_lambdabox_pipeline (Σ, v)). + Context (p' : pre verified_lambdabox_pipeline (Σ', v)). + Context (is_value : value (wfl := default_wcbv_flags) Σ v). + + Lemma pres : extends_eprogram_env (Σ, v) (Σ', v) -> + extends_eprogram (transform verified_lambdabox_pipeline (Σ, v) p) + (transform verified_lambdabox_pipeline (Σ', v) p'). + Proof. + epose proof (pres := verified_lambdabox_pipeline_extends). + red in pres. specialize (pres _ _ p p'). auto. + Qed. + + (* Final evaluation flags *) + Definition evflags := {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}. + + Lemma pres_firstorder_value : + is_construct_app v -> + is_construct_app (transform verified_lambdabox_pipeline (Σ, v) p).2. + Proof. + intros isapp. + destruct (preservation verified_lambdabox_pipeline (Σ, v) v p) as [v' [[ev] obs]]. + { red. cbn. sq. eapply value_final, is_value. } + set (transp := transform _ _ p) in *. + assert (value (wfl := evflags) transp.1 transp.2). admit. + eapply eval_value in ev => //. subst v'. + clear -obs isapp. + unfold verified_lambdabox_pipeline in obs. + cbn [obseq compose] in obs. + unfold run, time in obs. + decompose [ex and prod] obs. clear obs. subst. + cbn [obseq compose verified_lambdabox_pipeline] in *. + cbn [obseq compose constructors_as_blocks_transformation] in *. + cbn [obseq run compose rebuild_wf_env_transform] in *. + cbn [obseq compose inline_projections_optimization] in *. + cbn [obseq compose remove_match_on_box_trans] in *. + cbn [obseq compose remove_params_optimization] in *. + cbn [obseq compose guarded_to_unguarded_fix] in *. + cbn [obseq compose verified_lambdabox_pipeline] in *. + subst. + cbn [transform rebuild_wf_env_transform] in *. + cbn [transform constructors_as_blocks_transformation] in *. + cbn [transform inline_projections_optimization] in *. + cbn [transform remove_match_on_box_trans] in *. + cbn [transform remove_params_optimization] in *. + cbn [transform guarded_to_unguarded_fix] in *. + clearbody transp. revert b. intros ->. clear transp. + induction isapp. + cbn in *. constructor. constructor. + Admitted. + + +End lambdabox_theorem. + + +Lemma rebuild_wf_env_irr {efl : EWellformed.EEnvFlags} p wf p' wf' : + p.1 = p'.1 -> + (rebuild_wf_env p wf).1 = (rebuild_wf_env p' wf').1. +Proof. + destruct p as [], p' as []. + cbn. intros <-. + unfold make. f_equal. apply proof_irrelevance. +Qed. + +Lemma obseq_lambdabox (Σt Σ'v : EProgram.eprogram_env) pr pr' p' v' : + EGlobalEnv.extends Σ'v.1 Σt.1 -> + obseq verified_lambdabox_pipeline Σt pr p' Σ'v.2 v' -> + (transform verified_lambdabox_pipeline Σ'v pr').2 = v'. +Proof. + intros ext obseq. + destruct Σt as [Σ t], Σ'v as [Σ' v]. + pose proof verified_lambdabox_pipeline_extends. + red in H. + assert (pr'' : pre verified_lambdabox_pipeline (Σ, v)). + { clear -pr pr' ext. destruct pr as [[] ?], pr' as [[] ?]. + split. red; cbn. split => //. + eapply EWellformed.extends_wellformed; tea. + split. apply H1. cbn. destruct H4; cbn in *. + eapply EEtaExpandedFix.isEtaExp_expanded. + eapply EEtaExpandedFix.isEtaExp_extends; tea. + now eapply EEtaExpandedFix.expanded_isEtaExp. } + destruct (H _ _ pr' pr'') as [ext' ->]. + split => //. + clear H. + move: obseq. + unfold verified_lambdabox_pipeline. + repeat destruct_compose. + cbn [transform rebuild_wf_env_transform] in *. + cbn [transform constructors_as_blocks_transformation] in *. + cbn [transform inline_projections_optimization] in *. + cbn [transform remove_match_on_box_trans] in *. + cbn [transform remove_params_optimization] in *. + cbn [transform guarded_to_unguarded_fix] in *. + intros ? ? ? ? ? ? ?. + unfold run, time. + cbn [obseq compose constructors_as_blocks_transformation] in *. + cbn [obseq run compose rebuild_wf_env_transform] in *. + cbn [obseq compose inline_projections_optimization] in *. + cbn [obseq compose remove_match_on_box_trans] in *. + cbn [obseq compose remove_params_optimization] in *. + cbn [obseq compose guarded_to_unguarded_fix] in *. + intros obs. + decompose [ex and prod] obs. clear obs. subst. + unfold run, time. + unfold transform_blocks_program. cbn [snd]. f_equal. + repeat destruct_compose. + intros. + cbn [transform rebuild_wf_env_transform] in *. + cbn [transform constructors_as_blocks_transformation] in *. + cbn [transform inline_projections_optimization] in *. + cbn [transform remove_match_on_box_trans] in *. + cbn [transform remove_params_optimization] in *. + cbn [transform guarded_to_unguarded_fix] in *. + eapply rebuild_wf_env_irr. + unfold EInlineProjections.optimize_program. cbn [fst snd]. + f_equal. + eapply rebuild_wf_env_irr. + unfold EOptimizePropDiscr.remove_match_on_box_program. cbn [fst snd]. + f_equal. + now eapply rebuild_wf_env_irr. +Qed. + +Lemma extends_erase_pcuic_program {guard : abstract_guard_impl} (Σ : global_env_ext_map) t t' nin nin' nin0 nin0' wf wf' ty ty' : + PCUICWcbvEval.eval Σ t' t -> + EGlobalEnv.extends + (@erase_pcuic_program guard (Σ, t) nin nin' wf ty).1 + (@erase_pcuic_program guard (Σ, t') nin0 nin0' wf' ty').1. +Proof. + intros ev. + cbn. + unfold ErasureFunction.erase_global_fast. + set (eg := ErasureFunction.erase _ _ _ _ _). + set (eg' := ErasureFunction.erase _ _ _ _ _). + erewrite ErasureFunction.erase_global_deps_fast_spec. + erewrite ErasureFunction.erase_global_deps_fast_spec. + epose proof ErasureFunction.erase_global_decls_irr. +Admitted. + +Section pipeline_theorem. + + Fixpoint compile_value_box (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := + match t with + | PCUICAst.tApp f a => compile_value_box f (acc ++ [compile_value_box a []]) + | PCUICAst.tConstruct i n _ => EAst.tConstruct i n acc + | _ => EAst.tVar "error" + end. + + Instance cf : checker_flags := extraction_checker_flags. + Instance nf : PCUICSN.normalizing_flags := PCUICSN.extraction_normalizing. + + Variable Σ : global_env_ext_map. + Variable HΣ : PCUICTyping.wf_ext Σ. + Variable expΣ : PCUICEtaExpand.expanded_global_env Σ.1. + + Variable t : PCUICAst.term. + Variable expt : PCUICEtaExpand.expanded Σ.1 [] t. + + Variable v : PCUICAst.term. + + Variable i : Kernames.inductive. + Variable u : Universes.Instance.t. + Variable args : list PCUICAst.term. + + Variable typing : PCUICTyping.typing Σ [] t (PCUICAst.mkApps (PCUICAst.tInd i u) args). + + Variable fo : @PCUICFirstorder.firstorder_ind Σ (PCUICFirstorder.firstorder_env Σ) i. + + Variable Normalisation : PCUICSN.NormalizationIn Σ. + + Lemma precond : pre verified_erasure_pipeline (Σ, t). + Proof. + hnf. repeat eapply conj; sq; cbn; eauto. + - red. cbn. eauto. + - todo "normalization". + - todo "normalization". + Qed. + + Variable Heval : ∥PCUICWcbvEval.eval Σ t v∥. + + Lemma precond2 : pre verified_erasure_pipeline (Σ, v). + Proof. + cbn. repeat eapply conj; sq; cbn; eauto. + - red. cbn. split; eauto. + eexists. + eapply PCUICClassification.subject_reduction_eval; eauto. + - todo "preservation of eta expandedness". + - todo "normalization". + - todo "normalization". + Qed. + + Let Σ_t := (transform verified_erasure_pipeline (Σ, t) precond).1. + Let t_t := (transform verified_erasure_pipeline (Σ, t) precond).2. + Let v_t := compile_value_box v []. + + Lemma fo_v : PCUICFirstorder.firstorder_value Σ [] v. + Proof. + sq. + eapply PCUICFirstorder.firstorder_value_spec; eauto. + - eapply PCUICClassification.subject_reduction_eval; eauto. + - eapply PCUICWcbvEval.eval_to_value; eauto. + Qed. + + + Lemma v_t_spec : v_t = (transform verified_erasure_pipeline (Σ, v) precond2).2. + Proof. + unfold v_t. generalize fo_v, precond2. clear. + induction 1. + intros. unfold verified_erasure_pipeline. + repeat destruct_compose. intros. + cbn [transform erase_transform]. + cbn [transform pcuic_expand_lets_transform]. + Admitted. + + Import PCUICWfEnv. + + + + Lemma verified_erasure_pipeline_theorem : + ∥ eval (wfl := extraction_wcbv_flags) Σ_t t_t v_t∥. + Proof. + hnf. + pose proof (preservation verified_erasure_pipeline (Σ, t)) as Hcorr. + unshelve eapply Hcorr in Heval as Hev. eapply precond. + destruct Hev as [v' [[H1] H2]]. + move: H2. + + (* repeat match goal with + [ H : obseq _ _ _ _ _ |- _ ] => hnf in H ; decompose [ex and prod] H ; subst + end. *) + rewrite v_t_spec. + subst v_t Σ_t t_t. + revert H1. + unfold verified_erasure_pipeline. + intros. + revert H1 H2. clear Hcorr. + intros ev obs. + cbn [obseq compose] in obs. + unfold run, time in obs. + decompose [ex and prod] obs. clear obs. + subst. + cbn [obseq compose erase_transform] in *. + cbn [obseq compose pcuic_expand_lets_transform] in *. + subst. + move: ev b. + repeat destruct_compose. + intros. + move: b. + cbn [transform rebuild_wf_env_transform] in *. + cbn [transform constructors_as_blocks_transformation] in *. + cbn [transform inline_projections_optimization] in *. + cbn [transform remove_match_on_box_trans] in *. + cbn [transform remove_params_optimization] in *. + cbn [transform guarded_to_unguarded_fix] in *. + cbn [transform erase_transform] in *. + cbn [transform compose pcuic_expand_lets_transform] in *. + unfold run, time. + cbn [obseq compose constructors_as_blocks_transformation] in *. + cbn [obseq run compose rebuild_wf_env_transform] in *. + cbn [obseq compose inline_projections_optimization] in *. + cbn [obseq compose remove_match_on_box_trans] in *. + cbn [obseq compose remove_params_optimization] in *. + cbn [obseq compose guarded_to_unguarded_fix] in *. + cbn [obseq compose erase_transform] in *. + cbn [obseq compose pcuic_expand_lets_transform] in *. + cbn [transform compose pcuic_expand_lets_transform] in *. + cbn [transform erase_transform] in *. + destruct Heval. + pose proof typing as typing'. + eapply PCUICClassification.subject_reduction_eval in typing'; tea. + eapply PCUICExpandLetsCorrectness.pcuic_expand_lets in typing'. + rewrite PCUICExpandLetsCorrectness.trans_mkApps /= in typing'. + destruct H1. + (* pose proof (abstract_make_wf_env_ext) *) + unfold PCUICExpandLets.expand_lets_program. + set (em := build_global_env_map _). + unfold erase_program. + set (f := map_squash _ _). cbn in f. + destruct H. destruct s as [[]]. + set (wfe := build_wf_env_from_env em (map_squash (PCUICTyping.wf_ext_wf (em, Σ.2)) (map_squash fst (conj (sq (w0, s)) a).p1))). + destruct Heval. + eapply (ErasureFunction.firstorder_erases_deterministic optimized_abstract_env_impl wfe Σ.2) in b0. 3:tea. + 2:{ cbn. reflexivity. } + 2:{ eapply PCUICExpandLetsCorrectness.trans_wcbveval. eapply PCUICWcbvEval.eval_closed; tea. apply HΣ. + admit. + eapply PCUICWcbvEval.value_final. now eapply PCUICWcbvEval.eval_to_value in X0. } + 2:{ clear -fo. admit. } + 2:{ apply HΣ. } + 2:{ apply PCUICExpandLetsCorrectness.trans_wf, HΣ. } + rewrite b0. + intros obs. + constructor. + match goal with [ H1 : eval _ _ ?v1 |- eval _ _ ?v2 ] => enough (v2 = v1) as -> by exact ev end. + eapply obseq_lambdabox; revgoals. + unfold erase_pcuic_program. cbn [fst snd]. exact obs. + clear obs b0 ev e w. + eapply extends_erase_pcuic_program. cbn. + eapply (PCUICExpandLetsCorrectness.trans_wcbveval (Σ := (Σ.1, Σ.2))). admit. exact X0. + Admitted. + + Lemma verified_erasure_pipeline_lambda : + PCUICAst.isLambda t -> EAst.isLambda t_t. + Proof. + unfold t_t. clear. + Admitted. + +End pipeline_theorem. From 71819e7bc59d814386abdf74958f56b735da29ce Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 29 Aug 2023 18:17:51 +0200 Subject: [PATCH 44/65] Main argument of the erasure with dependencies proof --- erasure-plugin/theories/ErasureCorrectness.v | 5 +- erasure/theories/ErasureFunction.v | 918 ++++++++++++++++--- 2 files changed, 800 insertions(+), 123 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 01c4ac15e..437a1ab61 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -271,11 +271,12 @@ Proof. intros ev. cbn. unfold ErasureFunction.erase_global_fast. - set (eg := ErasureFunction.erase _ _ _ _ _). - set (eg' := ErasureFunction.erase _ _ _ _ _). + set (et := ErasureFunction.erase _ _ _ _ _). + set (et' := ErasureFunction.erase _ _ _ _ _). erewrite ErasureFunction.erase_global_deps_fast_spec. erewrite ErasureFunction.erase_global_deps_fast_spec. epose proof ErasureFunction.erase_global_decls_irr. + intros kn decl. Admitted. Section pipeline_theorem. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 5edab27a3..3d4b6710e 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -877,7 +877,7 @@ Definition iter {A} (f : A -> A) : nat -> (A -> A) end. (* we use the [match] trick to get typeclass resolution to pick up the right instances without leaving any evidence in the resulting term, and without having to pass them manually everywhere *) -Notation NormalizationIn_erase_global_decls X decls +Notation NormalizationIn_erase_global_deps X decls := (match extraction_checker_flags, extraction_normalizing return _ with | cf, no => forall n, @@ -892,8 +892,8 @@ Notation NormalizationIn_erase_global_decls X decls Lemma normalization_in_inv {X_type : abstract_env_impl} (X : X_type.π1) (decls : global_declarations) kn cb - (normalization_in : NormalizationIn_erase_global_decls X ((kn, ConstantDecl cb) :: decls)) : - NormalizationIn_erase_global_decls (abstract_pop_decls X) decls. + (normalization_in : NormalizationIn_erase_global_deps X ((kn, ConstantDecl cb) :: decls)) : + NormalizationIn_erase_global_deps (abstract_pop_decls X) decls. Proof. cbv [id]. intros. unshelve eapply (normalization_in (S n)); cbn; tea. lia. @@ -992,9 +992,9 @@ Proof. now rewrite H1 H2. } Qed. -Program Fixpoint erase_global_decls +Program Fixpoint erase_global_deps {X_type : abstract_env_impl} (deps : KernameSet.t) (X : X_type.π1) (decls : global_declarations) - {normalization_in : NormalizationIn_erase_global_decls X decls} + {normalization_in : NormalizationIn_erase_global_deps X decls} (prop : forall Σ : global_env, abstract_env_rel X Σ -> Σ.(declarations) = decls) : E.global_declarations * KernameSet.t := match decls with @@ -1004,18 +1004,18 @@ Program Fixpoint erase_global_decls if KernameSet.mem kn deps then let cb' := @erase_constant_decl X_type X' cb _ _ in let deps := KernameSet.union deps (snd cb') in - let X'' := erase_global_decls deps X' decls _ in + let X'' := erase_global_deps deps X' decls _ in (((kn, E.ConstantDecl (fst cb')) :: fst X''), snd X'') else - erase_global_decls deps X' decls _ + erase_global_deps deps X' decls _ | (kn, InductiveDecl mib) :: decls => let X' := abstract_pop_decls X in if KernameSet.mem kn deps then let mib' := erase_mutual_inductive_body mib in - let X'':= erase_global_decls deps X' decls _ in + let X'':= erase_global_deps deps X' decls _ in (((kn, E.InductiveDecl mib') :: fst X''), snd X'') - else erase_global_decls deps X' decls _ + else erase_global_deps deps X' decls _ end. Next Obligation. cbv [id]. @@ -1071,12 +1071,66 @@ assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(de now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). Qed. -Lemma erase_global_decls_irr +Program Fixpoint erase_global {X_type : abstract_env_impl} (X : X_type.π1) (decls : global_declarations) + {normalization_in : NormalizationIn_erase_global_deps X decls} + (prop : forall Σ : global_env, abstract_env_rel X Σ -> Σ.(declarations) = decls) + : E.global_declarations := + match decls with + | [] => [] + | (kn, ConstantDecl cb) :: decls => + let X' := abstract_pop_decls X in + let cb' := @erase_constant_decl X_type X' cb _ _ in + let X'' := erase_global X' decls _ in + ((kn, E.ConstantDecl (fst cb')) :: X'') + + | (kn, InductiveDecl mib) :: decls => + let X' := abstract_pop_decls X in + let mib' := erase_mutual_inductive_body mib in + let X'':= erase_global X' decls _ in + ((kn, E.InductiveDecl mib') :: X'') + end. +Next Obligation. + cbv [id]. + unshelve eapply (normalization_in 0); tea; cbn; try reflexivity; try lia. +Defined. +Next Obligation. + pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_wf _ HX) as [wfX]. + assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). + { now eexists. } + pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). + destruct x, Σ as [[] u], H0; cbn in *. + subst. sq. inversion H1. subst. destruct wfX. cbn in *. + specialize (prop _ HX). + cbn in prop. + rewrite prop in o0. depelim o0. destruct o1. + split. 2:exact on_global_decl_d. split => //. +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + pose proof (abstract_env_exists X) as [[? HX]]. + assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). + { now eexists. } + now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. +pose proof (abstract_env_exists X) as [[? HX]]. +assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). +{ now eexists. } +now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). +Qed. + +Lemma erase_global_deps_irr X_type deps (X:X_type.π1) decls - {normalization_in normalization_in' : NormalizationIn_erase_global_decls X decls} + {normalization_in normalization_in' : NormalizationIn_erase_global_deps X decls} prf prf' : - erase_global_decls deps X decls (normalization_in:=normalization_in) prf = - erase_global_decls deps X decls (normalization_in:=normalization_in') prf'. + erase_global_deps deps X decls (normalization_in:=normalization_in) prf = + erase_global_deps deps X decls (normalization_in:=normalization_in') prf'. Proof. revert X deps normalization_in normalization_in' prf prf'. induction decls; eauto. intros. destruct a as [kn []]. @@ -1616,7 +1670,7 @@ Lemma erase_global_includes X_type (X:X_type.π1) deps decls {normalization_in} forall Σ : global_env, abstract_env_rel X Σ -> ∥ ∑ decl, lookup_env Σ d = Some decl ∥) -> KernameSet.subset deps' deps -> forall Σ : global_env, abstract_env_rel X Σ -> - let Σ' := erase_global_decls deps X decls (normalization_in:=normalization_in) prf in + let Σ' := erase_global_deps deps X decls (normalization_in:=normalization_in) prf in includes_deps Σ (fst Σ') deps'. Proof. intros ? sub Σ wfΣ; cbn. induction decls in X, H, sub, prf, deps, deps', Σ , wfΣ, normalization_in |- *. @@ -1629,7 +1683,7 @@ Proof. eapply KernameSet.subset_spec in sub. edestruct (H i hin) as [[decl Hdecl]]; eauto. unfold lookup_env in Hdecl. pose proof (eqb_spec i kn). - rewrite (prf _ wfΣ) in Hdecl. move: Hdecl. cbn -[erase_global_decls]. + rewrite (prf _ wfΣ) in Hdecl. move: Hdecl. cbn -[erase_global_deps]. elim: H0. intros -> [= <-]. * destruct d as [|]; [left|right]. { cbn. set (Xpop := abstract_pop_decls X). @@ -1775,7 +1829,7 @@ Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) forall wt : forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t, erase X_type Xext [] t wt = t' -> KernameSet.subset (term_global_deps t') deps -> - erase_global_decls deps X decls (normalization_in:=normalization_in) prf = Σ' -> + erase_global_deps deps X decls (normalization_in:=normalization_in) prf = Σ' -> (forall Σ : global_env, abstract_env_rel X Σ -> Σ |-p t ⇓ v) -> forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> exists v', Σ ;;; [] |- v ⇝ℇ v' /\ ∥ fst Σ' ⊢ t' ⇓ v' ∥. @@ -1911,22 +1965,22 @@ Qed. Local Hint Constructors expanded : expanded. -Local Arguments erase_global_decls _ _ _ _ _ : clear implicits. +Local Arguments erase_global_deps _ _ _ _ _ : clear implicits. (*Lemma lookup_env_erase X_type X deps decls normalization_in prf kn d : KernameSet.In kn deps -> forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some (InductiveDecl d) -> - EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf) kn = Some (EAst.InductiveDecl (erase_mutual_inductive_body d)). + EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf) kn = Some (EAst.InductiveDecl (erase_mutual_inductive_body d)). Proof. intros hin Σ wfΣ. pose proof (prf _ wfΣ). unfold lookup_env. rewrite H. clear H. rewrite /lookup_env. induction decls in X, Σ , wfΣ ,prf, deps, hin, normalization_in |- *. - move=> /= //. - destruct a as [kn' d']. - cbn -[erase_global_decls]. + cbn -[erase_global_deps]. case: (eqb_spec kn kn'); intros e'; subst. intros [= ->]. - unfold erase_global_decls. + unfold erase_global_deps. eapply KernameSet.mem_spec in hin. rewrite hin /=. now rewrite eq_kername_refl. intros hl. destruct d'. simpl. @@ -1949,7 +2003,7 @@ Qed. Lemma lookup_env_erase_decl_None X_type X deps decls normalization_in prf kn : forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = None -> - EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls normalization_in prf).1 kn = None. + EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf).1 kn = None. Proof. intros Σ wfΣ. pose proof (prf _ wfΣ). @@ -1958,7 +2012,7 @@ Proof. induction decls in X, Σ , wfΣ ,prf, deps, normalization_in |- *. - move=> /= //. - destruct a as [kn' d']. - cbn -[erase_global_decls]. + cbn -[erase_global_deps]. case: (eqb_spec kn kn'); intros e'; subst. intros [= ->]. cbn. destruct d'. cbn. @@ -1985,10 +2039,10 @@ Lemma lookup_env_erase_global_diff X_type X deps decls kn kn' d' normalization_i kn <> kn' -> exists deps' nin' prf', KernameSet.Subset deps deps' /\ - EGlobalEnv.lookup_env (erase_global_decls X_type deps X ((kn', d') :: decls) normalization_in prf).1 kn = - EGlobalEnv.lookup_env (erase_global_decls X_type deps' (abstract_pop_decls X) decls nin' prf').1 kn /\ - (KernameSet.In kn (erase_global_decls X_type deps X ((kn', d') :: decls) normalization_in prf).2 -> - KernameSet.In kn (erase_global_decls X_type deps' (abstract_pop_decls X) decls nin' prf').2). + EGlobalEnv.lookup_env (erase_global_deps X_type deps X ((kn', d') :: decls) normalization_in prf).1 kn = + EGlobalEnv.lookup_env (erase_global_deps X_type deps' (abstract_pop_decls X) decls nin' prf').1 kn /\ + (KernameSet.In kn (erase_global_deps X_type deps X ((kn', d') :: decls) normalization_in prf).2 -> + KernameSet.In kn (erase_global_deps X_type deps' (abstract_pop_decls X) decls nin' prf').2). Proof. intros hd. simpl. destruct d'. @@ -2037,15 +2091,15 @@ Proof. now eapply lookup_env_In_map_fst in hl. Qed. -Lemma in_erase_global_decls_acc X_type X deps decls kn normalization_in prf : - KernameSet.In kn (erase_global_decls X_type deps X decls normalization_in prf).2 -> +Lemma in_erase_global_deps_acc X_type X deps decls kn normalization_in prf : + KernameSet.In kn (erase_global_deps X_type deps X decls normalization_in prf).2 -> KernameSet.In kn deps \/ In kn (map fst decls). Proof. induction decls in X, prf, deps, normalization_in |- *. cbn; auto. destruct a as [kn' []]. + cbn. set (ec := erase_constant_decl _ _ _ _). - set (eg := erase_global_decls _ _ _ _ _ _). - set (eg' := erase_global_decls _ _ _ _ _ _). + set (eg := erase_global_deps _ _ _ _ _ _). + set (eg' := erase_global_deps _ _ _ _ _ _). case_eq (KernameSet.mem kn' deps). * cbn; intros. specialize (IHdecls _ _ _ _ H0). destruct IHdecls as [Hu|Hm]; auto. @@ -2060,8 +2114,8 @@ Proof. now destruct H2 as [<- _]. * intros hdeps hin. eapply IHdecls in hin. intuition auto. - + cbn; set (eg := erase_global_decls _ _ _ _ _ _); - set (eg' := erase_global_decls _ _ _ _ _ _). + + cbn; set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). case_eq (KernameSet.mem kn' deps). * cbn; intros. specialize (IHdecls _ _ _ _ H0). destruct IHdecls as [Hu|Hm]; auto. @@ -2077,7 +2131,7 @@ Qed. Lemma lookup_env_erase_decl X_type X deps decls normalization_in prf kn decl : forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some decl -> - let er := erase_global_decls X_type deps X decls normalization_in prf in + let er := erase_global_deps X_type deps X decls normalization_in prf in KernameSet.In kn er.2 -> match decl with | ConstantDecl cb => @@ -2096,13 +2150,13 @@ Proof. induction decls in X, Σ , wfΣ ,prf, deps, decl, normalization_in |- *. - move=> /= //. - destruct a as [kn' d']. - cbn -[erase_global_decls]. + cbn -[erase_global_deps]. case: (eqb_spec kn kn'); intros e'; subst. intros [= ->]. destruct decl. + cbn; set (ec := erase_constant_decl _ _ _ _); - set (eg := erase_global_decls _ _ _ _ _ _); - set (eg' := erase_global_decls _ _ _ _ _ _). + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). case_eq (KernameSet.mem kn' deps). move/KernameSet.mem_spec => hin'; cbn. ++ intros hin. cbn; rewrite eqb_refl; @@ -2112,7 +2166,7 @@ Proof. destruct H as [? []]. unfold strictly_extends_decls. rewrite H. sq; split => //. clear ec eg eg' hin. specialize (prf _ hx). rewrite prf. now eexists [_]. ++ intros kn'deps kn'eg'. - eapply in_erase_global_decls_acc in kn'eg'. + eapply in_erase_global_deps_acc in kn'eg'. destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. elimtype False. clear -prf wfΣ H. specialize (prf _ wfΣ). @@ -2120,14 +2174,14 @@ Proof. rewrite prf in X0. depelim X0. apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. + cbn; - set (eg := erase_global_decls _ _ _ _ _ _); - set (eg' := erase_global_decls _ _ _ _ _ _). + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). case_eq (KernameSet.mem kn' deps). move/KernameSet.mem_spec => hin'; cbn. ++ intros hin. cbn; rewrite eqb_refl; do 3 eexists. ++ intros kn'deps kn'eg'. - eapply in_erase_global_decls_acc in kn'eg'. + eapply in_erase_global_deps_acc in kn'eg'. destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. elimtype False. clear -prf wfΣ H. specialize (prf _ wfΣ). @@ -2187,9 +2241,9 @@ Proof. eapply wf_fresh_globals in X. now rewrite -e0. Qed. -Lemma in_deps_in_erase_global_decls X_type X deps decls normalization_in prf kn : +Lemma in_deps_in_erase_global_deps X_type X deps decls normalization_in prf kn : KernameSet.In kn deps -> - KernameSet.In kn (erase_global_decls X_type deps X decls normalization_in prf).2. + KernameSet.In kn (erase_global_deps X_type deps X decls normalization_in prf).2. Proof. induction decls in X, deps, normalization_in, prf |- *. - intros. now cbn. @@ -2200,8 +2254,8 @@ Proof. unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H' wfpop). intros. rewrite prf => //. now eexists. destruct H0 as [Hd [Hu Hr]]. destruct a. destruct g. - + set (eg := erase_global_decls _ _ _ _ _ _); - set (eg' := erase_global_decls _ _ _ _ _ _). + + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). case_eq (KernameSet.mem k deps). * cbn. intros hm. destruct (eqb_spec k kn). @@ -2209,8 +2263,8 @@ Proof. ++ eapply IHdecls. KernameSetDecide.fsetdec. * intros hnin. eapply IHdecls; tea. - + set (eg := erase_global_decls _ _ _ _ _ _); - set (eg' := erase_global_decls _ _ _ _ _ _). + + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). case_eq (KernameSet.mem k deps). * cbn. intros hm. destruct (eqb_spec k kn). @@ -2220,22 +2274,357 @@ Proof. * intros hnin. eapply IHdecls; tea. Qed. +Definition constant_decls_deps decl := + match decl with + | {| EAst.cst_body := Some b |} => term_global_deps b + | _ => KernameSet.empty + end. -Lemma erase_global_decls_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X:X_type.π1) ext wfX {normalization_in} decls nin prf Γ t wt v wv : - let Xext := abstract_make_wf_env_ext X ext wfX in - let t' := erase X_type Xext (normalization_in := normalization_in) Γ t wt in - let v' := erase X_type Xext (normalization_in := normalization_in) Γ v wv in - let eg := erase_global_decls X_type (term_global_deps t') X decls nin prf in - let eg' := erase_global_decls X_type (term_global_deps v') X decls nin prf in - eg.1 ⊢ t' ⇓ v' -> KernameSet.Subset eg'.2 eg.2. +Fixpoint filter_deps deps decls := + match decls with + | [] => [] + | (kn, decl) :: decls => + if KernameSet.mem kn deps then + match decl with + | EAst.ConstantDecl cst => + (kn, decl) :: filter_deps (KernameSet.union deps (constant_decls_deps cst)) decls + | _ => (kn, decl) :: filter_deps deps decls + end + else filter_deps deps decls + end. + +Lemma erase_global_deps_erase_global {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X:X_type.π1) deps decls {normalization_in} prf : + (@erase_global_deps X_type deps X decls normalization_in prf).1 = + filter_deps deps (@erase_global X_type X decls normalization_in prf). Proof. - intros. clearbody t' v'. + symmetry. + generalize normalization_in at 1. + generalize prf at 1. + intros prf' normalization_in'. + induction decls in normalization_in, normalization_in', prf, prf', X, deps |- *. + - cbn. auto. + - destruct a as [kn []]. + cbn. + + destruct (KernameSet.mem kn deps). + destruct c as [? [] ? ?]. + set (ec := erase_constant_decl _ _ _ _). + set (ec' := erase_constant_decl _ _ _ _). + assert (ec = ec') as <-. + { unfold ec, ec'. eapply erase_constant_decl_irrel. red. cbn. + intros. pose proof (abstract_env_irr _ H H0). subst. red. split; auto. congruence. } + cbn; f_equal. set (d := KernameSet.union _ _). eapply IHdecls. + cbn. f_equal. eapply IHdecls. + eapply IHdecls. + + cbn; destruct (KernameSet.mem kn deps). + cbn. f_equal. eapply IHdecls. + eapply IHdecls. +Qed. + +Lemma knset_mem_spec kn s : reflect (KernameSet.In kn s) (KernameSet.mem kn s). +Proof. + destruct (KernameSet.mem_spec s kn). + destruct (KernameSet.mem kn s). + - now constructor. + - constructor. intros hin. now apply H0 in hin. +Qed. + +Definition global_decl_deps decl := + match decl with + | EAst.ConstantDecl cst => constant_decls_deps cst + | _ => KernameSet.empty + end. + +Fixpoint global_deps (Σ : EAst.global_declarations) deps := + match Σ with + | [] => deps + | (kn, decl) :: decls => + if KernameSet.mem kn deps then + global_deps decls + (KernameSet.union deps (global_decl_deps decl)) + else global_deps decls deps + end. + +Infix "=kn" := KernameSet.Equal (at level 90). + +Ltac knset := KernameSetDecide.fsetdec. + +Lemma global_deps_union Σ deps deps' : + global_deps Σ (KernameSet.union deps deps') =kn + KernameSet.union (global_deps Σ deps) (global_deps Σ deps'). +Proof. + induction Σ in deps, deps' |- *; auto. + - reflexivity. + - destruct a. cbn -[KernameSet.mem]. + destruct (knset_mem_spec k deps'). + * case: (knset_mem_spec k _). + move/KernameSet.union_spec => hin. + destruct hin. + eapply KernameSet.mem_spec in H. rewrite H. + rewrite !IHΣ. KernameSetDecide.fsetdec. + ** case: (knset_mem_spec k _); intros hin'; + rewrite !IHΣ; KernameSetDecide.fsetdec. + ** intros hin'. + case: (knset_mem_spec k _); intros hin''; + rewrite !IHΣ; KernameSetDecide.fsetdec. + * case: (knset_mem_spec k _); intros hin''. + case: (knset_mem_spec k _); intros hin'''. + rewrite !IHΣ. knset. + rewrite !IHΣ. knset. + case: (knset_mem_spec k _); intros hin'''. + rewrite !IHΣ. knset. + rewrite !IHΣ. knset. +Qed. + +Lemma in_global_deps deps Σ : + KernameSet.Subset deps (global_deps Σ deps). +Proof. + induction Σ => //. + destruct a as [kn [[[]]|]]; cbn; eauto; + case: (knset_mem_spec kn _); intros hin'''; + rewrite ?global_deps_union; + intros h hin; rewrite ?KernameSet.union_spec; try left; knset. +Qed. + +Lemma term_global_deps_csubst a k b : + KernameSet.Subset (term_global_deps (ECSubst.csubst a k b)) + (KernameSet.union (term_global_deps a) (term_global_deps b)). Admitted. +Lemma global_deps_subset Σ deps deps' : + KernameSet.Subset deps deps' -> + KernameSet.Subset (global_deps Σ deps) (global_deps Σ deps'). +Proof. + induction Σ in deps, deps' |- *. + - cbn. auto. + - destruct a; cbn. + intros sub. + case: (knset_mem_spec k deps) => hin. + eapply sub in hin. eapply KernameSet.mem_spec in hin. rewrite hin. + rewrite !global_deps_union. + specialize (IHΣ _ _ sub). knset. + case: (knset_mem_spec k deps') => hin'. + rewrite !global_deps_union. + specialize (IHΣ _ _ sub). knset. + now eapply IHΣ. +Qed. + +Arguments KernameSet.mem : simpl never. + +Lemma lookup_env_In Σ kn d : EGlobalEnv.lookup_env Σ kn = Some d -> In kn (map fst Σ). +Proof. + induction Σ; cbn; auto. + - easy. + - destruct (eqb_spec kn a.1). + intros [= <-]. left; auto. + intros hl; right; auto. +Qed. + + +Lemma term_global_deps_fresh {efl : EWellformed.EEnvFlags} Σ k t : + EWellformed.wellformed Σ k t -> + forall kn, KernameSet.In kn (term_global_deps t) -> In kn (map fst Σ). +Proof. + induction t in k |- * using EInduction.term_forall_list_ind; intros; try cbn in *; try knset; + rtoProp; intuition eauto. + all:try eapply KernameSet.union_spec in H0; intuition eauto. + - apply KernameSet.singleton_spec in H0. subst s. + destruct (EGlobalEnv.lookup_env Σ kn) eqn:E. + destruct g => //. destruct c => //. cbn in H1. + now eapply lookup_env_In in E. easy. + - admit. + - admit. + - admit. + - admit. + - admit. +Admitted. + +Lemma wf_global_decl_deps {efl : EWellformed.EEnvFlags} Σ d : + EWellformed.wf_global_decl Σ d -> + forall kn, KernameSet.In kn (global_decl_deps d) -> In kn (map fst Σ). +Proof. + intros wf kn hin. + destruct d as [[[]]|] => //; cbn in hin. + * eapply term_global_deps_fresh in hin. exact hin. cbn in wf; tea. + * knset. + * knset. +Qed. + +Lemma lookup_global_deps {efl : EWellformed.EEnvFlags} Σ kn decl : + EWellformed.wf_glob Σ -> + EGlobalEnv.lookup_env Σ kn = Some decl -> + forall kn, KernameSet.In kn (global_decl_deps decl) -> In kn (map fst Σ). +Proof. + induction 1 in kn, decl |- *. + - cbn => //. + - cbn. + case: (eqb_spec kn kn0) => heq. + subst kn0; intros [= <-]. + intros kn' hkn'. + * eapply wf_global_decl_deps in H0; tea. now right. + * intros hl kn' kin. + eapply IHwf_glob in hl; tea. now right. +Qed. + +Lemma fresh_global_In kn Σ : EGlobalEnv.fresh_global kn Σ <-> ~ In kn (map fst Σ). +Proof. + split. + - intros fr. + eapply (Forall_map (fun x => x <> kn) fst) in fr. + intros hin. + now eapply PCUICWfUniverses.Forall_In in fr; tea. + - intros nin. + red. eapply In_Forall. intros kn' hin <-. + eapply nin. now eapply (in_map fst). +Qed. + +Lemma global_deps_kn {fl :EWellformed.EEnvFlags} Σ kn decl : + EWellformed.wf_glob Σ -> + EGlobalEnv.declared_constant Σ kn decl -> + KernameSet.Subset (global_deps Σ (constant_decls_deps decl)) (global_deps Σ (KernameSet.singleton kn)). +Proof. + induction 1 in kn, decl |- *. + - cbn. unfold EGlobalEnv.declared_constant. cbn => //. + - cbn. unfold EGlobalEnv.declared_constant. cbn => //. + destruct (eqb_spec kn kn0). subst kn0. cbn. intros [= ->]. + + case: (knset_mem_spec kn _) => hin. + * eapply wf_global_decl_deps in H0; tea. + now eapply fresh_global_In in H1. + * case: (knset_mem_spec kn _) => hin'. + rewrite !global_deps_union. cbn. knset. + knset. + + + intros hl. + case: (knset_mem_spec kn0 _) => hin. + * elimtype False. + eapply lookup_global_deps in hl; tea. + now eapply fresh_global_In in H1. + * case: (knset_mem_spec kn0 _). + ** move/KernameSet.singleton_spec. intros <-. congruence. + ** intros hnin. now eapply IHwf_glob. +Qed. + +Lemma eval_global_deps {fl : EWcbvEval.WcbvFlags} {efl : EWellformed.EEnvFlags} Σ t t' : + EWellformed.wf_glob Σ -> + Σ ⊢ t ⇓ t' -> KernameSet.Subset (global_deps Σ (term_global_deps t')) (global_deps Σ (term_global_deps t)). +Proof. + intros wf. + induction 1 using EWcbvEval.eval_ind; cbn; rewrite ?global_deps_union; try knset. + - cbn in IHeval1. + epose proof (term_global_deps_csubst a' 0 b). + eapply (global_deps_subset Σ) in H2. + rewrite global_deps_union in H2. + knset. + - epose proof (term_global_deps_csubst b0' 0 b1). + eapply (global_deps_subset Σ) in H1. + rewrite global_deps_union in H1. + knset. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - cbn. + epose proof (global_deps_kn Σ c decl wf isdecl). + unfold constant_decls_deps in H0. destruct decl => //. + cbn in e. subst cst_body0. knset. + - admit. +Admitted. + +Lemma in_global_deps_fresh {efl : EWellformed.EEnvFlags} kn Σ deps : + EWellformed.wf_glob Σ -> + KernameSet.In kn (global_deps Σ deps) -> + EGlobalEnv.fresh_global kn Σ -> + KernameSet.In kn deps. +Proof. + induction Σ in deps |- *. + - now cbn. + - intros wf. destruct a as [kn' d]; cbn. depelim wf. + case: (knset_mem_spec kn' deps) => hin. + * rewrite global_deps_union KernameSet.union_spec. + intros [] fr. + ** depelim fr. now eapply IHΣ. + ** depelim fr. elimtype False. eapply IHΣ in H1; eauto. + destruct d as [[[]]|] eqn:eqd; cbn in H. + + cbn in H1. eapply (term_global_deps_fresh Σ) in H1; tea. cbn in H2. + eapply (Forall_map (fun x => x <> kn) fst) in fr. + now eapply PCUICWfUniverses.Forall_In in fr. + + cbn in H1; knset. + + cbn in H1; knset. + * intros hin' fr. depelim fr. now eapply IHΣ. +Qed. + +Lemma global_deps_empty Σ : global_deps Σ KernameSet.empty = KernameSet.empty. +Proof. + induction Σ; cbn; auto. + destruct a as [kn d]. + destruct (knset_mem_spec kn KernameSet.empty). + knset. auto. +Qed. + +Lemma filter_deps_filter {efl : EWellformed.EEnvFlags} deps Σ : + EWellformed.wf_glob Σ -> + (* (forall kn, KernameSet.In kn deps -> In kn (map fst Σ)) -> *) + filter_deps deps Σ = filter (flip KernameSet.mem (global_deps Σ deps) ∘ fst) Σ. +Proof. + induction Σ in deps |- *. + - now cbn. + - destruct a as [kn [[[]]|]]. + + cbn. unfold flip. + destruct (knset_mem_spec kn deps). + * case: (knset_mem_spec kn _). + ** intros hin' hwf. f_equal. depelim hwf. now eapply IHΣ. + ** intros nhin. + elim: nhin. + rewrite global_deps_union. + rewrite KernameSet.union_spec. left. + now eapply in_global_deps. + * intros hwf. + case: (knset_mem_spec kn _); intros hin. + ** elimtype False. + depelim hwf. + eapply in_global_deps_fresh in hin => //. + ** depelim hwf. rewrite -IHΣ => //. + + intros wf; depelim wf. + cbn. unfold flip. + * case: (knset_mem_spec kn _). + ** intros hin'. + case: (knset_mem_spec kn _) => hin''. + ++ f_equal. now eapply IHΣ. + ++ elim: hin''. + rewrite !global_deps_union. + rewrite KernameSet.union_spec. left. + now eapply in_global_deps. + ** intros hwf. + case: (knset_mem_spec kn _); intros hin. + *** elimtype False. + eapply in_global_deps_fresh in hin => //. + *** rewrite -IHΣ => //. + + intros wf; depelim wf. + cbn. unfold flip. + * case: (knset_mem_spec kn _). + ** intros hin'. + case: (knset_mem_spec kn _) => hin''. + ++ f_equal. rewrite IHΣ //. eapply filter_ext. + intros ?. unfold flip. rewrite global_deps_union /=. + rewrite global_deps_empty. + now rewrite KernameSetFact.union_b KernameSetFact.empty_b orb_false_r. + ++ elim: hin''. + rewrite !global_deps_union. + rewrite KernameSet.union_spec. left. + now eapply in_global_deps. + ** intros hwf. + case: (knset_mem_spec kn _); intros hin. + *** elimtype False. + eapply in_global_deps_fresh in hin => //. + *** rewrite -IHΣ => //. +Qed. + Lemma erase_global_declared_constructor X_type X ind c mind idecl cdecl deps decls normalization_in prf: forall Σ : global_env, abstract_env_rel X Σ -> declared_constructor Σ (ind, c) mind idecl cdecl -> KernameSet.In ind.(inductive_mind) deps -> - EGlobalEnv.declared_constructor (erase_global_decls X_type deps X decls normalization_in prf).1 (ind, c) + EGlobalEnv.declared_constructor (erase_global_deps X_type deps X decls normalization_in prf).1 (ind, c) (erase_mutual_inductive_body mind) (erase_one_inductive_body idecl) (EAst.mkConstructor cdecl.(cstr_name) cdecl.(cstr_arity)). Proof. @@ -2243,15 +2632,15 @@ Proof. cbn in *. split. split. - unshelve eapply declared_minductive_to_gen in H; eauto. red in H |- *. eapply (lookup_env_erase_decl _ _ _ _ _ _ _ (InductiveDecl mind)); eauto. - eapply in_deps_in_erase_global_decls; tea. + eapply in_deps_in_erase_global_deps; tea. - cbn. now eapply map_nth_error. - cbn. erewrite map_nth_error; eauto. Qed. Import EGlobalEnv. -Lemma erase_global_decls_fresh X_type kn deps X decls normalization_in heq : - let Σ' := erase_global_decls X_type deps X decls normalization_in heq in +Lemma erase_global_deps_fresh X_type kn deps X decls normalization_in heq : + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in PCUICAst.fresh_global kn decls -> fresh_global kn Σ'.1. Proof. @@ -2340,7 +2729,7 @@ Lemma erases_deps_erase (cf := config.extraction_checker_flags) let et := erase X_type X' Γ t wt in let deps := EAstUtils.term_global_deps et in forall Σ, (abstract_env_rel X Σ) -> - erases_deps Σ (erase_global_decls X_type deps X decls normalization_in prf).1 et. + erases_deps Σ (erase_global_deps X_type deps X decls normalization_in prf).1 et. Proof. intros et deps Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. @@ -2370,7 +2759,7 @@ Lemma erases_deps_erase_weaken (cf := config.extraction_checker_flags) let et := erase X_type X' Γ t wt in let tdeps := EAstUtils.term_global_deps et in forall Σ, (abstract_env_rel X Σ) -> - erases_deps Σ (erase_global_decls X_type (KernameSet.union deps tdeps) X decls normalization_in prf).1 et. + erases_deps Σ (erase_global_deps X_type (KernameSet.union deps tdeps) X decls normalization_in prf).1 et. Proof. intros et tdeps Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. @@ -2407,7 +2796,7 @@ Proof. Qed. Lemma erase_global_closed X_type X deps decls {normalization_in} prf : - let X' := erase_global_decls X_type deps X decls normalization_in prf in + let X' := erase_global_deps X_type deps X decls normalization_in prf in EGlobalEnv.closed_env X'.1. Proof. revert X normalization_in prf deps. @@ -2517,11 +2906,66 @@ Proof. now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wf'). Qed. -Lemma erase_wellformed (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt -(X' := abstract_make_wf_env_ext X univs wfΣ) -{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} -(t' := erase X_type X' Γ t wt) : -wellformed (erase_global_decls X_type (term_global_deps t') X decls normalization_in prf).1 #|Γ| t'. +Lemma erases_global_erase_global (efl := all_env_flags) {X_type X} Σ decls {normalization_in} prf : + Σ ∼ X -> + erases_global Σ (@erase_global X_type X decls normalization_in prf). +Proof. + intros h. pose proof (prf _ h). red. rewrite H. clear H. + induction decls in X, Σ, prf, normalization_in, h |- *. + - cbn. constructor. + - cbn. + set (Xpop := abstract_pop_decls X). + destruct (abstract_env_exists Xpop) as [[Σpop hpop]]. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ h hpop). + intros; eexists; now eapply prf. + destruct H as [? []]. + destruct a as [kn []]. + * constructor. cbn. + unfold erase_constant_decl. + set (Σd := {| universes := _ |}). + assert (Σd = Σpop). + { subst Σd. rewrite -H H0 H1. now destruct Σpop. } + subst Σd. + set (ext := abstract_make_wf_env_ext _ _ _). + pose proof (abstract_env_ext_exists ext) as [[Σ' wf']]. + epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ hpop wf'). + subst Σ'. + cbn. pose proof (abstract_env_wf _ hpop) as []. + eapply (erase_constant_body_correct _ _ _ _ (Σpop, cst_universes c)) => //. + now rewrite H2. rewrite H2. split => //. now exists []. + rewrite H0 H1. + now eapply IHdecls. + * pose proof (abstract_env_wf _ h) as [wfΣ]. + destruct wfΣ. rewrite (prf _ h) in o0. + depelim o0. depelim o1. + constructor. + eapply erases_mutual. eapply on_global_decl_d. + rewrite H0 H1. + now eapply IHdecls. +Qed. + +Lemma erase_global_wellformed (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + (t' := erase X_type X' Γ t wt) : + wellformed (@erase_global X_type X decls normalization_in prf) #|Γ| t'. +Proof. + cbn. + epose proof (@erases_erase X_type X' normalization_in' _ _ wt). + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. + pose proof (abstract_env_ext_wf _ wf') as [?]. + eapply (erases_wellformed (wt _ wf')) in H; eauto; tea. + eapply erases_global_all_deps. apply X0. + epose proof (abstract_make_wf_env_ext_correct _ _ wfΣ _ _ wf wf'). subst Σ'. + now eapply erases_global_erase_global. +Qed. + +Lemma erase_wellformed_deps (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + (t' := erase X_type X' Γ t wt) : + wellformed (erase_global_deps X_type (term_global_deps t') X decls normalization_in prf).1 #|Γ| t'. Proof. cbn. epose proof (@erases_deps_erase X_type X univs wfΣ decls normalization_in prf _ Γ t wt). @@ -2543,7 +2987,7 @@ Lemma erase_wellformed_weaken (efl := all_env_flags) {X_type X} decls {normaliza {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} deps: let t' := erase X_type X' Γ t wt in - wellformed (erase_global_decls X_type (KernameSet.union deps (term_global_deps t')) X decls normalization_in prf).1 #|Γ| t'. + wellformed (erase_global_deps X_type (KernameSet.union deps (term_global_deps t')) X decls normalization_in prf).1 #|Γ| t'. Proof. set (t' := erase _ _ _ _ _). cbn. epose proof (@erases_deps_erase_weaken _ X univs wfΣ decls _ prf _ Γ t wt deps). @@ -2569,7 +3013,7 @@ Lemma erase_constant_body_correct'' {X_type X} {cb} {decls normalization_in prf} forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * - wellformed (efl:=all_env_flags) (erase_global_decls X_type (KernameSet.union deps (term_global_deps body)) X decls normalization_in prf).1 0 body ∥. + wellformed (efl:=all_env_flags) (erase_global_deps X_type (KernameSet.union deps (term_global_deps body)) X decls normalization_in prf).1 0 body ∥. Proof. intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. destruct cb as [name [bod|] udecl]; simpl. @@ -2595,7 +3039,7 @@ Lemma erase_global_cst_decl_wf_glob X_type X deps decls normalization_in heq : let X' := abstract_make_wf_env_ext X (cst_universes cb) wfΣ in forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, let ecb := erase_constant_body X_type X' cb hcb in - let Σ' := erase_global_decls X_type (KernameSet.union deps ecb.2) X decls normalization_in heq in + let Σ' := erase_global_deps X_type (KernameSet.union deps ecb.2) X decls normalization_in heq in (@wf_global_decl all_env_flags Σ'.1 (EAst.ConstantDecl ecb.1) : Prop). Proof. intros cb wfΣ hcb X' normalization_in' ecb Σ'. @@ -2611,11 +3055,11 @@ Qed. Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls normalization_in kn m} heq : (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> let m' := erase_mutual_inductive_body m in - let Σ' := erase_global_decls X_type deps X decls normalization_in heq in + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in @wf_global_decl all_env_flags Σ'.1 (EAst.InductiveDecl m'). Proof. set (m' := erase_mutual_inductive_body m). - set (Σ' := erase_global_decls _ _ _ _ _ _). simpl. + set (Σ' := erase_global_deps _ _ _ _ _ _). simpl. intros oni. pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. pose proof (abstract_env_wf _ wf) as [wfΣ]. @@ -2625,8 +3069,8 @@ Proof. rewrite -(heq _ wf). now destruct Σ. Qed. -Lemma erase_global_decls_wf_glob X_type X deps decls normalization_in heq : - let Σ' := erase_global_decls X_type deps X decls normalization_in heq in +Lemma erase_global_deps_wf_glob X_type X deps decls normalization_in heq : + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in @wf_glob all_env_flags Σ'.1. Proof. cbn. @@ -2640,7 +3084,105 @@ Proof. epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. + constructor. eapply IHdecls => //; eauto. eapply erase_global_cst_decl_wf_glob; auto. - eapply erase_global_decls_fresh; auto. + eapply erase_global_deps_fresh; auto. + destruct wfΣ. destruct wfΣpop. + rewrite (heq _ wf) in o0. depelim o0. now destruct o3. + + cbn. eapply IHdecls; eauto. + + constructor. eapply IHdecls; eauto. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. destruct o0. + eapply (erase_global_ind_decl_wf_glob (kn:=kn)); tea. + intros. rewrite (abstract_env_irr _ H wfpop). + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. + {intros; now eexists. } + destruct Σpop, Σ; cbn in *. now subst. + eapply erase_global_deps_fresh. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. now destruct o0. + + eapply IHdecls; eauto. +Qed. + +Lemma erase_constant_body_correct_glob {X_type X} {cb} {decls normalization_in prf} {univs wfΣ} + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + {onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} : + EAst.cst_body (fst (erase_constant_body X_type X' cb onc)) = Some body -> + forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> + ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * + (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * + wellformed (efl:=all_env_flags) (@erase_global X_type X decls normalization_in prf) 0 body ∥. +Proof. + intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. + destruct cb as [name [bod|] udecl]; simpl. + simpl in H. noconf H. + set (obl :=(erase_constant_body_obligation_1 X_type X' + {| + cst_type := name; + cst_body := Some bod; + cst_universes := udecl |} onc bod eq_refl)). clearbody obl. + destruct (obl _ wfΣ'). sq. + have er : (Σ, univs);;; [] |- bod ⇝ℇ erase X_type X' [] bod obl. + { eapply (erases_erase (X:=X')). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + } + exists bod, A; intuition auto. + now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply (erase_global_wellformed decls _ _ _ (Γ := [])). + now simpl in H. +Qed. + +Lemma erase_global_cst_wf_glob X_type X decls normalization_in heq : + forall cb wfΣ hcb, + let X' := abstract_make_wf_env_ext X (cst_universes cb) wfΣ in + forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, + let ecb := erase_constant_body X_type X' cb hcb in + let Σ' := @erase_global X_type X decls normalization_in heq in + (@wf_global_decl all_env_flags Σ' (EAst.ConstantDecl ecb.1) : Prop). +Proof. + intros cb wfΣ hcb X' normalization_in' ecb Σ'. + unfold wf_global_decl. cbn. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. + destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. + destruct EAst.cst_body eqn:hb => /= //. + eapply (erase_constant_body_correct'') in hb; eauto. + destruct hb as [[t0 [T [[] ?]]]]. rewrite e in i. exact i. +Qed. + +Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls normalization_in kn m} heq : + (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> + let m' := erase_mutual_inductive_body m in + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in + @wf_global_decl all_env_flags Σ'.1 (EAst.InductiveDecl m'). +Proof. + set (m' := erase_mutual_inductive_body m). + set (Σ' := erase_global_deps _ _ _ _ _ _). simpl. + intros oni. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_wf _ wf) as [wfΣ]. + assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). + { eapply (erases_mutual (mdecl:=kn)); tea. } + eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ'.1)) in H; tea. + rewrite -(heq _ wf). now destruct Σ. +Qed. + +Lemma erase_global_wf_glob X_type X decls normalization_in heq : + let Σ' := @erase_global X_type X decls normalization_in heq in + @wf_glob all_env_flags Σ'. +Proof. + cbn. + pose proof (abstract_env_exists X) as [[Σ wf]]. + pose proof (abstract_env_wf _ wf) as [wfΣ]. + revert X Σ wf wfΣ normalization_in heq. + induction decls; [cbn; auto|]. + { intros. constructor. } + intros. destruct a as [kn []]; simpl; set (Xpop := abstract_pop_decls X); + try set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); + epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; + pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. + + constructor. eapply IHdecls => //; eauto. + eapply erase_global_cst_decl_wf_glob; auto. + eapply erase_global_deps_fresh; auto. destruct wfΣ. destruct wfΣpop. rewrite (heq _ wf) in o0. depelim o0. now destruct o3. + cbn. eapply IHdecls; eauto. @@ -2652,15 +3194,99 @@ Proof. unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. {intros; now eexists. } destruct Σpop, Σ; cbn in *. now subst. - eapply erase_global_decls_fresh. + eapply erase_global_deps_fresh. destruct wfΣ as [[onu ond]]. rewrite (heq _ wf) in o. depelim o. now destruct o0. + eapply IHdecls; eauto. Qed. + +Lemma extends_cons d Σ Σ' : extends Σ Σ' -> extends (d :: Σ) (d :: Σ'). +Proof. + intros ext kn decl. + cbn. + case: (eqb_spec kn d.1). + - now intros -> [= <-]. + - intros hin. apply ext. +Qed. + +Lemma extends_fresh Σ Σ' kn d : + fresh_global kn Σ' -> + extends Σ Σ' -> + extends Σ ((kn, d) :: Σ'). +Proof. + intros fr ext. + intros kn' decl hl. + cbn. destruct (eqb_spec kn' kn) => //. subst. + eapply ext in hl. now eapply lookup_env_Some_fresh in hl. + now eapply ext. +Qed. + +Lemma Forall_filter {A} {P} f l : @Forall A P l -> Forall P (filter f l). +Proof. + induction 1; try econstructor; auto. + cbn. case E: (f x) => //. now constructor. +Qed. + +Lemma extends_filter_impl {efl : EEnvFlags} (f f' : kername * EAst.global_decl -> bool) Σ : + (forall x, f x -> f' x) -> + wf_glob Σ -> + extends (filter f Σ) (filter f' Σ). +Proof. + intros hf; induction Σ; cbn; auto. + - red; auto. + - intros wf; depelim wf. + case E: (f _); auto. rewrite (hf _ E). + now eapply extends_cons. + case E': (f' _); auto. + eapply extends_fresh. now eapply Forall_filter. + auto. +Qed. + +Lemma extends_filter {efl : EEnvFlags} (f : kername * EAst.global_decl -> bool) Σ : + wf_glob Σ -> + extends (filter f Σ) Σ. +Proof. + intros wf hf; induction Σ; cbn; auto. + intros decl. depelim wf. cbn in *. + case E: (f _); auto; cbn. + case (eqb_spec hf kn) => //. + - intros hd. now eapply IHΣ. + - intros hl; eapply IHΣ in hl => //. rewrite hl. + case (eqb_spec hf kn) => heq. + subst. now eapply lookup_env_Some_fresh in hl. + reflexivity. +Qed. + +Lemma erase_global_deps_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X:X_type.π1) ext wfX {normalization_in} decls nin prf Γ t wt v wv : + let Xext := abstract_make_wf_env_ext X ext wfX in + let t' := erase X_type Xext (normalization_in := normalization_in) Γ t wt in + let v' := erase X_type Xext (normalization_in := normalization_in) Γ v wv in + let eg := erase_global_deps X_type (term_global_deps t') X decls nin prf in + let eg' := erase_global_deps X_type (term_global_deps v') X decls nin prf in + eg.1 ⊢ t' ⇓ v' -> EGlobalEnv.extends eg'.1 eg.1. +Proof. + intros. + move: (erase_global_deps_wf_glob X_type X (term_global_deps t') decls nin prf). + subst eg eg'. + rewrite -!erase_global_deps. + assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls nin prf)). + { admit. } + rewrite !(filter_deps_filter (efl := all_env_flags)) //. + cbn. + intros wf. + eapply extends_filter_impl; tea. unfold flip in *. + intros [kn d]; cbn. clear d. + rewrite /is_true !KernameSet.mem_spec. revert kn. + eapply EWcbvEval.weakening_eval_env in H. 2:exact wfer. + now eapply eval_global_deps in H. + rewrite -!erase_global_deps (filter_deps_filter (efl := all_env_flags)) //. + now eapply extends_filter. +Qed. + Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {deps deps' decls normalization_in prf} : KernameSet.Subset deps deps' -> - EExtends.global_subset (erase_global_decls X_type deps X decls normalization_in prf).1 (erase_global_decls X_type deps' X decls normalization_in prf).1. + EExtends.global_subset (erase_global_deps X_type deps X decls normalization_in prf).1 (erase_global_deps X_type deps' X decls normalization_in prf).1. Proof. revert deps deps' X normalization_in prf. induction decls. cbn => //. @@ -2669,10 +3295,10 @@ Proof. destruct a as [kn' []]; cbn; ( set (decl := E.ConstantDecl _) || set (decl := E.InductiveDecl _)); hidebody decl; - set (eg := erase_global_decls _ _ _ _ _ _); hidebody eg; - set (eg' := erase_global_decls _ _ _ _ _ _); hidebody eg'; - try (set (eg'' := erase_global_decls _ _ _ _ _ _); hidebody eg''); - try (set (eg''' := erase_global_decls _ _ _ _ _ _); hidebody eg'''). + set (eg := erase_global_deps _ _ _ _ _ _); hidebody eg; + set (eg' := erase_global_deps _ _ _ _ _ _); hidebody eg'; + try (set (eg'' := erase_global_deps _ _ _ _ _ _); hidebody eg''); + try (set (eg''' := erase_global_deps _ _ _ _ _ _); hidebody eg'''). { destruct (KernameSet.mem) eqn:knm => /=. + eapply KernameSet.mem_spec, sub, KernameSet.mem_spec in knm. rewrite knm. apply EExtends.global_subset_cons. eapply IHdecls; eauto. @@ -2681,15 +3307,15 @@ Proof. right => //. + destruct (KernameSet.mem kn' deps') eqn:eq'. eapply EExtends.global_subset_cons_right; eauto. - eapply erase_global_decls_wf_glob. + eapply erase_global_deps_wf_glob. unfold decl. unfold hidebody. - constructor. eapply erase_global_decls_wf_glob. + constructor. eapply erase_global_deps_wf_glob. eapply erase_global_cst_decl_wf_glob. - eapply erase_global_decls_fresh => //. + eapply erase_global_deps_fresh => //. pose proof (abstract_env_wf _ wf) as [wfΣ]. depelim wfΣ. rewrite (prf _ wf) in o0. clear - o0. depelim o0. now destruct o. unfold eg', eg'', hidebody. - erewrite erase_global_decls_irr. + erewrite erase_global_deps_irr. eapply IHdecls. intros x hin. eapply KernameSet.union_spec. left. now eapply sub. @@ -2698,8 +3324,8 @@ Proof. + eapply KernameSet.mem_spec, sub, KernameSet.mem_spec in knm. rewrite knm. apply EExtends.global_subset_cons. eapply IHdecls => //. + destruct (KernameSet.mem kn' deps') eqn:eq'. - eapply EExtends.global_subset_cons_right. eapply erase_global_decls_wf_glob. - constructor. eapply erase_global_decls_wf_glob. + eapply EExtends.global_subset_cons_right. eapply erase_global_deps_wf_glob. + constructor. eapply erase_global_deps_wf_glob. pose proof (abstract_env_wf _ wf) as [wfΣ]. pose proof (prf _ wf) as prf'. eapply (erase_global_ind_decl_wf_glob (kn:=kn')). @@ -2709,20 +3335,20 @@ Proof. destruct Σ, Σ0. cbn in *. rewrite prf' in wfΣ. depelim wfΣ. cbn in *. rewrite <- H1, H0, <- H2. depelim o0. now destruct o1. - eapply erase_global_decls_fresh => //. + eapply erase_global_deps_fresh => //. pose proof (abstract_env_wf _ wf) as [wfΣ]. pose proof (prf _ wf) as prf'. destruct Σ. cbn in *. rewrite prf' in wfΣ. clear -wfΣ. destruct wfΣ. cbn in *. depelim o0. now destruct o1. - unfold eg'', hidebody. erewrite erase_global_decls_irr. + unfold eg'', hidebody. erewrite erase_global_deps_irr. eapply IHdecls. intros x hin. now eapply sub. eapply IHdecls => //. } Qed. Lemma expanded_weakening_global X_type X deps deps' decls normalization_in prf Γ t : KernameSet.Subset deps deps' -> - expanded (erase_global_decls X_type deps X decls normalization_in prf).1 Γ t -> - expanded (erase_global_decls X_type deps' X decls normalization_in prf).1 Γ t. + expanded (erase_global_deps X_type deps X decls normalization_in prf).1 Γ t -> + expanded (erase_global_deps X_type deps' X decls normalization_in prf).1 Γ t. Proof. intros hs. eapply expanded_ind; intros; try solve [econstructor; eauto]. @@ -2741,7 +3367,7 @@ Lemma expanded_erase (cf := config.extraction_checker_flags) forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, let et := (erase X_type X' [] t wtp) in let deps := EAstUtils.term_global_deps et in - expanded (erase_global_decls X_type deps X decls normalization_in prf).1 [] et. + expanded (erase_global_deps X_type deps X decls normalization_in prf).1 [] et. Proof. intros Σ wf hexp X' normalization_in'. pose proof (abstract_env_wf _ wf) as [wf']. @@ -2757,7 +3383,7 @@ Lemma expanded_erase_global (cf := config.extraction_checker_flags) deps {X_type X decls normalization_in prf} : forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded_global_env Σ -> - expanded_global_env (erase_global_decls X_type deps X decls normalization_in prf).1. + expanded_global_env (erase_global_deps X_type deps X decls normalization_in prf).1. Proof. intros Σ wf etaΣ. pose proof (prf _ wf). destruct Σ as [univ decls']. @@ -2808,7 +3434,7 @@ Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, erase X_type Xext [] t wt = t' -> KernameSet.subset (term_global_deps t') deps -> - erase_global_decls X_type deps X decls normalization_in prf = Σ' -> + erase_global_deps X_type deps X decls normalization_in prf = Σ' -> forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> (forall Σ : global_env, abstract_env_rel X Σ -> PCUICWcbvEval.eval Σ t v) -> @@ -2834,7 +3460,7 @@ Lemma erase_eval_to_box_eager (wfl := Ee.default_wcbv_flags) forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, erase X_type Xext [] t wt = t' -> KernameSet.subset (term_global_deps t') deps -> - erase_global_decls X_type deps X decls normalization_in prf = Σ' -> + erase_global_deps X_type deps X decls normalization_in prf = Σ' -> forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> (forall Σ : global_env, abstract_env_rel X Σ -> PCUICWcbvEval.eval Σ t v) -> @@ -2941,7 +3567,7 @@ forall Σ, abstract_env_ext_rel Xext Σ -> @firstorder_ind Σ (firstorder_env Σ) i -> erase X_type Xext [] t wt = t' -> KernameSet.subset (term_global_deps t') deps -> - erase_global_decls X_type deps X decls normalization_in prf = Σ' -> + erase_global_deps X_type deps X decls normalization_in prf = Σ' -> red Σ [] t v -> ¬ { t' & Σ ;;; [] |- v ⇝ t'} -> forall wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. @@ -2970,7 +3596,7 @@ forall Σ, abstract_env_ext_rel Xext Σ -> axiom_free Σ -> Σ ;;; [] |- t : mkApps (tInd i u) args -> let t' := erase X_type Xext [] t wt in - let Σ' := erase_global_decls X_type deps X decls normalization_in prf in + let Σ' := erase_global_deps X_type deps X decls normalization_in prf in @firstorder_ind Σ (firstorder_env Σ) i -> KernameSet.subset (term_global_deps t') deps -> red Σ [] t v -> @@ -3012,7 +3638,7 @@ forall Σ (wfΣ : abstract_env_ext_rel Xext Σ) axiom_free Σ -> let t' := erase X_type Xext [] t (unique_type wfΣ wt) in let decls := declarations (fst Σ) in - let Σ' := erase_global_decls X_type (term_global_deps t') X decls + let Σ' := erase_global_deps X_type (term_global_deps t') X decls (fun _ _ _ _ _ _ _ => normalization_in _ _) (unique_decls univs wfext wfΣ) in @firstorder_ind Σ (firstorder_env Σ) i -> red Σ [] t v -> @@ -3025,7 +3651,7 @@ Proof. Qed. (* we use the [match] trick to get typeclass resolution to pick up the right instances without leaving any evidence in the resulting term, and without having to pass them manually everywhere *) -Notation NormalizationIn_erase_global_decls_fast X decls +Notation NormalizationIn_erase_global_deps_fast X decls := (match extraction_checker_flags, extraction_normalizing return _ with | cf, no => forall n, @@ -3086,9 +3712,9 @@ Qed. (* This version of global environment erasure keeps the same global environment throughout the whole erasure, while folding over the list of declarations. *) -Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) +Program Fixpoint erase_global_deps_fast (deps : KernameSet.t) X_type (X:X_type.π1) (decls : global_declarations) - {normalization_in : NormalizationIn_erase_global_decls_fast X decls} + {normalization_in : NormalizationIn_erase_global_deps_fast X decls} (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations * KernameSet.t := match decls with | [] => ([],deps) @@ -3098,17 +3724,17 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) let cb' := @erase_constant_body X_type Xext' normalization_in' cb _ in let deps := KernameSet.union deps (snd cb') in - let Σ' := erase_global_decls_fast deps X_type X decls _ in + let Σ' := erase_global_deps_fast deps X_type X decls _ in (((kn, E.ConstantDecl (fst cb')) :: Σ'.1), Σ'.2) else - erase_global_decls_fast deps X_type X decls _ + erase_global_deps_fast deps X_type X decls _ | (kn, InductiveDecl mib) :: decls => if KernameSet.mem kn deps then let mib' := erase_mutual_inductive_body mib in - let Σ' := erase_global_decls_fast deps X_type X decls _ in + let Σ' := erase_global_deps_fast deps X_type X decls _ in (((kn, E.InductiveDecl mib') :: Σ'.1), Σ'.2) - else erase_global_decls_fast deps X_type X decls _ + else erase_global_deps_fast deps X_type X decls _ end. Next Obligation. pose proof (abstract_env_wf _ H) as [?]. @@ -3236,13 +3862,13 @@ Definition same_principal_type {cf} (*Lemma erase_global_deps_suffix {deps} {Σ Σ' : wf_env} {decls hprefix hprefix'} : wf Σ -> wf Σ' -> universes Σ = universes Σ' -> - erase_global_decls_fast deps Σ decls hprefix = - erase_global_decls_fast deps Σ' decls hprefix'. + erase_global_deps_fast deps Σ decls hprefix = + erase_global_deps_fast deps Σ' decls hprefix'. Proof using Type. intros wfΣ wfΣ' equ. induction decls in deps, hprefix, hprefix' |- *; cbn => //. destruct a as [kn []]. - set (obl := (erase_global_decls_fast_obligation_1 Σ ((kn, ConstantDecl c) :: decls) + set (obl := (erase_global_deps_fast_obligation_1 Σ ((kn, ConstantDecl c) :: decls) hprefix kn c decls eq_refl)). clearbody obl. destruct obl. set (eb := erase_constant_body _ _ _). @@ -3251,7 +3877,7 @@ Proof using Type. { subst eb eb'. set (wfΣx := abstract_make_wf_env_ext _ _ _). set (wfΣ'x := abstract_make_wf_env_ext _ _ _). - set (obl' := erase_global_decls_fast_obligation_2 _ _ _ _ _ _ _). + set (obl' := erase_global_deps_fast_obligation_2 _ _ _ _ _ _ _). clearbody obl'. set (Σd := {| universes := Σ.(universes); declarations := decls |}). assert (wfΣd : wf Σd). @@ -3313,8 +3939,8 @@ Qed. Lemma erase_global_deps_fast_spec_gen {deps} {X_type X X'} {decls normalization_in normalization_in' hprefix hprefix'} : (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> - erase_global_decls_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = - erase_global_decls X_type deps X' decls normalization_in' hprefix'. + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = + erase_global_deps X_type deps X' decls normalization_in' hprefix'. Proof using Type. intros equ. induction decls in X, X', equ, deps, normalization_in, normalization_in', hprefix, hprefix' |- * => //. @@ -3327,12 +3953,12 @@ Proof using Type. destruct a as [kn []]. - cbn. unfold erase_constant_decl. - set (obl := (erase_global_decls_fast_obligation_1 X_type X ((kn, ConstantDecl c) :: decls) + set (obl := (erase_global_deps_fast_obligation_1 X_type X ((kn, ConstantDecl c) :: decls) _ hprefix kn c decls eq_refl)). set (eb := erase_constant_body _ _ _ _). set (eb' := erase_constant_body _ _ _ _). - set (eg := erase_global_decls _ _ _ _ _ _). - set (eg' := erase_global_decls _ _ _ _ _ _). + set (eg := erase_global_deps _ _ _ _ _ _). + set (eg' := erase_global_deps _ _ _ _ _ _). assert (eb = eb') as <-. { subst eb eb'. @@ -3378,18 +4004,18 @@ Proof using Type. Qed. Lemma erase_global_deps_fast_spec {deps} {X_type X} {decls normalization_in normalization_in' hprefix hprefix'} : - erase_global_decls_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = - erase_global_decls X_type deps X decls normalization_in' hprefix'. + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = + erase_global_deps X_type deps X decls normalization_in' hprefix'. Proof using Type. eapply erase_global_deps_fast_spec_gen; intros. rewrite (abstract_env_irr _ H H0); eauto. Qed. Definition erase_global_fast X_type deps X decls {normalization_in} (prf:forall Σ : global_env, abstract_env_rel X Σ -> declarations Σ = decls) := - erase_global_decls_fast deps X_type X decls (normalization_in:=normalization_in) (fun _ H => sq ([] ; prf _ H)). + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) (fun _ H => sq ([] ; prf _ H)). Lemma expanded_erase_global_fast (cf := config.extraction_checker_flags) deps - {X_type X decls normalization_in} {normalization_in':NormalizationIn_erase_global_decls X decls} {prf} : + {X_type X decls normalization_in} {normalization_in':NormalizationIn_erase_global_deps X decls} {prf} : forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded_global_env Σ -> expanded_global_env (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. @@ -3401,7 +4027,7 @@ Proof using Type. Qed. Lemma expanded_erase_fast (cf := config.extraction_checker_flags) - {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_decls X decls} univs wfΣ t wtp : + {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_deps X decls} univs wfΣ t wtp : forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded Σ [] t -> let X' := abstract_make_wf_env_ext X univs wfΣ in @@ -3420,16 +4046,16 @@ Proof using Type. Unshelve. all: eauto. Qed. -Lemma erase_global_fast_wf_glob X_type deps X decls normalization_in (normalization_in':NormalizationIn_erase_global_decls X decls) prf : +Lemma erase_global_fast_wf_glob X_type deps X decls normalization_in (normalization_in':NormalizationIn_erase_global_deps X decls) prf : @wf_glob all_env_flags (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. Proof using Type. unfold erase_global_fast; erewrite erase_global_deps_fast_spec. - eapply erase_global_decls_wf_glob. + eapply erase_global_deps_wf_glob. Unshelve. all: eauto. Qed. Lemma erase_wellformed_fast (efl := all_env_flags) - {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_decls X decls} univs wfΣ {Γ t} wt + {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_deps X decls} univs wfΣ {Γ t} wt (X' := abstract_make_wf_env_ext X univs wfΣ) {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} : let t' := erase X_type X' Γ t wt in @@ -3442,3 +4068,53 @@ Proof using Type. Qed. End EraseGlobalFast. + +#[local] Instance extends_trans : Transitive extends. +Proof. + Admitted. + +Lemma extends_erase_pcuic_program {wfl : EWcbvEval.WcbvFlags} X_type X decls nin pf : + forall Σ et et', + EWcbvEval.eval Σ et' et -> + Σ = (@erase_global_deps X_type (term_global_deps et') X decls nin pf).1 -> + EGlobalEnv.extends + (@erase_global_deps X_type (term_global_deps et) X decls nin pf).1 + (@erase_global_deps X_type (term_global_deps et') X decls nin pf).1. +Proof. + intros Σ et et'. + induction 1; intros eqΣ. + - cbn. eapply lookup_erase_global. KernameSetDecide.fsetdec. + - cbn in *. etransitivity; tea. + transitivity ((erase_global_deps X_type (term_global_deps (ECSubst.csubst a 0 f0)) X decls nin pf).1). + admit. admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - cbn. etransitivity; tea. + intros kn decl'. + intros hl. epose proof (lookup_env_erase_decl X_type X). in hl. + + + +Lemma extends_erase_pcuic_program X_type X t t' Γ : + (forall Σ, Σ ∼ X -> PCUICWcbvEval.eval Σ t' t) -> + forall Xext norm decls nin pf wt wt', + let et := @erase X_type Xext norm Γ t wt in + let et' := @erase X_type Xext norm Γ t' wt' in + EGlobalEnv.extends + (@erase_global_deps X_type (term_global_deps et) X decls nin pf).1 + (@erase_global_deps X_type (term_global_deps et') X decls nin pf).1. +Proof. + intros ev Xext norm decls nin pf wt wt' et et'. + intros kn decl. + pose proof (abstract_env_exists X) as [[Σ H]]. + specialize (ev _ H). + induction ev. + +Admitted. From 93395bfb481db230d41b4aca9239f09e081c7718 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Aug 2023 11:15:21 +0200 Subject: [PATCH 45/65] Finish the proofs in ErasureFunction --- erasure/theories/ErasureFunction.v | 947 +++++++++++++++++++---------- 1 file changed, 622 insertions(+), 325 deletions(-) diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 3d4b6710e..15f45b589 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -68,9 +68,589 @@ Section OnInductives. eapply PCUICInductives.on_minductive_wf_params_indices_inst; tea. Qed. - End OnInductives. +Infix "=kn" := KernameSet.Equal (at level 90). +Ltac knset := KernameSetDecide.fsetdec. + +Lemma term_global_deps_csubst a k b : + KernameSet.Subset (term_global_deps (ECSubst.csubst a k b)) + (KernameSet.union (term_global_deps a) (term_global_deps b)). +Proof. + induction b in k |- * using EInduction.term_forall_list_ind; cbn; try knset; eauto. + - destruct Nat.compare; knset. + - specialize (IHb1 k); specialize (IHb2 (S k)); knset. + - specialize (IHb1 k); specialize (IHb2 k); knset. + - destruct i. intros kn. rewrite knset_in_fold_left. + rewrite KernameSet.union_spec knset_in_fold_left. + intuition auto. destruct H0 as [a' [hin hin']]. + eapply in_map_iff in hin as [cs [<- hin]]. + eapply All_In in X as [X]; tea. specialize (X k). + specialize (X _ hin'). + eapply KernameSet.union_spec in X as []. knset. + right; right. now exists cs. + - destruct p. intros kn. + rewrite !KernameSet.union_spec !knset_in_fold_left. + specialize (IHb k kn). intuition auto. knset. + destruct H as [? []]. + eapply in_map_iff in H as [cs [<- hin]]. + eapply All_In in X as [X]; tea. specialize (X _ _ H0). intuition auto; try knset. + cbn in H0. apply KernameSet.union_spec in X as []; [knset|]. + right; right; right. now exists cs. + - specialize (IHb k). knset. + - intros kn; rewrite knset_in_fold_left !KernameSet.union_spec knset_in_fold_left. + intuition auto. + destruct H0 as [? []]. + eapply in_map_iff in H as [cs [<- hin]]. + eapply All_In in X as [X]; tea. specialize (X _ _ H0). intuition auto; try knset. + cbn in H0. apply KernameSet.union_spec in X as []; [knset|]. + right; right. now exists cs. + - intros kn; rewrite knset_in_fold_left !KernameSet.union_spec knset_in_fold_left. + intuition auto. + destruct H0 as [? []]. + eapply in_map_iff in H as [cs [<- hin]]. + eapply All_In in X as [X]; tea. specialize (X _ _ H0). intuition auto; try knset. + cbn in H0. apply KernameSet.union_spec in X as []; [knset|]. + right; right. now exists cs. +Qed. + + +Arguments KernameSet.mem : simpl never. + +Lemma lookup_env_In Σ kn d : EGlobalEnv.lookup_env Σ kn = Some d -> In kn (map fst Σ). +Proof. + induction Σ; cbn; auto. + - easy. + - destruct (eqb_spec kn a.1). + intros [= <-]. left; auto. + intros hl; right; auto. +Qed. + + +Notation terms_global_deps l := + (fold_left (fun (acc : KernameSet.t) (x : EAst.term) => + KernameSet.union (term_global_deps x) acc) l + KernameSet.empty). + +Lemma term_global_deps_fresh {efl : EWellformed.EEnvFlags} Σ k t : + EWellformed.wellformed Σ k t -> + forall kn, KernameSet.In kn (term_global_deps t) -> In kn (map fst Σ). +Proof. + induction t in k |- * using EInduction.term_forall_list_ind; intros; try (cbn in *; try knset; + rtoProp; intuition eauto). + all:try eapply KernameSet.union_spec in H0; intuition eauto. + - apply KernameSet.singleton_spec in H0. subst s. + destruct (EGlobalEnv.lookup_env Σ kn) eqn:E. + destruct g => //. destruct c => //. cbn in H1. + now eapply lookup_env_In in E. easy. + - destruct i. rewrite knset_in_fold_left in H0. + destruct H0. + apply KernameSet.singleton_spec in H0. subst kn. + destruct (EGlobalEnv.lookup_env Σ _) eqn:E. + destruct g => //. cbn in E. + now eapply lookup_env_In in E. easy. + destruct H0 as [a []]. + eapply All_In in X as [X]; tea. specialize (X k). + destruct EWellformed.cstr_as_blocks. move/andP: H1 => [_ wf]. + solve_all. eapply All_In in wf as [wf]; tea. now specialize (X wf kn). + destruct args => //. + - destruct p. rewrite KernameSet.union_spec knset_in_fold_left in H0. + destruct H0. + apply KernameSet.singleton_spec in H0. subst kn. cbn in *. + destruct (EGlobalEnv.lookup_env Σ _) eqn:E. + destruct g => //. + now eapply lookup_env_In in E. easy. clear H1. + destruct H0. now apply (IHt k H3). + destruct H0 as [a []]. + eapply All_In in X as [X]; tea. + solve_all. eapply All_In in H2 as [wf]; tea. now specialize (X _ wf kn). + - apply KernameSet.singleton_spec in H3. subst kn. cbn in *. + destruct (EGlobalEnv.lookup_env Σ _) eqn:E. + destruct g => //. + now eapply lookup_env_In in E. easy. + - rewrite knset_in_fold_left in H0; destruct H0; [knset|]. + destruct H0 as [a []]. + unfold EWellformed.wf_fix_gen in H1. move/andP: H1 => [_ hm]. solve_all. + eapply All_In in hm as [hm]; tea. intuition auto. + eapply (a0 (#|m| + k)) => //. + - rewrite knset_in_fold_left in H0; destruct H0; [knset|]. + destruct H0 as [a []]. + unfold EWellformed.wf_fix_gen in H1. move/andP: H1 => [_ hm]. solve_all. + eapply All_In in hm as [hm]; tea. intuition auto. + eapply (a0 (#|m| + k)) => //. +Qed. + +Lemma knset_mem_spec kn s : reflect (KernameSet.In kn s) (KernameSet.mem kn s). +Proof. + destruct (KernameSet.mem_spec s kn). + destruct (KernameSet.mem kn s). + - now constructor. + - constructor. intros hin. now apply H0 in hin. +Qed. + +Definition constant_decls_deps decl := + match decl with + | {| EAst.cst_body := Some b |} => term_global_deps b + | _ => KernameSet.empty + end. + +Definition global_decl_deps decl := + match decl with + | EAst.ConstantDecl cst => constant_decls_deps cst + | _ => KernameSet.empty + end. + +Fixpoint global_deps (Σ : EAst.global_declarations) deps := + match Σ with + | [] => deps + | (kn, decl) :: decls => + if KernameSet.mem kn deps then + global_deps decls + (KernameSet.union deps (global_decl_deps decl)) + else global_deps decls deps + end. + +Lemma global_deps_union Σ deps deps' : + global_deps Σ (KernameSet.union deps deps') =kn + KernameSet.union (global_deps Σ deps) (global_deps Σ deps'). +Proof. + induction Σ in deps, deps' |- *; auto. + - reflexivity. + - destruct a. cbn -[KernameSet.mem]. + destruct (knset_mem_spec k deps'). + * case: (knset_mem_spec k _). + move/KernameSet.union_spec => hin. + destruct hin. + eapply KernameSet.mem_spec in H. rewrite H. + rewrite !IHΣ. knset. + ** case: (knset_mem_spec k _); intros hin'; + rewrite !IHΣ; knset. + ** intros hin'. + case: (knset_mem_spec k _); intros hin''; + rewrite !IHΣ; knset. + * case: (knset_mem_spec k _); intros hin''. + case: (knset_mem_spec k _); intros hin'''. + rewrite !IHΣ. knset. + rewrite !IHΣ. knset. + case: (knset_mem_spec k _); intros hin'''. + rewrite !IHΣ. knset. + rewrite !IHΣ. knset. +Qed. + +Lemma in_global_deps deps Σ : + KernameSet.Subset deps (global_deps Σ deps). +Proof. + induction Σ => //. + destruct a as [kn [[[]]|]]; cbn; eauto; + case: (knset_mem_spec kn _); intros hin'''; + rewrite ?global_deps_union; + intros h hin; rewrite ?KernameSet.union_spec; try left; knset. +Qed. + +Lemma global_deps_subset Σ deps deps' : + KernameSet.Subset deps deps' -> + KernameSet.Subset (global_deps Σ deps) (global_deps Σ deps'). +Proof. + induction Σ in deps, deps' |- *. + - cbn. auto. + - destruct a; cbn. + intros sub. + case: (knset_mem_spec k deps) => hin. + eapply sub in hin. eapply KernameSet.mem_spec in hin. rewrite hin. + rewrite !global_deps_union. + specialize (IHΣ _ _ sub). knset. + case: (knset_mem_spec k deps') => hin'. + rewrite !global_deps_union. + specialize (IHΣ _ _ sub). knset. + now eapply IHΣ. +Qed. + +Lemma wf_global_decl_deps {efl : EWellformed.EEnvFlags} Σ d : + EWellformed.wf_global_decl Σ d -> + forall kn, KernameSet.In kn (global_decl_deps d) -> In kn (map fst Σ). +Proof. + intros wf kn hin. + destruct d as [[[]]|] => //; cbn in hin. + * eapply term_global_deps_fresh in hin. exact hin. cbn in wf; tea. + * knset. + * knset. +Qed. + +Lemma lookup_global_deps {efl : EWellformed.EEnvFlags} Σ kn decl : + EWellformed.wf_glob Σ -> + EGlobalEnv.lookup_env Σ kn = Some decl -> + forall kn, KernameSet.In kn (global_decl_deps decl) -> In kn (map fst Σ). +Proof. + induction 1 in kn, decl |- *. + - cbn => //. + - cbn. + case: (eqb_spec kn kn0) => heq. + subst kn0; intros [= <-]. + intros kn' hkn'. + * eapply wf_global_decl_deps in H0; tea. now right. + * intros hl kn' kin. + eapply IHwf_glob in hl; tea. now right. +Qed. + +Lemma fresh_global_In kn Σ : EGlobalEnv.fresh_global kn Σ <-> ~ In kn (map fst Σ). +Proof. + split. + - intros fr. + eapply (Forall_map (fun x => x <> kn) fst) in fr. + intros hin. + now eapply PCUICWfUniverses.Forall_In in fr; tea. + - intros nin. + red. eapply In_Forall. intros kn' hin <-. + eapply nin. now eapply (in_map fst). +Qed. + +Lemma global_deps_kn {fl :EWellformed.EEnvFlags} Σ kn decl : + EWellformed.wf_glob Σ -> + EGlobalEnv.declared_constant Σ kn decl -> + KernameSet.Subset (global_deps Σ (constant_decls_deps decl)) (global_deps Σ (KernameSet.singleton kn)). +Proof. + induction 1 in kn, decl |- *. + - cbn. unfold EGlobalEnv.declared_constant. cbn => //. + - cbn. unfold EGlobalEnv.declared_constant. cbn => //. + destruct (eqb_spec kn kn0). subst kn0. cbn. intros [= ->]. + + case: (knset_mem_spec kn _) => hin. + * eapply wf_global_decl_deps in H0; tea. + now eapply fresh_global_In in H1. + * case: (knset_mem_spec kn _) => hin'. + rewrite !global_deps_union. cbn. knset. + knset. + + + intros hl. + case: (knset_mem_spec kn0 _) => hin. + * elimtype False. + eapply lookup_global_deps in hl; tea. + now eapply fresh_global_In in H1. + * case: (knset_mem_spec kn0 _). + ** move/KernameSet.singleton_spec. intros <-. congruence. + ** intros hnin. now eapply IHwf_glob. +Qed. + +Lemma term_global_deps_mkApps f args : + term_global_deps (EAst.mkApps f args) =kn + KernameSet.union (term_global_deps f) (terms_global_deps args). +Proof. + induction args in f |- *. + - cbn; knset. + - cbn. rewrite IHargs. cbn. + intros kn. + rewrite !KernameSet.union_spec !knset_in_fold_left KernameSet.union_spec. + intuition auto. +Qed. + +From Coq Require Import Morphisms. + +#[export] Instance global_deps_proper : Proper (eq ==> KernameSet.Equal ==> KernameSet.Equal) global_deps. +Proof. + intros ? ? -> kns kns' eq. + induction y in kns, kns', eq |- *; cbn; auto; try knset. + destruct a. setoid_rewrite eq. destruct KernameSet.mem. rewrite IHy; [|reflexivity]. + now rewrite eq. now apply IHy. +Qed. + +#[export] Instance global_deps_proper_subset : Proper (eq ==> KernameSet.Subset ==> KernameSet.Subset) global_deps. +Proof. + intros ? ? -> kns kns' eq. + induction y in kns, kns', eq |- *; cbn; auto; try knset. + destruct a. destruct (knset_mem_spec k kns). eapply eq in i. + eapply KernameSet.mem_spec in i. rewrite i. eapply IHy. knset. + destruct (knset_mem_spec k kns'). specialize (IHy _ _ eq). + rewrite global_deps_union. knset. + eauto. +Qed. + +Lemma term_global_deps_substl defs body : + KernameSet.Subset (term_global_deps (ECSubst.substl defs body)) + (KernameSet.union (terms_global_deps defs) (term_global_deps body)). +Proof. + intros kn. rewrite KernameSet.union_spec. + unfold ECSubst.substl. + induction defs in body |- *; cbn; auto. + - intros hin. eapply IHdefs in hin as []; eauto. left. + rewrite knset_in_fold_left. right. + rewrite knset_in_fold_left in H. + intuition. knset. + rewrite knset_in_fold_left. + eapply term_global_deps_csubst in H. + intuition knset. +Qed. + +Lemma terms_global_deps_rev l : terms_global_deps (List.rev l) =kn terms_global_deps l. +Proof. + intros kn. + rewrite !knset_in_fold_left. intuition auto; try knset. + - destruct H0 as [x []]; right. exists x. now eapply In_rev in H. + - destruct H0 as [x []]; right. exists x. now eapply In_rev in H. +Qed. + +Lemma In_skipn {A} n (l : list A) : forall x, In x (skipn n l) -> In x l. +Proof. + induction l in n |- *; destruct n => //. + rewrite skipn_S. intros x hin; right; eauto. +Qed. + +Lemma terms_global_deps_skipn n l : KernameSet.Subset (terms_global_deps (List.skipn n l)) (terms_global_deps l). +Proof. + intros kn. + rewrite !knset_in_fold_left. intuition auto; try knset. + destruct H0 as [x []]; right. eapply In_skipn in H. now exists x. +Qed. + + +Lemma term_global_deps_iota_red pars args br : + KernameSet.Subset (term_global_deps (EGlobalEnv.iota_red pars args br)) + (KernameSet.union (terms_global_deps args) (term_global_deps br.2)). +Proof. + intros kn hin. + eapply term_global_deps_substl in hin. + rewrite !KernameSet.union_spec in hin *. intuition auto. left. + rewrite terms_global_deps_rev in H. + now apply terms_global_deps_skipn in H. +Qed. + +Lemma fold_left_eq {A} f acc l : + fold_left (fun acc (x : A) => KernameSet.union (f x) acc) l acc =kn + KernameSet.union (fold_left (fun acc x => KernameSet.union (f x) acc) l KernameSet.empty) acc. +Proof. + induction l in acc |- *; cbn. knset. + rewrite IHl. rewrite (IHl (KernameSet.union _ _)). knset. +Qed. + +Lemma term_global_deps_repeat t n : KernameSet.Subset (terms_global_deps (repeat t n)) (term_global_deps t). +Proof. + induction n; cbn; auto; try knset. + intros kn hin. + rewrite fold_left_eq in hin. + rewrite KernameSet.union_spec in hin. intuition auto. + rewrite KernameSet.union_spec in H; intuition auto. + knset. +Qed. + +Notation terms_global_deps_gen f l := + (fold_left + (fun (acc : KernameSet.t) (x : _) => + KernameSet.union (term_global_deps (f x)) acc) l KernameSet.empty). + +Lemma term_global_deps_fix_subst mfix : + KernameSet.Subset (terms_global_deps (EGlobalEnv.fix_subst mfix)) (terms_global_deps_gen EAst.dbody mfix). +Proof. + unfold EGlobalEnv.fix_subst. + induction #|mfix|; cbn. + - knset. + - rewrite fold_left_eq. + intros kn. rewrite KernameSet.union_spec. + intros []. + + now eapply IHn in H. + + knset. +Qed. + +Lemma term_global_deps_cunfold_fix mfix idx n f : + EGlobalEnv.cunfold_fix mfix idx = Some (n, f) -> + KernameSet.Subset (term_global_deps f) (terms_global_deps_gen EAst.dbody mfix). +Proof. + unfold EGlobalEnv.cunfold_fix. + destruct nth_error eqn:E => //. + intros [= <- <-]. + intros kn hin. + eapply term_global_deps_substl in hin. + rewrite KernameSet.union_spec in hin. + destruct hin. + now eapply term_global_deps_fix_subst in H. + eapply nth_error_In in E. + rewrite knset_in_fold_left. right. now exists d. +Qed. + +Lemma term_global_deps_cofix_subst mfix : + KernameSet.Subset (terms_global_deps (EGlobalEnv.cofix_subst mfix)) (terms_global_deps_gen EAst.dbody mfix). +Proof. + unfold EGlobalEnv.cofix_subst. + induction #|mfix|; cbn. + - knset. + - rewrite fold_left_eq. + intros kn. rewrite KernameSet.union_spec. + intros []. + + now eapply IHn in H. + + knset. +Qed. + +Lemma term_global_deps_cunfold_cofix mfix idx n f : + EGlobalEnv.cunfold_cofix mfix idx = Some (n, f) -> + KernameSet.Subset (term_global_deps f) (terms_global_deps_gen EAst.dbody mfix). +Proof. + unfold EGlobalEnv.cunfold_cofix. + destruct nth_error eqn:E => //. + intros [= <- <-]. + intros kn hin. + eapply term_global_deps_substl in hin. + rewrite KernameSet.union_spec in hin. + destruct hin. + now eapply term_global_deps_cofix_subst in H. + eapply nth_error_In in E. + rewrite knset_in_fold_left. right. now exists d. +Qed. + +Lemma global_deps_empty Σ : global_deps Σ KernameSet.empty = KernameSet.empty. +Proof. + induction Σ; cbn; auto. + destruct a as [kn d]. + destruct (knset_mem_spec kn KernameSet.empty). + knset. auto. +Qed. + +Lemma eval_global_deps {fl : EWcbvEval.WcbvFlags} {efl : EWellformed.EEnvFlags} Σ t t' : + EWellformed.wf_glob Σ -> + Σ ⊢ t ⇓ t' -> KernameSet.Subset (global_deps Σ (term_global_deps t')) (global_deps Σ (term_global_deps t)). +Proof. + intros wf. + induction 1 using EWcbvEval.eval_ind; cbn; rewrite ?global_deps_union; try knset. + - cbn in IHeval1. + epose proof (term_global_deps_csubst a' 0 b). + eapply (global_deps_subset Σ) in H2. + rewrite global_deps_union in H2. + knset. + - epose proof (term_global_deps_csubst b0' 0 b1). + eapply (global_deps_subset Σ) in H1. + rewrite global_deps_union in H1. + knset. + - rewrite term_global_deps_mkApps in IHeval1. + rewrite global_deps_union /= in IHeval1. destruct ind; cbn in *. + intros kn hr. + eapply IHeval2 in hr. + eapply global_deps_proper_subset in hr. + 3:eapply (term_global_deps_iota_red pars args br). 2:reflexivity. + rewrite global_deps_union KernameSet.union_spec in hr. + specialize (IHeval1 kn); rewrite !KernameSet.union_spec in IHeval1 *. + right. + destruct hr. + eapply global_deps_proper_subset. reflexivity. + intros kn'. rewrite knset_in_fold_left. intros; left; eauto. + now eapply IHeval1. + rewrite fold_left_eq global_deps_union KernameSet.union_spec. left. + eapply global_deps_proper_subset. reflexivity. + intros kn'. rewrite knset_in_fold_left. intros; right. + eapply nth_error_In in e2. exists br; split. auto. exact H2. + exact H1. + - intros kn hr. + eapply IHeval2 in hr. + eapply global_deps_proper_subset in hr; [|reflexivity|]. + 2:eapply term_global_deps_iota_red. + rewrite global_deps_union KernameSet.union_spec in hr. + rewrite KernameSet.union_spec. + right. + eapply global_deps_proper_subset. reflexivity. + intros kn'. rewrite fold_left_eq. intros h; exact h. + rewrite global_deps_union KernameSet.union_spec. + destruct hr. right. eapply IHeval1. cbn. destruct ind. + now rewrite fold_left_eq global_deps_union KernameSet.union_spec. + left. + eapply global_deps_proper_subset. reflexivity. + intros kn'. rewrite knset_in_fold_left. intros; right. + eapply nth_error_In in e2. exists br; split. auto. exact H2. + exact H1. + - intros kn hr. eapply IHeval2 in hr. + rewrite KernameSet.union_spec. + eapply global_deps_proper_subset in hr; [|reflexivity|]. + 2:eapply term_global_deps_substl. + right. rewrite fold_left_eq global_deps_union KernameSet.union_spec. + subst brs. cbn. left. + rewrite global_deps_union KernameSet.union_spec in hr. destruct hr. + eapply global_deps_proper_subset. reflexivity. 2:exact H1. + setoid_rewrite term_global_deps_repeat. cbn. knset. + now rewrite global_deps_union KernameSet.union_spec. + - intros kn hin. eapply IHeval3 in hin. + cbn in hin. rewrite global_deps_union KernameSet.union_spec in hin. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec in hin. + rewrite KernameSet.union_spec. intuition auto. + + left. eapply IHeval1. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec. left. + cbn. eapply term_global_deps_cunfold_fix in e1. + now setoid_rewrite e1 in H3. + + left. eapply IHeval1. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec. now right. + - intros kn hin. eapply IHeval3 in hin. + cbn in hin. rewrite global_deps_union KernameSet.union_spec in hin. + rewrite KernameSet.union_spec. intuition auto. + left. eapply IHeval1. cbn. + eapply term_global_deps_cunfold_fix in e0. + now setoid_rewrite e0 in H2. + - intros kn hin. eapply IHeval2 in hin. + cbn in hin. destruct ip. + rewrite global_deps_union KernameSet.union_spec in hin. + rewrite global_deps_union KernameSet.union_spec. intuition auto. right. + rewrite fold_left_eq. rewrite fold_left_eq in H1. + rewrite global_deps_union KernameSet.union_spec in H1. + rewrite global_deps_union KernameSet.union_spec. intuition auto. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec in H2. + right. eapply IHeval1. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec. intuition auto. + left. cbn. + eapply term_global_deps_cunfold_cofix in e0. + now setoid_rewrite e0 in H1. + - intros kn hin. eapply IHeval2 in hin. + cbn in hin. rewrite global_deps_union KernameSet.union_spec in hin. + rewrite KernameSet.union_spec. intuition auto. right. + eapply IHeval1. cbn. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec in H1. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec. + intuition auto. left. + eapply term_global_deps_cunfold_cofix in e0. + now setoid_rewrite e0 in H2. + - cbn. + epose proof (global_deps_kn Σ c decl wf isdecl). + unfold constant_decls_deps in H0. destruct decl => //. + cbn in e. subst cst_body0. knset. + - move=> kn /IHeval2 hin. + rewrite KernameSet.union_spec; right. eapply IHeval1. + rewrite term_global_deps_mkApps global_deps_union KernameSet.union_spec. + right. eapply nth_error_In in e3. + eapply global_deps_proper_subset. reflexivity. 2:exact hin. + intros k h. rewrite knset_in_fold_left. right. now exists a. + - eapply nth_error_In in e3. + move=> kn /IHeval2 hin. + rewrite KernameSet.union_spec. right; apply IHeval1; cbn. + destruct proj_ind. rewrite fold_left_eq. + rewrite global_deps_union KernameSet.union_spec. left. + eapply global_deps_proper_subset. reflexivity. + intros kn'. rewrite knset_in_fold_left. intros; right. 2:tea. + now exists a. + - destruct ind. + rewrite fold_left_eq. rewrite (fold_left_eq _ (KernameSet.singleton _)). + intros kn. rewrite !global_deps_union !KernameSet.union_spec. intuition auto. + left. clear -a iha H0. + induction a; auto. + move: H0. cbn. + rewrite fold_left_eq (fold_left_eq _ (KernameSet.union _ _)). + rewrite !global_deps_union !KernameSet.union_spec. + destruct iha as [sub ih]. specialize (IHa ih). intuition eauto. +Qed. + +Lemma in_global_deps_fresh {efl : EWellformed.EEnvFlags} kn Σ deps : + EWellformed.wf_glob Σ -> + KernameSet.In kn (global_deps Σ deps) -> + EGlobalEnv.fresh_global kn Σ -> + KernameSet.In kn deps. +Proof. + induction Σ in deps |- *. + - now cbn. + - intros wf. destruct a as [kn' d]; cbn. depelim wf. + case: (knset_mem_spec kn' deps) => hin. + * rewrite global_deps_union KernameSet.union_spec. + intros [] fr. + ** depelim fr. now eapply IHΣ. + ** depelim fr. elimtype False. eapply IHΣ in H1; eauto. + destruct d as [[[]]|] eqn:eqd; cbn in H. + + cbn in H1. eapply (term_global_deps_fresh Σ) in H1; tea. cbn in H2. + eapply (Forall_map (fun x => x <> kn) fst) in fr. + now eapply PCUICWfUniverses.Forall_In in fr. + + cbn in H1; knset. + + cbn in H1; knset. + * intros hin' fr. depelim fr. now eapply IHΣ. +Qed. + Local Existing Instance extraction_checker_flags. (* Definition wf_ext_wf Σ : wf_ext Σ -> wf Σ := fst. #[global] @@ -2048,14 +2628,14 @@ Proof. simpl. destruct d'. + destruct KernameSet.mem. cbn. destruct (eqb_spec kn kn') => //. - do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. + do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. - do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. + do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. + destruct KernameSet.mem. cbn. destruct (eqb_spec kn kn') => //. - do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. auto. - do 3 eexists. split; [|split;[reflexivity|]]. KernameSetDecide.fsetdec. auto. + do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. + do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. Qed. Lemma lookup_env_In_map_fst Σ kn decl : lookup_global Σ kn = Some decl -> In kn (map fst Σ). @@ -2074,7 +2654,7 @@ Proof. unfold erase_constant_decl. set (ec := erase_constant_body _ _ _ _). destruct cb. destruct cst_body0. - 2:{ subst ec; cbn. KernameSetDecide.fsetdec. } + 2:{ subst ec; cbn. knset. } intros hc. epose proof (erase_constant_body_correct' (@eq_refl _ (EAst.cst_body ec.1))). subst ec. @@ -2259,9 +2839,9 @@ Proof. case_eq (KernameSet.mem k deps). * cbn. intros hm. destruct (eqb_spec k kn). - ++ subst k. eapply IHdecls. KernameSetDecide.fsetdec. + ++ subst k. eapply IHdecls. knset. ++ eapply IHdecls. - KernameSetDecide.fsetdec. + knset. * intros hnin. eapply IHdecls; tea. + set (eg := erase_global_deps _ _ _ _ _ _); set (eg' := erase_global_deps _ _ _ _ _ _). @@ -2274,12 +2854,6 @@ Proof. * intros hnin. eapply IHdecls; tea. Qed. -Definition constant_decls_deps decl := - match decl with - | {| EAst.cst_body := Some b |} => term_global_deps b - | _ => KernameSet.empty - end. - Fixpoint filter_deps deps decls := match decls with | [] => [] @@ -2320,248 +2894,6 @@ Proof. eapply IHdecls. Qed. -Lemma knset_mem_spec kn s : reflect (KernameSet.In kn s) (KernameSet.mem kn s). -Proof. - destruct (KernameSet.mem_spec s kn). - destruct (KernameSet.mem kn s). - - now constructor. - - constructor. intros hin. now apply H0 in hin. -Qed. - -Definition global_decl_deps decl := - match decl with - | EAst.ConstantDecl cst => constant_decls_deps cst - | _ => KernameSet.empty - end. - -Fixpoint global_deps (Σ : EAst.global_declarations) deps := - match Σ with - | [] => deps - | (kn, decl) :: decls => - if KernameSet.mem kn deps then - global_deps decls - (KernameSet.union deps (global_decl_deps decl)) - else global_deps decls deps - end. - -Infix "=kn" := KernameSet.Equal (at level 90). - -Ltac knset := KernameSetDecide.fsetdec. - -Lemma global_deps_union Σ deps deps' : - global_deps Σ (KernameSet.union deps deps') =kn - KernameSet.union (global_deps Σ deps) (global_deps Σ deps'). -Proof. - induction Σ in deps, deps' |- *; auto. - - reflexivity. - - destruct a. cbn -[KernameSet.mem]. - destruct (knset_mem_spec k deps'). - * case: (knset_mem_spec k _). - move/KernameSet.union_spec => hin. - destruct hin. - eapply KernameSet.mem_spec in H. rewrite H. - rewrite !IHΣ. KernameSetDecide.fsetdec. - ** case: (knset_mem_spec k _); intros hin'; - rewrite !IHΣ; KernameSetDecide.fsetdec. - ** intros hin'. - case: (knset_mem_spec k _); intros hin''; - rewrite !IHΣ; KernameSetDecide.fsetdec. - * case: (knset_mem_spec k _); intros hin''. - case: (knset_mem_spec k _); intros hin'''. - rewrite !IHΣ. knset. - rewrite !IHΣ. knset. - case: (knset_mem_spec k _); intros hin'''. - rewrite !IHΣ. knset. - rewrite !IHΣ. knset. -Qed. - -Lemma in_global_deps deps Σ : - KernameSet.Subset deps (global_deps Σ deps). -Proof. - induction Σ => //. - destruct a as [kn [[[]]|]]; cbn; eauto; - case: (knset_mem_spec kn _); intros hin'''; - rewrite ?global_deps_union; - intros h hin; rewrite ?KernameSet.union_spec; try left; knset. -Qed. - -Lemma term_global_deps_csubst a k b : - KernameSet.Subset (term_global_deps (ECSubst.csubst a k b)) - (KernameSet.union (term_global_deps a) (term_global_deps b)). -Admitted. - -Lemma global_deps_subset Σ deps deps' : - KernameSet.Subset deps deps' -> - KernameSet.Subset (global_deps Σ deps) (global_deps Σ deps'). -Proof. - induction Σ in deps, deps' |- *. - - cbn. auto. - - destruct a; cbn. - intros sub. - case: (knset_mem_spec k deps) => hin. - eapply sub in hin. eapply KernameSet.mem_spec in hin. rewrite hin. - rewrite !global_deps_union. - specialize (IHΣ _ _ sub). knset. - case: (knset_mem_spec k deps') => hin'. - rewrite !global_deps_union. - specialize (IHΣ _ _ sub). knset. - now eapply IHΣ. -Qed. - -Arguments KernameSet.mem : simpl never. - -Lemma lookup_env_In Σ kn d : EGlobalEnv.lookup_env Σ kn = Some d -> In kn (map fst Σ). -Proof. - induction Σ; cbn; auto. - - easy. - - destruct (eqb_spec kn a.1). - intros [= <-]. left; auto. - intros hl; right; auto. -Qed. - - -Lemma term_global_deps_fresh {efl : EWellformed.EEnvFlags} Σ k t : - EWellformed.wellformed Σ k t -> - forall kn, KernameSet.In kn (term_global_deps t) -> In kn (map fst Σ). -Proof. - induction t in k |- * using EInduction.term_forall_list_ind; intros; try cbn in *; try knset; - rtoProp; intuition eauto. - all:try eapply KernameSet.union_spec in H0; intuition eauto. - - apply KernameSet.singleton_spec in H0. subst s. - destruct (EGlobalEnv.lookup_env Σ kn) eqn:E. - destruct g => //. destruct c => //. cbn in H1. - now eapply lookup_env_In in E. easy. - - admit. - - admit. - - admit. - - admit. - - admit. -Admitted. - -Lemma wf_global_decl_deps {efl : EWellformed.EEnvFlags} Σ d : - EWellformed.wf_global_decl Σ d -> - forall kn, KernameSet.In kn (global_decl_deps d) -> In kn (map fst Σ). -Proof. - intros wf kn hin. - destruct d as [[[]]|] => //; cbn in hin. - * eapply term_global_deps_fresh in hin. exact hin. cbn in wf; tea. - * knset. - * knset. -Qed. - -Lemma lookup_global_deps {efl : EWellformed.EEnvFlags} Σ kn decl : - EWellformed.wf_glob Σ -> - EGlobalEnv.lookup_env Σ kn = Some decl -> - forall kn, KernameSet.In kn (global_decl_deps decl) -> In kn (map fst Σ). -Proof. - induction 1 in kn, decl |- *. - - cbn => //. - - cbn. - case: (eqb_spec kn kn0) => heq. - subst kn0; intros [= <-]. - intros kn' hkn'. - * eapply wf_global_decl_deps in H0; tea. now right. - * intros hl kn' kin. - eapply IHwf_glob in hl; tea. now right. -Qed. - -Lemma fresh_global_In kn Σ : EGlobalEnv.fresh_global kn Σ <-> ~ In kn (map fst Σ). -Proof. - split. - - intros fr. - eapply (Forall_map (fun x => x <> kn) fst) in fr. - intros hin. - now eapply PCUICWfUniverses.Forall_In in fr; tea. - - intros nin. - red. eapply In_Forall. intros kn' hin <-. - eapply nin. now eapply (in_map fst). -Qed. - -Lemma global_deps_kn {fl :EWellformed.EEnvFlags} Σ kn decl : - EWellformed.wf_glob Σ -> - EGlobalEnv.declared_constant Σ kn decl -> - KernameSet.Subset (global_deps Σ (constant_decls_deps decl)) (global_deps Σ (KernameSet.singleton kn)). -Proof. - induction 1 in kn, decl |- *. - - cbn. unfold EGlobalEnv.declared_constant. cbn => //. - - cbn. unfold EGlobalEnv.declared_constant. cbn => //. - destruct (eqb_spec kn kn0). subst kn0. cbn. intros [= ->]. - + case: (knset_mem_spec kn _) => hin. - * eapply wf_global_decl_deps in H0; tea. - now eapply fresh_global_In in H1. - * case: (knset_mem_spec kn _) => hin'. - rewrite !global_deps_union. cbn. knset. - knset. - - + intros hl. - case: (knset_mem_spec kn0 _) => hin. - * elimtype False. - eapply lookup_global_deps in hl; tea. - now eapply fresh_global_In in H1. - * case: (knset_mem_spec kn0 _). - ** move/KernameSet.singleton_spec. intros <-. congruence. - ** intros hnin. now eapply IHwf_glob. -Qed. - -Lemma eval_global_deps {fl : EWcbvEval.WcbvFlags} {efl : EWellformed.EEnvFlags} Σ t t' : - EWellformed.wf_glob Σ -> - Σ ⊢ t ⇓ t' -> KernameSet.Subset (global_deps Σ (term_global_deps t')) (global_deps Σ (term_global_deps t)). -Proof. - intros wf. - induction 1 using EWcbvEval.eval_ind; cbn; rewrite ?global_deps_union; try knset. - - cbn in IHeval1. - epose proof (term_global_deps_csubst a' 0 b). - eapply (global_deps_subset Σ) in H2. - rewrite global_deps_union in H2. - knset. - - epose proof (term_global_deps_csubst b0' 0 b1). - eapply (global_deps_subset Σ) in H1. - rewrite global_deps_union in H1. - knset. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - cbn. - epose proof (global_deps_kn Σ c decl wf isdecl). - unfold constant_decls_deps in H0. destruct decl => //. - cbn in e. subst cst_body0. knset. - - admit. -Admitted. - -Lemma in_global_deps_fresh {efl : EWellformed.EEnvFlags} kn Σ deps : - EWellformed.wf_glob Σ -> - KernameSet.In kn (global_deps Σ deps) -> - EGlobalEnv.fresh_global kn Σ -> - KernameSet.In kn deps. -Proof. - induction Σ in deps |- *. - - now cbn. - - intros wf. destruct a as [kn' d]; cbn. depelim wf. - case: (knset_mem_spec kn' deps) => hin. - * rewrite global_deps_union KernameSet.union_spec. - intros [] fr. - ** depelim fr. now eapply IHΣ. - ** depelim fr. elimtype False. eapply IHΣ in H1; eauto. - destruct d as [[[]]|] eqn:eqd; cbn in H. - + cbn in H1. eapply (term_global_deps_fresh Σ) in H1; tea. cbn in H2. - eapply (Forall_map (fun x => x <> kn) fst) in fr. - now eapply PCUICWfUniverses.Forall_In in fr. - + cbn in H1; knset. - + cbn in H1; knset. - * intros hin' fr. depelim fr. now eapply IHΣ. -Qed. - -Lemma global_deps_empty Σ : global_deps Σ KernameSet.empty = KernameSet.empty. -Proof. - induction Σ; cbn; auto. - destruct a as [kn d]. - destruct (knset_mem_spec kn KernameSet.empty). - knset. auto. -Qed. Lemma filter_deps_filter {efl : EWellformed.EEnvFlags} deps Σ : EWellformed.wf_glob Σ -> @@ -2659,6 +2991,24 @@ Proof. + eapply IHdecls => //. Qed. +Lemma erase_global_fresh X_type kn X decls normalization_in heq : + let Σ' := @erase_global X_type X decls normalization_in heq in + PCUICAst.fresh_global kn decls -> + fresh_global kn Σ'. +Proof. + cbn. + revert X normalization_in heq. + induction decls; [cbn; auto|]. + - intros. red. constructor. + - destruct a as [kn' d]. intros. depelim H. + cbn in H, H0. cbn. + destruct d as []; simpl. + + cbn [EGlobalEnv.closed_env forallb]. cbn. + constructor => //. eapply IHdecls => //. + + constructor; auto. + eapply IHdecls => //. +Qed. + From MetaCoq.Erasure Require Import EEtaExpandedFix. Lemma erase_brs_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ p ts wt : @@ -3145,24 +3495,24 @@ Proof. pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. destruct EAst.cst_body eqn:hb => /= //. - eapply (erase_constant_body_correct'') in hb; eauto. - destruct hb as [[t0 [T [[] ?]]]]. rewrite e in i. exact i. + eapply (erase_constant_body_correct_glob) in hb; eauto. + destruct hb as [[t0 [T [[] ?]]]]. exact i. Qed. -Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls normalization_in kn m} heq : +Lemma erase_global_ind_decl_wf_glob' {X_type X} {decls normalization_in kn m} heq : (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> let m' := erase_mutual_inductive_body m in - let Σ' := erase_global_deps X_type deps X decls normalization_in heq in - @wf_global_decl all_env_flags Σ'.1 (EAst.InductiveDecl m'). + let Σ' := @erase_global X_type X decls normalization_in heq in + @wf_global_decl all_env_flags Σ' (EAst.InductiveDecl m'). Proof. set (m' := erase_mutual_inductive_body m). - set (Σ' := erase_global_deps _ _ _ _ _ _). simpl. + set (Σ' := erase_global _ _ _). simpl. intros oni. pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. pose proof (abstract_env_wf _ wf) as [wfΣ]. assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). { eapply (erases_mutual (mdecl:=kn)); tea. } - eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ'.1)) in H; tea. + eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ')) in H; tea. rewrite -(heq _ wf). now destruct Σ. Qed. @@ -3181,26 +3531,23 @@ Proof. epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. + constructor. eapply IHdecls => //; eauto. - eapply erase_global_cst_decl_wf_glob; auto. - eapply erase_global_deps_fresh; auto. + eapply erase_global_cst_wf_glob; auto. + eapply erase_global_fresh; auto. destruct wfΣ. destruct wfΣpop. rewrite (heq _ wf) in o0. depelim o0. now destruct o3. - + cbn. eapply IHdecls; eauto. + constructor. eapply IHdecls; eauto. destruct wfΣ as [[onu ond]]. rewrite (heq _ wf) in o. depelim o. destruct o0. - eapply (erase_global_ind_decl_wf_glob (kn:=kn)); tea. + eapply (erase_global_ind_decl_wf_glob' (kn:=kn)); tea. intros. rewrite (abstract_env_irr _ H wfpop). unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. - {intros; now eexists. } + { intros; now eexists. } destruct Σpop, Σ; cbn in *. now subst. - eapply erase_global_deps_fresh. + eapply erase_global_fresh. destruct wfΣ as [[onu ond]]. rewrite (heq _ wf) in o. depelim o. now destruct o0. - + eapply IHdecls; eauto. Qed. - Lemma extends_cons d Σ Σ' : extends Σ Σ' -> extends (d :: Σ) (d :: Σ'). Proof. intros ext kn decl. @@ -3269,9 +3616,9 @@ Proof. intros. move: (erase_global_deps_wf_glob X_type X (term_global_deps t') decls nin prf). subst eg eg'. - rewrite -!erase_global_deps. + rewrite !erase_global_deps_erase_global. assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls nin prf)). - { admit. } + { eapply erase_global_wf_glob. } rewrite !(filter_deps_filter (efl := all_env_flags)) //. cbn. intros wf. @@ -3280,7 +3627,7 @@ Proof. rewrite /is_true !KernameSet.mem_spec. revert kn. eapply EWcbvEval.weakening_eval_env in H. 2:exact wfer. now eapply eval_global_deps in H. - rewrite -!erase_global_deps (filter_deps_filter (efl := all_env_flags)) //. + rewrite !erase_global_deps_erase_global (filter_deps_filter (efl := all_env_flags)) //. now eapply extends_filter. Qed. @@ -4063,58 +4410,8 @@ Lemma erase_wellformed_fast (efl := all_env_flags) Proof using Type. intros. cbn. unfold erase_global_fast. erewrite erase_global_deps_fast_spec. - eapply erase_wellformed. + eapply erase_wellformed_deps. Unshelve. all: eauto. Qed. End EraseGlobalFast. - -#[local] Instance extends_trans : Transitive extends. -Proof. - Admitted. - -Lemma extends_erase_pcuic_program {wfl : EWcbvEval.WcbvFlags} X_type X decls nin pf : - forall Σ et et', - EWcbvEval.eval Σ et' et -> - Σ = (@erase_global_deps X_type (term_global_deps et') X decls nin pf).1 -> - EGlobalEnv.extends - (@erase_global_deps X_type (term_global_deps et) X decls nin pf).1 - (@erase_global_deps X_type (term_global_deps et') X decls nin pf).1. -Proof. - intros Σ et et'. - induction 1; intros eqΣ. - - cbn. eapply lookup_erase_global. KernameSetDecide.fsetdec. - - cbn in *. etransitivity; tea. - transitivity ((erase_global_deps X_type (term_global_deps (ECSubst.csubst a 0 f0)) X decls nin pf).1). - admit. admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - cbn. etransitivity; tea. - intros kn decl'. - intros hl. epose proof (lookup_env_erase_decl X_type X). in hl. - - - -Lemma extends_erase_pcuic_program X_type X t t' Γ : - (forall Σ, Σ ∼ X -> PCUICWcbvEval.eval Σ t' t) -> - forall Xext norm decls nin pf wt wt', - let et := @erase X_type Xext norm Γ t wt in - let et' := @erase X_type Xext norm Γ t' wt' in - EGlobalEnv.extends - (@erase_global_deps X_type (term_global_deps et) X decls nin pf).1 - (@erase_global_deps X_type (term_global_deps et') X decls nin pf).1. -Proof. - intros ev Xext norm decls nin pf wt wt' et et'. - intros kn decl. - pose proof (abstract_env_exists X) as [[Σ H]]. - specialize (ev _ H). - induction ev. - -Admitted. From 80055db424031c287f6cbf1cbc6efd3dd29e7a0a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 31 Aug 2023 12:08:47 +0200 Subject: [PATCH 46/65] Finished proof of firstorder correctness for erase_pcuic_program --- erasure-plugin/theories/ETransform.v | 30 +-- erasure-plugin/theories/Erasure.v | 2 +- erasure-plugin/theories/ErasureCorrectness.v | 71 +++++- erasure/theories/ErasureFunction.v | 244 +++++++++++++------ 4 files changed, 247 insertions(+), 100 deletions(-) diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index acef38110..c8c4584c1 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -24,11 +24,11 @@ Definition build_wf_env_from_env {cf : checker_flags} (Σ : global_env_map) (wf Notation NormalizationIn_erase_pcuic_program_1 p - := (@PCUICTyping.wf_ext config.extraction_checker_flags p.1 -> PCUICSN.NormalizationIn (cf:=config.extraction_checker_flags) (no:=PCUICSN.extraction_normalizing) p.1) + := (@PCUICTyping.wf_ext config.extraction_checker_flags p -> PCUICSN.NormalizationIn (cf:=config.extraction_checker_flags) (no:=PCUICSN.extraction_normalizing) p) (only parsing). Notation NormalizationIn_erase_pcuic_program_2 p - := (@PCUICTyping.wf_ext config.extraction_checker_flags p.1 -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn (cf:=config.extraction_checker_flags) (no:=PCUICSN.extraction_normalizing) p.1) + := (@PCUICTyping.wf_ext config.extraction_checker_flags p -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn (cf:=config.extraction_checker_flags) (no:=PCUICSN.extraction_normalizing) p) (only parsing). (* TODO: Where should this go? *) @@ -70,11 +70,11 @@ Qed. #[local] Lemma erase_pcuic_program_normalization_helper (cf := config.extraction_checker_flags) (no := PCUICSN.extraction_normalizing) - {guard : abstract_guard_impl} (p : pcuic_program) + {guard : abstract_guard_impl} (p : global_env_ext_map) {normalization_in : NormalizationIn_erase_pcuic_program_1 p} {normalization_in_adjust_universes : NormalizationIn_erase_pcuic_program_2 p} - (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p.1 ∥) - : (let wfe := build_wf_env_from_env p.1.1 (map_squash (PCUICTyping.wf_ext_wf _) (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p.1 ∥)) in + (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p ∥) + : (let wfe := build_wf_env_from_env p.1 (map_squash (PCUICTyping.wf_ext_wf _) (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p ∥)) in forall n : nat, n < #|PCUICAst.PCUICEnvironment.declarations p.1| -> forall kn cb pf, @@ -87,7 +87,7 @@ Qed. (@optimized_abstract_env_impl extraction_checker_flags _) wfe (PCUICAst.PCUICEnvironment.cst_universes cb) pf -> PCUICSN.NormalizationIn Σ) /\ - (let wfe := build_wf_env_from_env p.1.1 (map_squash (PCUICTyping.wf_ext_wf _) (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p.1 ∥)) in + (let wfe := build_wf_env_from_env p.1 (map_squash (PCUICTyping.wf_ext_wf _) (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p ∥)) in forall n : nat, n < #|PCUICAst.PCUICEnvironment.declarations p.1| -> let X' := @@ -138,8 +138,8 @@ Proof. Qed. Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_program) - {normalization_in : NormalizationIn_erase_pcuic_program_1 p} - {normalization_in_adjust_universes : NormalizationIn_erase_pcuic_program_2 p} + {normalization_in : NormalizationIn_erase_pcuic_program_1 p.1} + {normalization_in_adjust_universes : NormalizationIn_erase_pcuic_program_2 p.1} (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p.1 ∥) (wt : ∥ ∑ T, PCUICTyping.typing (H := config.extraction_checker_flags) p.1 [] p.2 T ∥) : eprogram_env := let wfe := build_wf_env_from_env p.1.1 (map_squash (PCUICTyping.wf_ext_wf _) wfΣ) in @@ -150,14 +150,14 @@ Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_ (EAstUtils.term_global_deps t) wfe (p.1.(PCUICAst.PCUICEnvironment.declarations)) _ in (EEnvMap.GlobalContextMap.make Σ'.1 _, t). -Next Obligation. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. Qed. +Next Obligation. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. Defined. Next Obligation. eapply wf_glob_fresh. eapply ErasureFunction.erase_global_fast_wf_glob. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. -Qed. +Defined. -Obligation Tactic := idtac. +Local Obligation Tactic := idtac. Import Extract. @@ -191,7 +191,7 @@ Proof. - eapply EEtaExpanded.isEtaExpFix_isEtaExp. now eapply EEtaExpandedFix.expanded_isEtaExp. Qed. -Obligation Tactic := try solve [ eauto ]. +Local Obligation Tactic := try solve [ eauto ]. Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t pcuic_program eprogram_env PCUICAst.term EAst.term eval_pcuic_program (eval_eprogram_env EWcbvEval.default_wcbv_flags) := @@ -199,8 +199,8 @@ Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t p pre p := ∥ wt_pcuic_program (cf := config.extraction_checker_flags) p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p - /\ NormalizationIn_erase_pcuic_program_1 p - /\ NormalizationIn_erase_pcuic_program_2 p ; + /\ NormalizationIn_erase_pcuic_program_1 p.1 + /\ NormalizationIn_erase_pcuic_program_2 p.1 ; transform p hp := let nhs := proj2 (proj2 hp) in @erase_program guard p (proj1 nhs) (proj2 nhs) (proj1 hp) ; post p := [/\ wf_eprogram_env all_env_flags p & EEtaExpandedFix.expanded_eprogram_env p]; @@ -316,7 +316,7 @@ Qed. End PCUICEnv. -Obligation Tactic := idtac. +#[local] Obligation Tactic := idtac. (** This transformation is the identity on terms but changes the evaluation relation to one where fixpoints are not guarded. It requires eta-expanded fixpoints and evaluation diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index b44821921..4467c1dae 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -23,7 +23,7 @@ Local Open Scope string_scope2. Import Transform. -Obligation Tactic := program_simpl. +Local Obligation Tactic := program_simpl. #[local] Existing Instance extraction_checker_flags. #[local] Existing Instance PCUICSN.extraction_normalizing. diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 437a1ab61..4558691a0 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -262,22 +262,69 @@ Proof. now eapply rebuild_wf_env_irr. Qed. -Lemma extends_erase_pcuic_program {guard : abstract_guard_impl} (Σ : global_env_ext_map) t t' nin nin' nin0 nin0' wf wf' ty ty' : - PCUICWcbvEval.eval Σ t' t -> - EGlobalEnv.extends - (@erase_pcuic_program guard (Σ, t) nin nin' wf ty).1 - (@erase_pcuic_program guard (Σ, t') nin0 nin0' wf' ty').1. +From MetaCoq.Erasure Require Import Erasure Extract ErasureFunction. +From MetaCoq.PCUIC Require Import PCUICTyping. + +Lemma extends_erase_pcuic_program (efl := EWcbvEval.default_wcbv_flags) {guard : abstract_guard_impl} (Σ : global_env_ext_map) t v nin nin' nin0 nin0' + wf wf' ty ty' i u args : + PCUICWcbvEval.eval Σ t v -> + axiom_free Σ -> + Σ ;;; [] |- t : PCUICAst.mkApps (PCUICAst.tInd i u) args -> + @PCUICFirstorder.firstorder_ind Σ (PCUICFirstorder.firstorder_env Σ) i -> + let pt := @erase_pcuic_program guard (Σ, t) nin0 nin0' wf' ty' in + let pv := @erase_pcuic_program guard (Σ, v) nin nin' wf ty in + EGlobalEnv.extends pv.1 pt.1 /\ ∥ eval pt.1 pt.2 pv.2 ∥. Proof. - intros ev. - cbn. + intros ev axf ht fo. + cbn -[erase_pcuic_program]. + unfold erase_pcuic_program. + set (prf0 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). + set (prf1 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). + set (prf2 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). + set (prf3 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env_ext) => _)). + set (prf4 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env_ext) => _)). + set (prf5 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env_ext) => _)). + set (prf6 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env_ext) => _)). + set (env' := build_wf_env_from_env _ _). + set (env := build_wf_env_from_env _ _). + set (X := PCUICWfEnv.abstract_make_wf_env_ext _ _ _). + set (X' := PCUICWfEnv.abstract_make_wf_env_ext _ _ _). unfold ErasureFunction.erase_global_fast. + set (prf7 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). set (et := ErasureFunction.erase _ _ _ _ _). set (et' := ErasureFunction.erase _ _ _ _ _). - erewrite ErasureFunction.erase_global_deps_fast_spec. - erewrite ErasureFunction.erase_global_deps_fast_spec. - epose proof ErasureFunction.erase_global_decls_irr. - intros kn decl. -Admitted. + destruct Σ as [Σ ext]. + cbn -[et et' PCUICWfEnv.abstract_make_wf_env_ext] in *. + unshelve (epose proof ErasureFunction.erase_global_deps_fast_erase_global_deps as [norm eq]; + erewrite eq). + { cbn. now intros ? ->. } + unshelve (epose proof ErasureFunction.erase_global_deps_fast_erase_global_deps as [norm' eq']; + erewrite eq'). + { cbn. now intros ? ->. } + set (prf := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). cbn in prf. + rewrite (ErasureFunction.erase_global_deps_irr optimized_abstract_env_impl (EAstUtils.term_global_deps et) env' env _ prf prf). + { cbn. now intros ? ? -> ->. } + clearbody prf0 prf1 prf2 prf3 prf4 prf5 prf6 prf7. + epose proof (ErasureFunction.erase_correct_strong optimized_abstract_env_impl (v:=v) env ext prf2 + (PCUICAst.PCUICEnvironment.declarations Σ) norm' prf prf6 X eq_refl axf ht fo). + pose proof wf as []. + forward H by (eapply Kernames.KernameSet.subset_spec; reflexivity). + forward H by unshelve (eapply PCUICClassification.wcbveval_red; tea). + forward H. { + intros [? hr]. + eapply PCUICNormalization.firstorder_value_irred; tea. cbn. + eapply PCUICFirstorder.firstorder_value_spec; tea. apply X0. constructor. + eapply PCUICClassification.subject_reduction_eval; tea. + eapply PCUICWcbvEval.eval_to_value; tea. } + destruct H as [wt' []]. + split => //. + eapply (ErasureFunction.erase_global_deps_eval optimized_abstract_env_impl env env' ext). + unshelve erewrite (ErasureFunction.erase_irrel_global_env (X_type:=optimized_abstract_env_impl) (t:=v)); tea. + red. intros. split; reflexivity. + sq. unfold et', et. + unshelve erewrite (ErasureFunction.erase_irrel_global_env (X_type:=optimized_abstract_env_impl) (t:=v)); tea. + red. intros. split; reflexivity. +Qed. Section pipeline_theorem. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 15f45b589..8313423d9 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -1706,37 +1706,73 @@ now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). Qed. Lemma erase_global_deps_irr - X_type deps (X:X_type.π1) decls - {normalization_in normalization_in' : NormalizationIn_erase_global_deps X decls} + X_type deps (X X':X_type.π1) decls + {normalization_in normalization_in'} prf prf' : + (forall Σ Σ', Σ ∼ X -> Σ' ∼ X' -> forall tag, primitive_constant Σ tag = primitive_constant Σ' tag) -> erase_global_deps deps X decls (normalization_in:=normalization_in) prf = - erase_global_deps deps X decls (normalization_in:=normalization_in') prf'. + erase_global_deps deps X' decls (normalization_in:=normalization_in') prf'. Proof. - revert X deps normalization_in normalization_in' prf prf'. + revert X X' deps normalization_in normalization_in' prf prf'. induction decls; eauto. intros. destruct a as [kn []]. - cbn. set (ec := erase_constant_decl _ _ _ _). set (ec' := erase_constant_decl _ _ _ _). + pose proof (abstract_env_exists X) as [[envX wfX]]. + pose proof (abstract_env_exists X') as [[envX' wfX']]. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[env wf]]. + pose proof (abstract_env_exists (abstract_pop_decls X')) as [[env' wf']]. + unshelve epose proof (abstract_pop_decls_correct _ _ _ _ _ wfX wf) as [Hd [Hu Hr]]. shelve. + { intros ? h. rewrite (prf _ h). now eexists. } + unshelve epose proof (abstract_pop_decls_correct _ _ _ _ _ wfX' wf') as [Hd' [Hu' Hr']]. shelve. + { intros ? h. rewrite (prf' _ h). now eexists. } assert (ec = ec') as <-. { subst ec ec'. unfold erase_constant_decl. erewrite erase_constant_body_irrel. reflexivity. - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[env wf]]. red. intros. - pose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H). pose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H0). + pose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wf' H1). split => //. { intros. - rewrite -(abstract_env_lookup_correct' _ _ H). - rewrite -(abstract_env_lookup_correct' _ _ H0). now rewrite H1 H2. } + rewrite -(abstract_env_lookup_correct' _ _ H0). + rewrite -(abstract_env_lookup_correct' _ _ H1). + move: H4 H5. rewrite /lookup_env H2 H3 /= Hd Hd'. congruence. } intros. - { rewrite (abstract_primitive_constant_correct _ _ _ H). - rewrite (abstract_primitive_constant_correct _ _ _ H0). - now rewrite H1 H2. } } + { rewrite (abstract_primitive_constant_correct _ _ _ H0). + rewrite (abstract_primitive_constant_correct _ _ _ H1). + specialize (H _ _ wfX wfX'). + rewrite H2 H3 /primitive_constant /= -Hr -Hr'. apply H. } } + assert ((forall Σ Σ' : global_env, + Σ ∼ abstract_pop_decls X -> Σ' ∼ abstract_pop_decls X' -> + forall tag : Primitive.prim_tag, primitive_constant Σ tag = primitive_constant Σ' tag)) . + { intros Σ Σ' h h' tag. + pose proof (abstract_env_irr _ wf h). subst env. + pose proof (abstract_env_irr _ wf' h'). subst env'. + specialize (H _ _ wfX wfX'). + rewrite /primitive_constant -Hr -Hr'. apply H. } + specialize (IHdecls (abstract_pop_decls X) (abstract_pop_decls X')). destruct KernameSet.mem; cbn. - f_equal; f_equal. f_equal; eapply IHdecls. - apply IHdecls. apply IHdecls. - - cbn. destruct KernameSet.mem; cbn. f_equal. f_equal. 1-2:f_equal. all:eapply IHdecls. + f_equal; f_equal. f_equal; now eapply IHdecls. + now apply IHdecls. now apply IHdecls. + - cbn. + pose proof (abstract_env_exists X) as [[envX wfX]]. + pose proof (abstract_env_exists X') as [[envX' wfX']]. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[env wf]]. + pose proof (abstract_env_exists (abstract_pop_decls X')) as [[env' wf']]. + unshelve epose proof (abstract_pop_decls_correct _ _ _ _ _ wfX wf) as [Hd [Hu Hr]]. shelve. + { intros ? h. rewrite (prf _ h). now eexists. } + unshelve epose proof (abstract_pop_decls_correct _ _ _ _ _ wfX' wf') as [Hd' [Hu' Hr']]. shelve. + { intros ? h. rewrite (prf' _ h). now eexists. } + assert ((forall Σ Σ' : global_env, + Σ ∼ abstract_pop_decls X -> Σ' ∼ abstract_pop_decls X' -> + forall tag : Primitive.prim_tag, primitive_constant Σ tag = primitive_constant Σ' tag)) . + { intros Σ Σ' h h' tag. + pose proof (abstract_env_irr _ wf h). subst env. + pose proof (abstract_env_irr _ wf' h'). subst env'. + specialize (H _ _ wfX wfX'). + rewrite /primitive_constant -Hr -Hr'. apply H. } + destruct KernameSet.mem; cbn. f_equal. f_equal. 1-2:f_equal. all:now eapply IHdecls. Qed. Definition global_erased_with_deps (Σ : global_env) (Σ' : EAst.global_declarations) kn := @@ -2867,7 +2903,7 @@ Fixpoint filter_deps deps decls := else filter_deps deps decls end. -Lemma erase_global_deps_erase_global {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X:X_type.π1) deps decls {normalization_in} prf : +Lemma erase_global_deps_erase_global (X_type : abstract_env_impl) (X:X_type.π1) deps decls {normalization_in} prf : (@erase_global_deps X_type deps X decls normalization_in prf).1 = filter_deps deps (@erase_global X_type X decls normalization_in prf). Proof. @@ -3605,10 +3641,11 @@ Proof. reflexivity. Qed. -Lemma erase_global_deps_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X:X_type.π1) ext wfX {normalization_in} decls nin prf Γ t wt v wv : +Lemma erase_global_deps_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X X':X_type.π1) ext wfX wfX' {normalization_in} {normalization_in'} decls nin prf Γ t wt v wv : let Xext := abstract_make_wf_env_ext X ext wfX in + let Xext' := abstract_make_wf_env_ext X' ext wfX' in let t' := erase X_type Xext (normalization_in := normalization_in) Γ t wt in - let v' := erase X_type Xext (normalization_in := normalization_in) Γ v wv in + let v' := erase X_type Xext' (normalization_in := normalization_in') Γ v wv in let eg := erase_global_deps X_type (term_global_deps t') X decls nin prf in let eg' := erase_global_deps X_type (term_global_deps v') X decls nin prf in eg.1 ⊢ t' ⇓ v' -> EGlobalEnv.extends eg'.1 eg.1. @@ -3635,61 +3672,16 @@ Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {de KernameSet.Subset deps deps' -> EExtends.global_subset (erase_global_deps X_type deps X decls normalization_in prf).1 (erase_global_deps X_type deps' X decls normalization_in prf).1. Proof. - revert deps deps' X normalization_in prf. - induction decls. cbn => //. - intros ? ? ? ? ? sub. - epose proof (abstract_env_exists X) as [[Σ wf]]. - destruct a as [kn' []]; cbn; - ( set (decl := E.ConstantDecl _) || - set (decl := E.InductiveDecl _)); hidebody decl; - set (eg := erase_global_deps _ _ _ _ _ _); hidebody eg; - set (eg' := erase_global_deps _ _ _ _ _ _); hidebody eg'; - try (set (eg'' := erase_global_deps _ _ _ _ _ _); hidebody eg''); - try (set (eg''' := erase_global_deps _ _ _ _ _ _); hidebody eg'''). - { destruct (KernameSet.mem) eqn:knm => /=. - + eapply KernameSet.mem_spec, sub, KernameSet.mem_spec in knm. rewrite knm. - apply EExtends.global_subset_cons. eapply IHdecls; eauto. - intros x hin. eapply KernameSet.union_spec in hin. - eapply KernameSet.union_spec. destruct hin. left. now eapply sub. - right => //. - + destruct (KernameSet.mem kn' deps') eqn:eq'. - eapply EExtends.global_subset_cons_right; eauto. - eapply erase_global_deps_wf_glob. - unfold decl. unfold hidebody. - constructor. eapply erase_global_deps_wf_glob. - eapply erase_global_cst_decl_wf_glob. - eapply erase_global_deps_fresh => //. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - depelim wfΣ. rewrite (prf _ wf) in o0. clear - o0. depelim o0. now destruct o. - unfold eg', eg'', hidebody. - erewrite erase_global_deps_irr. - eapply IHdecls. - intros x hin. - eapply KernameSet.union_spec. left. now eapply sub. - eapply IHdecls => //. } - { destruct (KernameSet.mem) eqn:knm => /=. - + eapply KernameSet.mem_spec, sub, KernameSet.mem_spec in knm. rewrite knm. - apply EExtends.global_subset_cons. eapply IHdecls => //. - + destruct (KernameSet.mem kn' deps') eqn:eq'. - eapply EExtends.global_subset_cons_right. eapply erase_global_deps_wf_glob. - constructor. eapply erase_global_deps_wf_glob. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - pose proof (prf _ wf) as prf'. - eapply (erase_global_ind_decl_wf_glob (kn:=kn')). - intros. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf H) as [? [? ?]]. - { now eexists. } - destruct Σ, Σ0. cbn in *. rewrite prf' in wfΣ. - depelim wfΣ. cbn in *. rewrite <- H1, H0, <- H2. - depelim o0. now destruct o1. - eapply erase_global_deps_fresh => //. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - pose proof (prf _ wf) as prf'. - destruct Σ. cbn in *. rewrite prf' in wfΣ. - clear -wfΣ. destruct wfΣ. cbn in *. depelim o0. now destruct o1. - unfold eg'', hidebody. erewrite erase_global_deps_irr. - eapply IHdecls. intros x hin. now eapply sub. - eapply IHdecls => //. } + intros sub. + rewrite !erase_global_deps_erase_global. + assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls normalization_in prf)). + { eapply erase_global_wf_glob. } + rewrite !(filter_deps_filter (efl := all_env_flags)) //. + eapply extends_filter_impl => //. 2:exact wfer. + unfold flip. + move=> x /KernameSet.mem_spec hin. + apply/KernameSet.mem_spec. + eapply global_deps_subset; tea. Qed. Lemma expanded_weakening_global X_type X deps deps' decls normalization_in prf Γ t : @@ -4358,6 +4350,114 @@ Proof using Type. rewrite (abstract_env_irr _ H H0); eauto. Qed. +Lemma cored_extends (Σ Σ' : global_env_ext) Γ x y : + wf Σ' -> + extends Σ Σ' -> + cored Σ Γ x y -> cored Σ' Γ x y. +Proof. + intros wf ext. + induction 1. + - constructor. + eapply PCUICWeakeningEnvConv.weakening_env_red1. apply wf. exact ext. + exact X. + - econstructor 2; tea. + eapply PCUICWeakeningEnvConv.weakening_env_red1. apply wf. + exact ext. + exact X. +Qed. + +Lemma normalization_in_extends (Σ Σ' : global_env) ext : + wf Σ -> wf Σ' -> + extends Σ' Σ -> + NormalizationIn (Σ, ext) -> NormalizationIn (Σ', ext). +Proof. + intros wfΣ wfΣ' extH nin. + red in nin. intros Γ t wt. + assert (welltyped (Σ, ext) Γ t). + { destruct wt. exists A. eapply (env_prop_typing weakening_env) in X; tea; cbn. } + specialize (nin _ _ H). clear H. + induction nin. + constructor. intros y r. + eapply H0. eapply cored_extends in r; tea. + eapply cored_welltyped; tea. +Qed. + +Lemma iter_abstract_pop_decls_correct {cf} {abstract_env_impl abstract_env_ext_impl : Type} + {abstract_env_struct0 : abstract_env_struct abstract_env_impl + abstract_env_ext_impl} : + abstract_env_prop abstract_env_impl abstract_env_ext_impl -> + forall (X : abstract_env_impl) (decls : list (kername × global_decl)) n, + (forall Σ : global_env, + Σ ∼ X -> exists decls', #|decls'| = n /\ declarations Σ = decls' ++ decls) -> + let X' := iter abstract_pop_decls n X in + forall Σ Σ' : global_env, + Σ ∼ X -> + Σ' ∼ X' -> + declarations Σ' = decls /\ universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ'. +Proof. + intros ap X decls. + induction n in X, decls |- *. cbn. + - intros hdecl Σ Σ' HX HX'. + specialize (hdecl _ HX) as [decls' [hlen hde]]. + destruct decls' => //. cbn in hde. + now rewrite -hde (abstract_env_irr _ HX HX'). + - intros hdecl X' Σ Σ' HX HX'. + specialize (hdecl _ HX) as [decls' [hlen hde]]. + destruct decls' => //; cbn in hde. + specialize (IHn (abstract_pop_decls X) decls). + pose proof (abstract_pop_decls_correct X (decls' ++ decls)). + forward H. + { intros ? h. rewrite -(abstract_env_irr _ HX h). now exists p. } + forward IHn. + { intros ? H0. now specialize (H _ _ HX H0). } + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop hpop]]. + specialize (IHn _ _ hpop HX'). + destruct IHn. split => //. + pose proof (abstract_pop_decls_correct X (decls' ++ decls)). + forward H2. + { intros ? hx. pose proof (abstract_env_irr _ hx HX). subst Σ0. now exists p. } + specialize (H2 _ _ HX hpop). destruct H2 as [? []]. + destruct H1. + split; congruence. +Qed. + +Lemma skipn_app_prefix {A} n (l l' : list A) : skipn (#|l| + n) (l ++ l') = skipn n l'. +Proof. + induction l; cbn; auto. +Qed. + +Lemma erase_global_deps_fast_erase_global_deps {deps} {X_type X} {decls normalization_in hprefix hprefix'} : + exists normalization_in', + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = + erase_global_deps X_type deps X decls normalization_in' hprefix'. +Proof using Type. + unshelve eexists. + intros. + pose proof (abstract_env_exists X) as [[Σ' H']]. + pose proof (abstract_env_wf _ H') as []. + specialize (hprefix _ H') as [[Σ'' ?]]. + pose proof (abstract_env_exists (iter abstract_pop_decls (S n) X)) as [[? ?]]. + pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ a H1). noconf H2. + epose proof (iter_abstract_pop_decls_correct _ X (skipn (S n) (Σ'' ++ decls)) (S n)). + forward H2. { intros ? h. rewrite (abstract_env_irr _ h H'). exists (firstn (S n) (Σ'' ++ decls)). + rewrite firstn_skipn. split => //. rewrite firstn_length_le //. rewrite app_length. lia. } + specialize (H2 _ _ H' a) as [? []]. + eapply normalization_in_extends. exact X1. exact X0. + { eapply extends_decls_extends, strictly_extends_decls_extends_decls. + red. rewrite H2 H3 H4. split => //. exists (firstn (S n) (Σ'' ++ decls)). + now rewrite firstn_skipn. } + specialize (normalization_in n H kn cb). + assert (wf_ext (Σ', cst_universes cb)). + { split => //. cbn. rewrite H3. apply X0. } + assert (forall Σ : global_env, Σ ∼ X -> ∥ wf_ext (Σ, cst_universes cb) ∥). + { intros. pose proof (abstract_env_irr _ H' H5). now subst Σ'. } + unshelve eapply normalization_in; tea. + set (foo := abstract_make_wf_env_ext X (cst_universes cb) H5). + pose proof (abstract_env_ext_exists foo) as [[Σext hext]]. + epose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ H' hext). now subst Σext. + erewrite erase_global_deps_fast_spec; tea. reflexivity. +Qed. + Definition erase_global_fast X_type deps X decls {normalization_in} (prf:forall Σ : global_env, abstract_env_rel X Σ -> declarations Σ = decls) := erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) (fun _ H => sq ([] ; prf _ H)). From 0934fc0d92d6e04933fec71f41934ebd92e4ca27 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 31 Aug 2023 18:07:10 +0200 Subject: [PATCH 47/65] Modify Transform class to allow showing preservation of fo values compositionally --- common/theories/Transform.v | 31 +-- erasure-plugin/_CoqProject.in | 1 + erasure-plugin/theories/ETransform.v | 20 +- erasure-plugin/theories/Erasure.v | 27 ++- erasure-plugin/theories/ErasureCorrectness.v | 187 +++++++++++++++---- erasure/theories/EProgram.v | 38 ++-- erasure/theories/ErasureFunction.v | 81 ++++++++ template-coq/theories/TemplateProgram.v | 2 +- template-pcuic/theories/PCUICTransform.v | 4 +- 9 files changed, 299 insertions(+), 92 deletions(-) diff --git a/common/theories/Transform.v b/common/theories/Transform.v index bbeb25d22..d1678fb27 100644 --- a/common/theories/Transform.v +++ b/common/theories/Transform.v @@ -19,14 +19,17 @@ Extract Constant time => "(fun c f x -> let s = Caml_bytestring.caml_string_of_bytestring c in Tm_util.time (Pp.str s) f x)". Module Transform. + Definition program env term := env * term. Section Opt. - Context {program program' : Type}. - Context {value value' : Type}. - Context {eval : program -> value -> Prop}. - Context {eval' : program' -> value' -> Prop}. + Context {env env' : Type}. + Context {term term' : Type}. + Notation program' := (program env' term'). + Notation program := (program env term). + Context {eval : program -> term -> Prop}. + Context {eval' : program' -> term' -> Prop}. Definition preserves_eval pre (transform : forall p : program, pre p -> program') - (obseq : forall p : program, pre p -> program' -> value -> value' -> Prop) := + (obseq : forall p : program, pre p -> program' -> term -> term' -> Prop) := forall p v (pr : pre p), eval p v -> let p' := transform p pr in @@ -38,7 +41,7 @@ Module Transform. transform : forall p : program, pre p -> program'; post : program' -> Prop; correctness : forall input (p : pre input), post (transform input p); - obseq : forall p : program, pre p -> program' -> value -> value' -> Prop; + obseq : forall p : program, pre p -> program' -> term -> term' -> Prop; preservation : preserves_eval pre transform obseq }. Definition run (x : t) (p : program) (pr : pre x p) : program' := @@ -47,19 +50,19 @@ Module Transform. End Opt. Arguments t : clear implicits. - Definition self_transform program value eval eval' := t program program value value eval eval'. + Definition self_transform env term eval eval' := t env env term term eval eval'. Section Comp. - Context {program program' program'' : Type}. - Context {value value' value'' : Type}. - Context {eval : program -> value -> Prop}. - Context {eval' : program' -> value' -> Prop}. - Context {eval'' : program'' -> value'' -> Prop}. + Context {env env' env'' : Type}. + Context {term term' term'' : Type}. + Context {eval : program env term -> term -> Prop}. + Context {eval' : program env' term' -> term' -> Prop}. + Context {eval'' : program env'' term'' -> term'' -> Prop}. Local Obligation Tactic := idtac. - Program Definition compose (o : t program program' value value' eval eval') (o' : t program' program'' value' value'' eval' eval'') + Program Definition compose (o : t env env' term term' eval eval') (o' : t env' env'' term' term'' eval' eval'') (hpp : (forall p, o.(post) p -> o'.(pre) p)) - : t program program'' value value'' eval eval'' := + : t env env'' term term'' eval eval'' := {| name := (o.(name) ^ " -> " ^ o'.(name))%bs; transform p hp := run o' (run o p hp) (hpp _ (o.(correctness) _ hp)); diff --git a/erasure-plugin/_CoqProject.in b/erasure-plugin/_CoqProject.in index 49d459d43..4978832ec 100644 --- a/erasure-plugin/_CoqProject.in +++ b/erasure-plugin/_CoqProject.in @@ -2,4 +2,5 @@ theories/ETransform.v theories/Erasure.v +theories/ErasureCorrectness.v theories/Extraction.v diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index c8c4584c1..bc6694a18 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -137,6 +137,8 @@ Proof. eauto using firstn_skipn. } Qed. +Local Obligation Tactic := program_simpl. + Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_program) {normalization_in : NormalizationIn_erase_pcuic_program_1 p.1} {normalization_in_adjust_universes : NormalizationIn_erase_pcuic_program_2 p.1} @@ -193,7 +195,7 @@ Qed. Local Obligation Tactic := try solve [ eauto ]. -Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t pcuic_program eprogram_env PCUICAst.term EAst.term +Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t _ _ PCUICAst.term EAst.term eval_pcuic_program (eval_eprogram_env EWcbvEval.default_wcbv_flags) := {| name := "erasure"; pre p := @@ -325,7 +327,7 @@ End PCUICEnv. Import EWcbvEval (WcbvFlags, with_prop_case, with_guarded_fix). Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) : - Transform.t eprogram_env eprogram_env EAst.term EAst.term + Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram_env (EWcbvEval.switch_unguarded_fix fl)) := {| name := "switching to unguarded fixpoints"; transform p pre := p; @@ -354,7 +356,7 @@ Definition rebuild_wf_env {efl} (p : eprogram) (hwf : wf_eprogram efl p): eprogr (GlobalContextMap.make p.1 (wf_glob_fresh p.1 (proj1 hwf)), p.2). Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} (with_exp : bool) : - Transform.t eprogram eprogram_env EAst.term EAst.term (eval_eprogram fl) (eval_eprogram_env fl) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram fl) (eval_eprogram_env fl) := {| name := "rebuilding environment lookup table"; pre p := wf_eprogram efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_cstrs p); transform p pre := rebuild_wf_env p (proj1 pre); @@ -376,7 +378,7 @@ Qed. Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags): - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters"; transform p pre := ERemoveParams.strip_program p; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -412,7 +414,7 @@ Qed. Program Definition remove_params_fast_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags) : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters (faster?)"; transform p _ := (ERemoveParams.Fast.strip_env p.1, ERemoveParams.Fast.strip p.1 [] p.2); pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -454,7 +456,7 @@ Qed. Import EOptimizePropDiscr EWcbvEval. Program Definition remove_match_on_box_trans {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := {| name := "optimize_prop_discr"; transform p _ := remove_match_on_box_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -490,7 +492,7 @@ From MetaCoq.Erasure Require Import EInlineProjections. Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) {hastrel : has_tRel} {hastbox : has_tBox} : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "primitive projection inlining"; transform p _ := EInlineProjections.optimize_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -526,7 +528,7 @@ From MetaCoq.Erasure Require Import EConstructorsAsBlocks. Program Definition constructors_as_blocks_transformation {efl : EEnvFlags} {has_app : has_tApp} {has_rel : has_tRel} {hasbox : has_tBox} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := {| name := "transforming to constuctors as blocks"; transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -566,7 +568,7 @@ From MetaCoq.Erasure Require Import EImplementBox. Program Definition implement_box_transformation {efl : EEnvFlags} {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = true} : - Transform.t eprogram eprogram EAst.term EAst.term (eval_eprogram block_wcbv_flags) (eval_eprogram block_wcbv_flags) := + Transform.t _ _ EAst.term EAst.term (eval_eprogram block_wcbv_flags) (eval_eprogram block_wcbv_flags) := {| name := "transforming to constuctors as blocks"; transform p _ := EImplementBox.implement_box_program p ; pre p := wf_eprogram efl p ; diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index 4467c1dae..175f9210f 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -23,13 +23,13 @@ Local Open Scope string_scope2. Import Transform. -Local Obligation Tactic := program_simpl. - #[local] Existing Instance extraction_checker_flags. #[local] Existing Instance PCUICSN.extraction_normalizing. Import EWcbvEval. +Local Obligation Tactic := program_simpl. + Axiom assume_welltyped_template_program_expansion : forall p (wtp : ∥ wt_template_program_env p ∥), let p' := EtaExpand.eta_expand_program p in @@ -42,7 +42,7 @@ Axiom assume_preservation_template_program_env_expansion : (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) -Program Definition eta_expand K : Transform.t template_program_env template_program Ast.term Ast.term +Program Definition eta_expand K : Transform.t _ _ Ast.term Ast.term eval_template_program_env eval_template_program := {| name := "eta expand cstrs and fixpoints"; pre := fun p => ∥ wt_template_program_env p ∥ /\ K (eta_expand_global_env p.1) ; @@ -50,7 +50,7 @@ Program Definition eta_expand K : Transform.t template_program_env template_prog post := fun p => ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p /\ K p.1; obseq p hp p' v v' := v' = EtaExpand.eta_expand p.1 [] v |}. Next Obligation. - let p := match goal with H : template_program_env |- _ => H end in + let p := match goal with H : program _ _ |- _ => H end in destruct p. split; [|split]; auto; now apply assume_welltyped_template_program_expansion. Qed. Next Obligation. @@ -59,7 +59,7 @@ Next Obligation. Qed. Program Definition verified_lambdabox_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t EProgram.eprogram_env EProgram.eprogram EAst.term EAst.term + Transform.t _ _ EAst.term EAst.term (EProgram.eval_eprogram_env {| with_prop_case := true; with_guarded_fix := true; with_constructor_as_block := false |}) (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := (* Simulation of the guarded fixpoint rules with a single unguarded one: @@ -98,7 +98,7 @@ Qed. Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t pcuic_program EProgram.eprogram + Transform.t _ _ PCUICAst.term EAst.term PCUICTransform.eval_pcuic_program (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := @@ -117,12 +117,11 @@ Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl Import EGlobalEnv EWellformed. Definition transform_compose - {program program' program'' value value' value'' : Type} - {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} - {eval'' : program'' -> value'' -> Prop} - (o : t program program' value value' eval eval') - (o' : t program' program'' value' value'' eval' eval'') - (pre : forall p : program', post o p -> pre o' p) : + {env env' env'' term term' term'' : Type} + {eval eval' eval''} + (o : t env env' term term' eval eval') + (o' : t env' env'' term' term'' eval' eval'') + (pre : forall p, post o p -> pre o' p) : forall x p1, exists p3, transform (compose o o' pre) x p1 = transform o' (transform o x p1) p3. Proof. @@ -138,7 +137,7 @@ Proof. Qed. Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t TemplateProgram.template_program pcuic_program + Transform.t _ _ Ast.term PCUICAst.term TemplateProgram.eval_template_program PCUICTransform.eval_pcuic_program := @@ -159,7 +158,7 @@ Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EW template_to_pcuic_transform (K _ T2). Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t TemplateProgram.template_program EProgram.eprogram + Transform.t _ _ Ast.term EAst.term TemplateProgram.eval_template_program (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 4558691a0..158bd529c 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -20,22 +20,20 @@ Import PCUICTransform (template_to_pcuic_transform, pcuic_expand_lets_transform) Import Transform. -Obligation Tactic := program_simpl. +#[local] Obligation Tactic := program_simpl. #[local] Existing Instance extraction_checker_flags. Import EWcbvEval. Lemma transform_compose_assoc - {program program' program'' program''' value value' value'' value''' : Type} - {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} - {eval'' : program'' -> value'' -> Prop} - {eval''' : program''' -> value''' -> Prop} - (o : t program program' value value' eval eval') - (o' : t program' program'' value' value'' eval' eval'') - (o'' : t program'' program''' value'' value''' eval'' eval''') - (prec : forall p : program', post o p -> pre o' p) - (prec' : forall p : program'', post o' p -> pre o'' p) : + {env env' env'' env''' term term' term'' term''' : Type} + {eval eval' eval'' eval'''} + (o : t env env' term term' eval eval') + (o' : t env' env'' term' term'' eval' eval'') + (o'' : t env'' env''' term'' term''' eval'' eval''') + (prec : forall p, post o p -> pre o' p) + (prec' : forall p, post o' p -> pre o'' p) : forall x p1, transform (compose o (compose o' o'' prec') prec) x p1 = transform (compose (compose o o' prec) o'' prec') x p1. @@ -47,15 +45,13 @@ Proof. Qed. Lemma obseq_compose_assoc - {program program' program'' program''' value value' value'' value''' : Type} - {eval : program -> value -> Prop} {eval' : program' -> value' -> Prop} - {eval'' : program'' -> value'' -> Prop} - {eval''' : program''' -> value''' -> Prop} - (o : t program program' value value' eval eval') - (o' : t program' program'' value' value'' eval' eval'') - (o'' : t program'' program''' value'' value''' eval'' eval''') - (prec : forall p : program', post o p -> pre o' p) - (prec' : forall p : program'', post o' p -> pre o'' p) : + {env env' env'' env''' term term' term'' term''' : Type} + {eval eval' eval'' eval'''} + (o : t env env' term term' eval eval') + (o' : t env' env'' term' term'' eval' eval'') + (o'' : t env'' env''' term'' term''' eval'' eval''') + (prec : forall p, post o p -> pre o' p) + (prec' : forall p, post o' p -> pre o'' p) : forall x p1 p2 v1 v2, obseq (compose o (compose o' o'' prec') prec) x p1 p2 v1 v2 <-> obseq (compose (compose o o' prec) o'' prec') x p1 p2 v1 v2. Proof. @@ -326,14 +322,126 @@ Proof. red. intros. split; reflexivity. Qed. -Section pipeline_theorem. +Lemma expand_lets_fo (Σ : global_env_ext_map) t : + PCUICFirstorder.firstorder_value Σ [] t -> + let p := (Σ, t) in + PCUICExpandLets.expand_lets_program p = + (build_global_env_map (PCUICAst.PCUICEnvironment.fst_ctx (PCUICExpandLets.trans_global p.1)), p.1.2, t). +Proof. + intros p. + cbn. unfold PCUICExpandLets.expand_lets_program. f_equal. cbn. + move: p. apply: (PCUICFirstorder.firstorder_value_inds _ _ (fun t => PCUICExpandLets.trans t = t)). + intros i n ui u args pandi ht hf ih isp. + rewrite PCUICExpandLetsCorrectness.trans_mkApps /=. f_equal. + now eapply forall_map_id_spec. +Qed. - Fixpoint compile_value_box (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := - match t with - | PCUICAst.tApp f a => compile_value_box f (acc ++ [compile_value_box a []]) - | PCUICAst.tConstruct i n _ => EAst.tConstruct i n acc - | _ => EAst.tVar "error" - end. +Fixpoint compile_value_box (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := + match t with + | PCUICAst.tApp f a => compile_value_box f (acc ++ [compile_value_box a []]) + | PCUICAst.tConstruct i n _ => EAst.tConstruct i n acc + | _ => EAst.tVar "error" + end. + +From Equations Require Import Equations. + +Lemma erase_transform_fo_gen (p : pcuic_program) pr : + PCUICFirstorder.firstorder_value p.1 [] p.2 -> + forall ep, transform erase_transform p pr = ep -> ep.2 = compile_value_erase p.2 []. +Proof. + destruct p as [Σ t]. cbn. + intros hev ep <-. move: hev pr. + unfold erase_program, erase_pcuic_program; cbn -[erase PCUICWfEnv.abstract_make_wf_env_ext]. + intros fo pr. + set (prf0 := fun (Σ0 : PCUICAst.PCUICEnvironment.global_env_ext) => _). + set (prf1 := fun (Σ0 : PCUICAst.PCUICEnvironment.global_env_ext) => _). + clearbody prf0 prf1. + destruct pr as []. + destruct s as [[]]. + epose proof (erases_erase (X_type := optimized_abstract_env_impl) prf1 _ eq_refl). + eapply erases_firstorder' in H; eauto. +Qed. + +Lemma erase_transform_fo (p : pcuic_program) pr : + PCUICFirstorder.firstorder_value p.1 [] p.2 -> + transform erase_transform p pr = ((transform erase_transform p pr).1, compile_value_erase p.2 []). +Proof. + intros fo. + set (tr := transform _ _ _). + change tr with (tr.1, tr.2). f_equal. + eapply erase_transform_fo_gen; tea. reflexivity. +Qed. + +Inductive firstorder_evalue : EAst.term -> Prop := + | is_fo i n args : Forall firstorder_evalue args -> firstorder_evalue (EAst.tConstruct i n args). + +Lemma compile_fo_value Σ t : + PCUICFirstorder.firstorder_value Σ [] t -> + firstorder_evalue (compile_value_erase t []). +Proof. Admitted. + +Fixpoint compile_evalue_box (t : EAst.term) (acc : list EAst.term) := + match t with + | EAst.tApp f a => compile_evalue_box f (compile_evalue_box a [] :: acc) + | EAst.tConstruct i n _ => EAst.tConstruct i n acc + | _ => EAst.tVar "error" + end. + +Import MetaCoq.Common.Transform. + +Module ETransformPresFO. + Section Opt. + Context {env env' : Type}. + Context {eval : program env EAst.term -> EAst.term -> Prop}. + Context {eval' : program env' EAst.term -> EAst.term -> Prop}. + Context (o : Transform.t _ _ _ _ eval eval'). + Context (compile_fo_value : EAst.term -> EAst.term). + + Class t := + { preserves_fo : forall v, firstorder_evalue v -> firstorder_evalue (compile_fo_value v); + transform_fo : forall v (pr : o.(pre) v), + firstorder_evalue v.2 -> (o.(transform) v pr).2 = compile_fo_value v.2 }. + End Opt. + + Section Comp. + Context {env env' env'' : Type}. + Context {eval : program env EAst.term -> EAst.term -> Prop}. + Context {eval' : program env' EAst.term -> EAst.term -> Prop}. + Context {eval'' : program env'' EAst.term -> EAst.term -> Prop}. + Context (compile_fo_value compile_fo_value' : EAst.term -> EAst.term). + + Local Obligation Tactic := idtac. + #[global] + Instance compose (o : Transform.t _ _ _ _ eval eval') + (o' : Transform.t _ _ _ _ eval' eval'') + (oext : t o compile_fo_value) + (o'ext : t o' compile_fo_value') + (hpp : (forall p, o.(post) p -> o'.(pre) p)) + : t (Transform.compose o o' hpp) (compile_fo_value' ∘ compile_fo_value). + Proof. + split. + - intros. eapply preserves_fo; tea. eapply preserves_fo; tea. + - intros. cbn. unfold run, time. + rewrite o'ext.(transform_fo _ _). + rewrite oext.(transform_fo _ _) //. + eapply preserves_fo; tea. + rewrite oext.(transform_fo _ _) //. + Qed. + End Comp. + +End ETransformPresFO. + +Axiom lambdabox_pres_fo : ETransformPresFO.t verified_lambdabox_pipeline (flip compile_evalue_box []). + +Lemma transform_lambda_box_firstorder (Σer : EEnvMap.GlobalContextMap.t) v pre : + firstorder_evalue v -> + (transform verified_lambdabox_pipeline (Σer, v) pre).2 = (compile_evalue_box v []). +Proof. + intros fo. + now rewrite (ETransformPresFO.transform_fo _ _ (t:=lambdabox_pres_fo)). +Qed. + +Section pipeline_theorem. Instance cf : checker_flags := extraction_checker_flags. Instance nf : PCUICSN.normalizing_flags := PCUICSN.extraction_normalizing. @@ -369,12 +477,12 @@ Section pipeline_theorem. Lemma precond2 : pre verified_erasure_pipeline (Σ, v). Proof. - cbn. repeat eapply conj; sq; cbn; eauto. + cbn. destruct Heval. repeat eapply conj; sq; cbn; eauto. - red. cbn. split; eauto. eexists. eapply PCUICClassification.subject_reduction_eval; eauto. - todo "preservation of eta expandedness". - - todo "normalization". + - cbn. todo "normalization". - todo "normalization". Qed. @@ -384,7 +492,7 @@ Section pipeline_theorem. Lemma fo_v : PCUICFirstorder.firstorder_value Σ [] v. Proof. - sq. + destruct Heval. sq. eapply PCUICFirstorder.firstorder_value_spec; eauto. - eapply PCUICClassification.subject_reduction_eval; eauto. - eapply PCUICWcbvEval.eval_to_value; eauto. @@ -394,11 +502,24 @@ Section pipeline_theorem. Lemma v_t_spec : v_t = (transform verified_erasure_pipeline (Σ, v) precond2).2. Proof. unfold v_t. generalize fo_v, precond2. clear. - induction 1. - intros. unfold verified_erasure_pipeline. - repeat destruct_compose. intros. - cbn [transform erase_transform]. + intros hv pre. + unfold verified_erasure_pipeline. + rewrite -transform_compose_assoc. + destruct_compose. cbn [transform pcuic_expand_lets_transform]. + rewrite (expand_lets_fo _ _ hv). + cbn [fst snd]. + intros h. + destruct_compose. + rewrite erase_transform_fo. cbn. admit. + set (Σer := (transform erase_transform _ _).1). + cbn [fst snd]. intros pre'. + symmetry. + erewrite transform_lambda_box_firstorder; tea. + eapply obseq_lambdabox. intros kn decl H; exact H. + Unshelve. 2:exact pre'. 2:exact (Σer, compile_value_erase v []). + cbn [snd]. + red. cbn. Admitted. Import PCUICWfEnv. diff --git a/erasure/theories/EProgram.v b/erasure/theories/EProgram.v index cd2d7cc49..15cfe1e16 100644 --- a/erasure/theories/EProgram.v +++ b/erasure/theories/EProgram.v @@ -13,7 +13,7 @@ Local Open Scope string_scope2. Import Transform. -Obligation Tactic := program_simpl. +Local Obligation Tactic := program_simpl. Import EGlobalEnv EWellformed. @@ -53,13 +53,14 @@ Qed. Module TransformExt. Section Opt. - Context {program program' : Type}. - Context {value value' : Type}. - Context {eval : program -> value -> Prop}. - Context {eval' : program' -> value' -> Prop}. - Context (o : Transform.t program program' value value' eval eval'). - Context (extends : program -> program -> Prop). - Context (extends' : program' -> program' -> Prop). + Context {env env' env'' : Type}. + Context {term term' term'' : Type}. + Context {eval : program env term -> term -> Prop}. + Context {eval' : program env' term' -> term' -> Prop}. + Context {eval'' : program env'' term'' -> term'' -> Prop}. + Context (o : Transform.t env env' term term' eval eval'). + Context (extends : program env term -> program env term -> Prop). + Context (extends' : program env' term' -> program env' term' -> Prop). Class t := preserves_obs : forall p p' (pr : o.(pre) p) (pr' : o.(pre) p'), extends p p' -> extends' (o.(transform) p pr) (o.(transform) p' pr'). @@ -67,20 +68,19 @@ Module TransformExt. End Opt. Section Comp. - Context {program program' program'' : Type}. - Context {value value' value'' : Type}. - Context {eval : program -> value -> Prop}. - Context {eval' : program' -> value' -> Prop}. - Context {eval'' : program'' -> value'' -> Prop}. - - Context {extends : program -> program -> Prop}. - Context {extends' : program' -> program' -> Prop}. - Context {extends'' : program'' -> program'' -> Prop}. + Context {env env' env'' : Type}. + Context {term term' term'' : Type}. + Context {eval : program env term -> term -> Prop}. + Context {eval' : program env' term' -> term' -> Prop}. + Context {eval'' : program env'' term'' -> term'' -> Prop}. + Context {extends : program env term -> program env term -> Prop}. + Context {extends' : program env' term' -> program env' term' -> Prop}. + Context {extends'' : program env'' term'' -> program env'' term'' -> Prop}. Local Obligation Tactic := idtac. #[global] - Instance compose (o : Transform.t program program' value value' eval eval') - (o' : Transform.t program' program'' value' value'' eval' eval'') + Instance compose (o : Transform.t env env' term term' eval eval') + (o' : Transform.t env' env'' term' term'' eval' eval'') (oext : t o extends extends') (o'ext : t o' extends' extends'') (hpp : (forall p, o.(post) p -> o'.(pre) p)) diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 8313423d9..528be6234 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -4051,6 +4051,8 @@ Qed. (* This version of global environment erasure keeps the same global environment throughout the whole erasure, while folding over the list of declarations. *) +Local Obligation Tactic := program_simpl. + Program Fixpoint erase_global_deps_fast (deps : KernameSet.t) X_type (X:X_type.π1) (decls : global_declarations) {normalization_in : NormalizationIn_erase_global_deps_fast X decls} @@ -4515,3 +4517,82 @@ Proof using Type. Qed. End EraseGlobalFast. + +Fixpoint compile_value_erase (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := + match t with + | PCUICAst.tApp f a => compile_value_erase f (compile_value_erase a [] :: acc) + | PCUICAst.tConstruct i n _ => EAst.mkApps (EAst.tConstruct i n []) acc + | _ => EAst.tVar "error" + end. + +Lemma compile_value_erase_mkApps i n ui args acc : + compile_value_erase (mkApps (tConstruct i n ui) args) acc = + EAst.mkApps (EAst.tConstruct i n []) (map (flip compile_value_erase []) args ++ acc). +Proof. + revert acc; induction args using rev_ind. + - cbn. auto. + - intros acc. rewrite PCUICAstUtils.mkApps_app /=. cbn. + now rewrite IHargs map_app /= -app_assoc /=. +Qed. + +Lemma erases_firstorder Σ Γ t : + PCUICFirstorder.firstorder_value Σ Γ t -> + erases Σ Γ t (compile_value_erase t []). +Proof. + move: t. + apply: (PCUICFirstorder.firstorder_value_inds Σ Γ). + intros i n ui u args pandi hty hfo ih isp. + assert (Forall2 (erases Σ Γ) args (map (flip compile_value_erase []) args)). + { solve_all. eapply All_All2; tea. + cbn. intros x [fo hx]. exact hx. } + unshelve epose proof (erases_mkApps Σ Γ (tConstruct i n ui) (EAst.tConstruct i n []) args _ _ H). + constructor. + { move: isp. rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. + destruct PCUICEnvironment.lookup_env => //. + destruct g => //. destruct nth_error => //. } + now rewrite compile_value_erase_mkApps app_nil_r. +Qed. + +Lemma erases_firstorder' Σ Γ t : + wf_ext Σ -> + PCUICFirstorder.firstorder_value Σ Γ t -> + forall t', erases Σ Γ t t' -> t' = (compile_value_erase t []). +Proof. + intros wf. move: t. + apply: (PCUICFirstorder.firstorder_value_inds Σ Γ). + intros i n ui u args pandi hty hfo ih isp. + assert (Forall2 (erases Σ Γ) args (map (flip compile_value_erase []) args)). + { solve_all. eapply All_All2; tea. + cbn. intros x [fo hx]. now eapply erases_firstorder. } + unshelve epose proof (erases_mkApps Σ Γ (tConstruct i n ui) (EAst.tConstruct i n []) args _ _ H). + constructor. + { move: isp. rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. + destruct PCUICEnvironment.lookup_env => //. + destruct g => //. destruct nth_error => //. } + rewrite compile_value_erase_mkApps app_nil_r. + intros t' ht'. + eapply erases_mkApps_inv in ht'. + destruct ht'. + { destruct H1 as [? [? [? [? [[] ?]]]]]. + eapply isErasable_Propositional in X => //. + clear -isp X. elimtype False. + move: isp X. + rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. + destruct PCUICEnvironment.lookup_env => //. + destruct g => //. destruct nth_error => //. + rewrite /isPropositionalArity. destruct destArity => //. + destruct p. intros ->. auto. } + destruct H1 as [f' [L' [-> [erc erargs]]]]. + depelim erc. f_equal. + solve_all. clear -erargs. + induction erargs => //. rewrite IHerargs. cbn. f_equal. + destruct r as [[] ?]. eapply e in e0. now unfold flip. + eapply (isErasable_Propositional (args := [])) in X => //. + clear -isp X. elimtype False. + move: isp X. + rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. + destruct PCUICEnvironment.lookup_env => //. + destruct g => //. destruct nth_error => //. + rewrite /isPropositionalArity. destruct destArity => //. + destruct p. intros ->. auto. +Qed. \ No newline at end of file diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v index 2895858f6..6db0926ba 100644 --- a/template-coq/theories/TemplateProgram.v +++ b/template-coq/theories/TemplateProgram.v @@ -47,7 +47,7 @@ Definition make_template_program_env {cf : checker_flags} (p : template_program) (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) Program Definition build_template_program_env {cf : checker_flags} K : - Transform.t template_program template_program_env Ast.term Ast.term eval_template_program eval_template_program_env := + Transform.t global_env GlobalEnvMap.t Ast.term Ast.term eval_template_program eval_template_program_env := {| name := "rebuilding environment lookup table"; pre p := ∥ wt_template_program p ∥ /\ forall pf, K (GlobalEnvMap.make p.1 (wt_template_program_fresh p pf)) : Prop ; transform p pre := make_template_program_env p (proj1 pre); diff --git a/template-pcuic/theories/PCUICTransform.v b/template-pcuic/theories/PCUICTransform.v index 359f8998b..ef840ddaf 100644 --- a/template-pcuic/theories/PCUICTransform.v +++ b/template-pcuic/theories/PCUICTransform.v @@ -34,7 +34,7 @@ Local Obligation Tactic := idtac. (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) Program Definition template_to_pcuic_transform {cf : checker_flags} K : - Transform.t template_program pcuic_program Ast.term term + Transform.t Ast.Env.global_env global_env_ext_map Ast.term term eval_template_program eval_pcuic_program := {| name := "template to pcuic"; pre p := ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p /\ K (trans_global (Ast.Env.empty_ext p.1)) ; @@ -66,7 +66,7 @@ From MetaCoq.PCUIC Require Import PCUICExpandLets PCUICExpandLetsCorrectness. *) Program Definition pcuic_expand_lets_transform {cf : checker_flags} K : - self_transform pcuic_program term eval_pcuic_program eval_pcuic_program := + self_transform global_env_ext_map term eval_pcuic_program eval_pcuic_program := {| name := "let expansion in branches/constructors"; pre p := ∥ wt_pcuic_program p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p /\ K (build_global_env_map (trans_global_env p.1.1), p.1.2) ; transform p hp := expand_lets_program p; From 1f1248dd3aefd63a926112949d05685b65de4938 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 1 Sep 2023 18:15:51 +0200 Subject: [PATCH 48/65] Proved most of the fo preservation of the lambdabox pipeline --- erasure-plugin/theories/ErasureCorrectness.v | 376 +++++++++++++++++-- erasure/theories/EInlineProjections.v | 11 + erasure/theories/EOptimizePropDiscr.v | 10 + erasure/theories/ERemoveParams.v | 11 + 4 files changed, 371 insertions(+), 37 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 158bd529c..5c0facb2e 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -336,10 +336,15 @@ Proof. now eapply forall_map_id_spec. Qed. -Fixpoint compile_value_box (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := +Fixpoint compile_value_box Σ (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := match t with - | PCUICAst.tApp f a => compile_value_box f (acc ++ [compile_value_box a []]) - | PCUICAst.tConstruct i n _ => EAst.tConstruct i n acc + | PCUICAst.tApp f a => compile_value_box Σ f (compile_value_box Σ a [] :: acc) + | PCUICAst.tConstruct i n _ => + match PCUICAst.PCUICEnvironment.lookup_env Σ (Kernames.inductive_mind i) with + | Some (PCUICAst.PCUICEnvironment.InductiveDecl mdecl) => + EAst.tConstruct i n (skipn mdecl.(PCUICAst.PCUICEnvironment.ind_npars) acc) + | _ => EAst.tVar "error" + end | _ => EAst.tVar "error" end. @@ -372,13 +377,95 @@ Proof. eapply erase_transform_fo_gen; tea. reflexivity. Qed. -Inductive firstorder_evalue : EAst.term -> Prop := - | is_fo i n args : Forall firstorder_evalue args -> firstorder_evalue (EAst.tConstruct i n args). +Inductive firstorder_evalue Σ : EAst.term -> Prop := + | is_fo i n args npars : + EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + Forall (firstorder_evalue Σ) (skipn npars args) -> + firstorder_evalue Σ (EAst.mkApps (EAst.tConstruct i n []) args). -Lemma compile_fo_value Σ t : +Lemma list_size_skipn {A} (l : list A) size n : + list_size size (skipn n l) <= list_size size l. +Proof. + induction n in l |- *. + - rewrite skipn_0 //. + - destruct l. rewrite skipn_nil. now cbn. + rewrite skipn_S. cbn. specialize (IHn l); lia. +Qed. + +Section elim. + Context (Σ : E.global_context). + Context (P : EAst.term -> Prop). + Context (ih : (forall i n args npars, + EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + Forall (firstorder_evalue Σ) (skipn npars args) -> + Forall P (skipn npars args) -> + P (EAst.mkApps (EAst.tConstruct i n []) args))). + + Equations? firstorder_evalue_elim (t : EAst.term) (fo : firstorder_evalue Σ t) : P t by wf t (MR lt EInduction.size) := + { | _, is_fo i n args npars hl hf => _ }. + Proof. + eapply ih; tea. + eapply In_Forall. intros x hin. + eapply PCUICWfUniverses.Forall_In in hf; tea. + apply firstorder_evalue_elim => //. red. + rewrite EInduction.size_mkApps. + eapply (In_size id EInduction.size) in hin. + unfold id in *. pose proof (list_size_skipn args EInduction.size npars). + change (fun x => EInduction.size x) with EInduction.size in hin. clear -hin H. + eapply Nat.lt_le_trans; tea. cbn. lia. + Qed. +End elim. + +(*Lemma firstorder_evalue_elim Σ {P : EAst.term -> Prop} : + (forall i n args npars, + EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + Forall (firstorder_evalue Σ) (skipn npars args) -> + Forall P (skipn npars args) -> + P (EAst.mkApps (EAst.tConstruct i n []) args)) -> + forall t, firstorder_evalue Σ t -> P t. +Proof. + intros Hf. + induction t using term_size + fix aux 2. + intros t fo; destruct fo.x + eapply Hf => //; tea. + clear H. + move: H0. + move: args H0. + fix aux' 2. + intros args []; constructor. + now apply aux. now apply aux'. +Qed.*) + +Inductive firstorder_evalue_block : EAst.term -> Prop := + | is_fo_block i n args : + Forall (firstorder_evalue_block) args -> + firstorder_evalue_block (EAst.tConstruct i n args). + +Lemma firstorder_evalue_block_elim {P : EAst.term -> Prop} : + (forall i n args, + Forall firstorder_evalue_block args -> + Forall P args -> + P (EAst.tConstruct i n args)) -> + forall t, firstorder_evalue_block t -> P t. +Proof. + intros Hf. + fix aux 2. + intros t fo; destruct fo. + eapply Hf => //. + move: args H. + fix aux' 2. + intros args []; constructor. + now apply aux. now apply aux'. +Qed. + +(* Import PCUICAst. + +Lemma compile_fo_value (Σ : global_env_ext) Σ' t : PCUICFirstorder.firstorder_value Σ [] t -> - firstorder_evalue (compile_value_erase t []). -Proof. Admitted. + erases_global + firstorder_evalue Σ (compile_value_erase t []). +Proof. Admitted. *) Fixpoint compile_evalue_box (t : EAst.term) (acc : list EAst.term) := match t with @@ -388,6 +475,7 @@ Fixpoint compile_evalue_box (t : EAst.term) (acc : list EAst.term) := end. Import MetaCoq.Common.Transform. +From Coq Require Import Morphisms. Module ETransformPresFO. Section Opt. @@ -395,50 +483,263 @@ Module ETransformPresFO. Context {eval : program env EAst.term -> EAst.term -> Prop}. Context {eval' : program env' EAst.term -> EAst.term -> Prop}. Context (o : Transform.t _ _ _ _ eval eval'). - Context (compile_fo_value : EAst.term -> EAst.term). + Context (firstorder_value : program env EAst.term -> Prop). + Context (firstorder_value' : program env' EAst.term -> Prop). + Context (compile_fo_value : forall p : program env EAst.term, o.(pre) p -> + firstorder_value p -> program env' EAst.term). Class t := - { preserves_fo : forall v, firstorder_evalue v -> firstorder_evalue (compile_fo_value v); - transform_fo : forall v (pr : o.(pre) v), - firstorder_evalue v.2 -> (o.(transform) v pr).2 = compile_fo_value v.2 }. + { preserves_fo : forall p pr (fo : firstorder_value p), firstorder_value' (compile_fo_value p pr fo); + transform_fo : forall v (pr : o.(pre) v) (fo : firstorder_value v), o.(transform) v pr = compile_fo_value v pr fo }. End Opt. + Section ExtEq. + Context {env env' : Type}. + Context {eval : program env EAst.term -> EAst.term -> Prop}. + Context {eval' : program env' EAst.term -> EAst.term -> Prop}. + Context (o : Transform.t _ _ _ _ eval eval'). + Context (firstorder_value : program env EAst.term -> Prop). + Context (firstorder_value' : program env' EAst.term -> Prop). + + Lemma proper_pres (compile_fo_value compile_fo_value' : forall p : program env EAst.term, o.(pre) p -> firstorder_value p -> program env' EAst.term) : + (forall p pre fo, compile_fo_value p pre fo = compile_fo_value' p pre fo) -> + t o firstorder_value firstorder_value' compile_fo_value <-> + t o firstorder_value firstorder_value' compile_fo_value'. + Proof. + intros Hfg. + split; move=> []; split; eauto. + - now intros ? ? ?; rewrite -Hfg. + - now intros v pr ?; rewrite -Hfg. + - now intros ???; rewrite Hfg. + - now intros ???; rewrite Hfg. + Qed. + End ExtEq. Section Comp. Context {env env' env'' : Type}. Context {eval : program env EAst.term -> EAst.term -> Prop}. Context {eval' : program env' EAst.term -> EAst.term -> Prop}. Context {eval'' : program env'' EAst.term -> EAst.term -> Prop}. - Context (compile_fo_value compile_fo_value' : EAst.term -> EAst.term). + Context (firstorder_value : program env EAst.term -> Prop). + Context (firstorder_value' : program env' EAst.term -> Prop). + Context (firstorder_value'' : program env'' EAst.term -> Prop). + Context (o : Transform.t _ _ _ _ eval eval') (o' : Transform.t _ _ _ _ eval' eval''). + Context compile_fo_value compile_fo_value' + (oext : t o firstorder_value firstorder_value' compile_fo_value) + (o'ext : t o' firstorder_value' firstorder_value'' compile_fo_value') + (hpp : (forall p, o.(post) p -> o'.(pre) p)). Local Obligation Tactic := idtac. + + Definition compose_compile_fo_value (p : program env EAst.term) (pr : o.(pre) p) (fo : firstorder_value p) : program env'' EAst.term := + compile_fo_value' (compile_fo_value p pr fo) (eq_rect_r (o'.(pre)) (hpp _ (correctness o p pr)) (eq_sym (oext.(transform_fo _ _ _ _) _ _ _))) (oext.(preserves_fo _ _ _ _) p pr fo). + #[global] - Instance compose (o : Transform.t _ _ _ _ eval eval') - (o' : Transform.t _ _ _ _ eval' eval'') - (oext : t o compile_fo_value) - (o'ext : t o' compile_fo_value') - (hpp : (forall p, o.(post) p -> o'.(pre) p)) - : t (Transform.compose o o' hpp) (compile_fo_value' ∘ compile_fo_value). + Instance compose + : t (Transform.compose o o' hpp) firstorder_value firstorder_value'' compose_compile_fo_value. Proof. split. - - intros. eapply preserves_fo; tea. eapply preserves_fo; tea. + - intros. eapply o'ext.(preserves_fo _ _ _ _); tea. - intros. cbn. unfold run, time. - rewrite o'ext.(transform_fo _ _). - rewrite oext.(transform_fo _ _) //. - eapply preserves_fo; tea. - rewrite oext.(transform_fo _ _) //. + unfold compose_compile_fo_value. + set (cor := correctness o v pr). clearbody cor. move: cor. + set (foo := eq_sym (transform_fo _ _ _ _ _ _ _)). clearbody foo. + destruct foo. cbn. intros cor. + apply o'ext.(transform_fo _ _ _ _). Qed. End Comp. End ETransformPresFO. -Axiom lambdabox_pres_fo : ETransformPresFO.t verified_lambdabox_pipeline (flip compile_evalue_box []). +Import EWellformed. + +Lemma compile_value_box_mkApps Σ i n ui args acc : + compile_value_box Σ (PCUICAst.mkApps (PCUICAst.tConstruct i n ui) args) acc = + EAst.tConstruct i n (List.map (flip compile_value_box []) args ++ acc). +Proof. + revert acc; induction args using rev_ind. + - cbn. auto. + - intros acc. rewrite PCUICAstUtils.mkApps_app /=. cbn. + now rewrite IHargs map_app /= -app_assoc /=. +Qed. + +Lemma compile_evalue_box_mkApps i n ui args acc : + compile_evalue_box (EAst.mkApps (EAst.tConstruct i n ui) args) acc = + EAst.tConstruct i n (List.map (flip compile_evalue_box []) args ++ acc). +Proof. + revert acc; induction args using rev_ind. + - cbn. auto. + - intros acc. rewrite EAstUtils.mkApps_app /=. cbn. + now rewrite IHargs map_app /= -app_assoc /=. +Qed. + +Lemma compile_evalue_erase Σ v : + PCUICFirstorder.firstorder_value Σ [] v -> + compile_evalue_box (compile_value_erase v []) [] = compile_value_box v []. +Proof. + move=> fo; move: v fo. + apply: PCUICFirstorder.firstorder_value_inds. + intros i n ui u args pandi hty hargs ih isp. + rewrite compile_value_erase_mkApps compile_value_box_mkApps compile_evalue_box_mkApps. + rewrite !app_nil_r. f_equal. + rewrite map_map. + now eapply map_ext_Forall. +Qed. -Lemma transform_lambda_box_firstorder (Σer : EEnvMap.GlobalContextMap.t) v pre : - firstorder_evalue v -> - (transform verified_lambdabox_pipeline (Σer, v) pre).2 = (compile_evalue_box v []). +Lemma compile_evalue_box_firstorder {efl : EEnvFlags} Σ v : + has_cstr_params = false -> + EWellformed.wf_glob Σ -> + firstorder_evalue Σ v -> firstorder_evalue_block (flip compile_evalue_box [] v). +Proof. + intros hpars wf. + move: v; apply: firstorder_evalue_elim. + intros. + rewrite /flip compile_evalue_box_mkApps app_nil_r. + rewrite /EGlobalEnv.lookup_inductive_pars /= in H. + destruct EGlobalEnv.lookup_minductive eqn:e => //. + eapply wellformed_lookup_inductive_pars in hpars; tea => //. + noconf H. rewrite hpars in H1. rewrite skipn_0 in H1. + constructor. ELiftSubst.solve_all. +Qed. + +Definition fo_evalue (p : program E.global_context EAst.term) : Prop := firstorder_evalue p.1 p.2. +Definition fo_evalue_map (p : program EEnvMap.GlobalContextMap.t EAst.term) : Prop := firstorder_evalue p.1 p.2. + +#[global] Instance rebuild_wf_env_transform_pres {fl : WcbvFlags} {efl : EEnvFlags} we : + ETransformPresFO.t + (rebuild_wf_env_transform we) fo_evalue fo_evalue_map (fun p pr fo => rebuild_wf_env p pr.p1). +Proof. split => //. Qed. + +Lemma wf_glob_lookup_inductive_pars {efl : EEnvFlags} (Σ : E.global_context) (kn : Kernames.kername) : + has_cstr_params = false -> + wf_glob Σ -> + forall pars, EGlobalEnv.lookup_inductive_pars Σ kn = Some pars -> pars = 0. +Proof. + intros hasp wf. + rewrite /EGlobalEnv.lookup_inductive_pars. + destruct EGlobalEnv.lookup_minductive eqn:e => //=. + eapply wellformed_lookup_inductive_pars in e => //. congruence. +Qed. + +#[global] Instance inline_projections_optimization_pres {fl : WcbvFlags} + (efl := EInlineProjections.switch_no_params all_env_flags) {wcon : with_constructor_as_block = false} + {has_rel : has_tRel} {has_box : has_tBox} : + ETransformPresFO.t + (inline_projections_optimization (wcon := wcon) (hastrel := has_rel) (hastbox := has_box)) + fo_evalue_map fo_evalue (fun p pr fo => (EInlineProjections.optimize_env p.1, p.2)). +Proof. split => //. + - intros [] pr fo. + cbn in *. + destruct pr as [pr _]. destruct pr as [pr wf]; cbn in *. + clear wf; move: t1 fo. unfold fo_evalue, fo_evalue_map. cbn. + apply: firstorder_evalue_elim; intros. + econstructor. + rewrite EInlineProjections.lookup_inductive_pars_optimize in H => //; tea. auto. + - rewrite /fo_evalue_map. intros [] pr fo. cbn in *. unfold EInlineProjections.optimize_program. cbn. f_equal. + destruct pr as [[pr _] _]. cbn in *. move: t1 fo. + apply: firstorder_evalue_elim; intros. + eapply wf_glob_lookup_inductive_pars in H => //. subst npars; rewrite skipn_0 in H0 H1. + rewrite EInlineProjections.optimize_mkApps /=. f_equal. + ELiftSubst.solve_all. +Qed. + +#[global] Instance remove_match_on_box_pres {fl : WcbvFlags} {efl : EEnvFlags} {wcon : with_constructor_as_block = false} + {has_rel : has_tRel} {has_box : has_tBox} : + has_cstr_params = false -> + ETransformPresFO.t + (remove_match_on_box_trans (wcon := wcon) (hastrel := has_rel) (hastbox := has_box)) + fo_evalue_map fo_evalue (fun p pr fo => (EOptimizePropDiscr.remove_match_on_box_env p.1, p.2)). +Proof. split => //. + - unfold fo_evalue, fo_evalue_map; intros [] pr fo. cbn in *. + destruct pr as [pr _]. destruct pr as [pr wf]; cbn in *. + clear wf; move: t1 fo. + apply: firstorder_evalue_elim; intros. + econstructor; tea. + rewrite EOptimizePropDiscr.lookup_inductive_pars_optimize in H0 => //; tea. + - intros [] pr fo. + cbn in *. + unfold EOptimizePropDiscr.remove_match_on_box_program; cbn. f_equal. + destruct pr as [[pr _] _]; cbn in *; move: t1 fo. + apply: firstorder_evalue_elim; intros. + eapply wf_glob_lookup_inductive_pars in H0 => //. subst npars; rewrite skipn_0 in H2. + rewrite EOptimizePropDiscr.remove_match_on_box_mkApps /=. f_equal. + ELiftSubst.solve_all. +Qed. + +#[global] Instance remove_params_optimization_pres {fl : WcbvFlags} {wcon : with_constructor_as_block = false} : + ETransformPresFO.t + (remove_params_optimization (wcon := wcon)) + fo_evalue_map fo_evalue (fun p pr fo => (ERemoveParams.strip_env p.1, ERemoveParams.strip p.1 p.2)). +Proof. split => //. + intros [] pr fo. + cbn [transform remove_params_optimization] in *. + destruct pr as [[pr _] _]; cbn -[ERemoveParams.strip] in *; move: t1 fo. + apply: firstorder_evalue_elim; intros. + rewrite ERemoveParams.strip_mkApps //. cbn -[EGlobalEnv.lookup_inductive_pars]. rewrite H. + econstructor. cbn -[EGlobalEnv.lookup_inductive_pars]. + now eapply ERemoveParams.lookup_inductive_pars_strip in H; tea. + rewrite skipn_0 /=. + rewrite skipn_map. + ELiftSubst.solve_all. +Qed. + +#[global] Instance constructors_as_blocks_transformation_pres {efl : EWellformed.EEnvFlags} + {has_app : has_tApp} {has_rel : has_tRel} {hasbox : has_tBox} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : + ETransformPresFO.t + (@constructors_as_blocks_transformation efl has_app has_rel hasbox has_pars has_cstrblocks) + fo_evalue_map (fun p => firstorder_evalue_block p.2) + (fun p pr fo => (transform_blocks_env p.1, compile_evalue_box p.2 [])). +Proof. + split. + - intros v pr fo; eapply compile_evalue_box_firstorder; tea. apply pr. + - move=> [Σ v] /= pr fo. rewrite /flip. + clear pr. move: v fo. + apply: firstorder_evalue_elim; intros. + rewrite /transform_blocks_program /=. f_equal. + rewrite EConstructorsAsBlocks.transform_blocks_decompose. + rewrite EAstUtils.decompose_app_mkApps // /=. + rewrite compile_evalue_box_mkApps app_nil_r. + admit. +Admitted. + + +#[global] Instance guarded_to_unguarded_fix_pres {efl : EWellformed.EEnvFlags} + {has_guard : with_guarded_fix} {has_cstrblocks : with_constructor_as_block = false} : + ETransformPresFO.t + (@guarded_to_unguarded_fix default_wcbv_flags has_cstrblocks efl has_guard) + fo_evalue_map fo_evalue_map + (fun p pr fo => p). +Proof. + split => //. +Qed. + +Lemma lambdabox_pres_fo : + exists compile_value, ETransformPresFO.t verified_lambdabox_pipeline fo_evalue_map (fun p => firstorder_evalue_block p.2) compile_value /\ + forall p pr fo, (compile_value p pr fo).2 = compile_evalue_box (ERemoveParams.strip p.1 p.2) []. +Proof. + eexists. + split. + unfold verified_lambdabox_pipeline. + unshelve eapply ETransformPresFO.compose; tc. shelve. + 2:intros p pr fo; unfold ETransformPresFO.compose_compile_fo_value; f_equal. 2:cbn. + unshelve eapply ETransformPresFO.compose; tc. shelve. + 2:unfold ETransformPresFO.compose_compile_fo_value; cbn. + unshelve eapply ETransformPresFO.compose; tc. shelve. + 2:unfold ETransformPresFO.compose_compile_fo_value; cbn. + unshelve eapply ETransformPresFO.compose; tc. shelve. + 2:unfold ETransformPresFO.compose_compile_fo_value; cbn. + unshelve eapply ETransformPresFO.compose. shelve. eapply remove_match_on_box_pres => //. + unfold ETransformPresFO.compose_compile_fo_value; cbn -[ERemoveParams.strip ERemoveParams.strip_env]. + reflexivity. +Qed. + +Lemma transform_lambda_box_firstorder (Σer : EEnvMap.GlobalContextMap.t) p pre : + firstorder_evalue Σer p -> + (transform verified_lambdabox_pipeline (Σer, p) pre).2 = (compile_evalue_box (ERemoveParams.strip Σer p) []). Proof. intros fo. - now rewrite (ETransformPresFO.transform_fo _ _ (t:=lambdabox_pres_fo)). + destruct lambdabox_pres_fo as [fn [tr hfn]]. + rewrite (ETransformPresFO.transform_fo _ _ _ _ (t:=tr)). + nowrewrite hfn. Qed. Section pipeline_theorem. @@ -488,7 +789,7 @@ Section pipeline_theorem. Let Σ_t := (transform verified_erasure_pipeline (Σ, t) precond).1. Let t_t := (transform verified_erasure_pipeline (Σ, t) precond).2. - Let v_t := compile_value_box v []. + Let v_t := compile_value_box Σ v []. Lemma fo_v : PCUICFirstorder.firstorder_value Σ [] v. Proof. @@ -498,7 +799,6 @@ Section pipeline_theorem. - eapply PCUICWcbvEval.eval_to_value; eauto. Qed. - Lemma v_t_spec : v_t = (transform verified_erasure_pipeline (Σ, v) precond2).2. Proof. unfold v_t. generalize fo_v, precond2. clear. @@ -511,16 +811,18 @@ Section pipeline_theorem. cbn [fst snd]. intros h. destruct_compose. - rewrite erase_transform_fo. cbn. admit. + rewrite erase_transform_fo. cbn. unfold global_env_ext_map_global_env_ext; cbn. + todo "expand lets preserves fo values". set (Σer := (transform erase_transform _ _).1). cbn [fst snd]. intros pre'. symmetry. erewrite transform_lambda_box_firstorder; tea. - eapply obseq_lambdabox. intros kn decl H; exact H. - Unshelve. 2:exact pre'. 2:exact (Σer, compile_value_erase v []). - cbn [snd]. - red. cbn. - Admitted. + now eapply compile_evalue_erase. + clear -hv. + move: v hv; eapply PCUICFirstorder.firstorder_value_inds. + intros. rewrite compile_value_erase_mkApps app_nil_r. + econstructor. ELiftSubst.solve_all. + Qed. Import PCUICWfEnv. diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v index 7d760e3b2..1772da104 100644 --- a/erasure/theories/EInlineProjections.v +++ b/erasure/theories/EInlineProjections.v @@ -422,6 +422,17 @@ Proof. destruct lookup_env as [[decl|]|] => //. Qed. +Lemma lookup_inductive_pars_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : + wf_glob Σ -> + EGlobalEnv.lookup_inductive_pars Σ ind = EGlobalEnv.lookup_inductive_pars (optimize_env Σ) ind. +Proof. + rewrite /lookup_inductive_pars => wf. + rewrite /lookup_inductive /lookup_minductive. + rewrite (lookup_env_optimize ind wf). + rewrite /GlobalContextMap.lookup_inductive /GlobalContextMap.lookup_minductive. + destruct lookup_env as [[decl|]|] => //. +Qed. + Lemma is_propositional_cstr_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : wf_glob Σ -> constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (optimize_env Σ) ind c. diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index 4e50ee4ca..0bbc6b016 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -491,6 +491,16 @@ Proof. destruct lookup_env as [[decl|]|] => //. Qed. +Lemma lookup_inductive_pars_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : + wf_glob Σ -> + EGlobalEnv.lookup_inductive_pars Σ ind = EGlobalEnv.lookup_inductive_pars (remove_match_on_box_env Σ) ind. +Proof. + rewrite /lookup_inductive_pars => wf. + rewrite /lookup_inductive /lookup_minductive. + rewrite (lookup_env_remove_match_on_box ind wf). + rewrite /GlobalContextMap.lookup_inductive /GlobalContextMap.lookup_minductive. + destruct lookup_env as [[decl|]|] => //. +Qed. Lemma closed_iota_red pars c args brs br : forallb (closedn 0) args -> diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v index 4d6937bf0..52a8c3414 100644 --- a/erasure/theories/ERemoveParams.v +++ b/erasure/theories/ERemoveParams.v @@ -430,6 +430,17 @@ Proof. destruct g; simpl; auto. do 2 destruct nth_error => //. Qed. +Lemma lookup_inductive_pars_strip {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : + wf_glob Σ -> + forall pars, lookup_inductive_pars Σ ind = Some pars -> + EGlobalEnv.lookup_inductive_pars (strip_env Σ) ind = Some 0. +Proof. + rewrite /lookup_inductive_pars => wf pars. + rewrite /lookup_inductive /lookup_minductive. + rewrite (lookup_env_strip _ ind). + destruct lookup_env as [[decl|]|] => //=. +Qed. + Arguments eval {wfl}. Arguments isEtaExp : simpl never. From 0e5938a5d1b93ba7b6e1cc3344efd8673dd04c13 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 7 Sep 2023 16:33:11 +0200 Subject: [PATCH 49/65] Finish main erasure correctness proof. Need to move expand_lets reasoning to a first step --- erasure-plugin/theories/ETransform.v | 24 +- erasure-plugin/theories/ErasureCorrectness.v | 412 ++- erasure/_CoqProject.in | 1 + erasure/theories/EArities.v | 21 +- erasure/theories/ESubstitution.v | 8 +- erasure/theories/ErasureCorrectness.v | 26 +- erasure/theories/ErasureFunction.v | 2762 +--------------- erasure/theories/ErasureFunctionProperties.v | 2877 +++++++++++++++++ erasure/theories/Extract.v | 22 +- erasure/theories/Typed/ErasureCorrectness.v | 7 +- .../theories/Typed/ExtractionCorrectness.v | 1 + pcuic/theories/PCUICFirstorder.v | 36 +- 12 files changed, 3225 insertions(+), 2972 deletions(-) create mode 100644 erasure/theories/ErasureFunctionProperties.v diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index bc6694a18..f108396d6 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -8,8 +8,8 @@ Set Warnings "-notation-overridden". From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram PCUICWeakeningEnvSN. Set Warnings "+notation-overridden". From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICWfEnvImpl. -From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness Extract - EOptimizePropDiscr ERemoveParams EProgram. +From MetaCoq.Erasure Require EAstUtils ErasureCorrectness Extract EOptimizePropDiscr ERemoveParams EProgram. +From MetaCoq.Erasure Require Import ErasureFunction ErasureFunctionProperties. From MetaCoq.TemplatePCUIC Require Import PCUICTransform. Import PCUICAst (term) PCUICProgram PCUICTransform (eval_pcuic_program) Extract EProgram @@ -148,14 +148,14 @@ Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_ let wfext := @abstract_make_wf_env_ext _ optimized_abstract_env_impl wfe p.1.2 _ in let t := ErasureFunction.erase (normalization_in:=_) optimized_abstract_env_impl wfext nil p.2 (fun Σ wfΣ => let '(sq (T; ty)) := wt in PCUICTyping.iswelltyped ty) in - let Σ' := ErasureFunction.erase_global_fast (normalization_in:=_) optimized_abstract_env_impl + let Σ' := ErasureFunctionProperties.erase_global_fast (normalization_in:=_) optimized_abstract_env_impl (EAstUtils.term_global_deps t) wfe (p.1.(PCUICAst.PCUICEnvironment.declarations)) _ in (EEnvMap.GlobalContextMap.make Σ'.1 _, t). Next Obligation. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. Defined. Next Obligation. eapply wf_glob_fresh. - eapply ErasureFunction.erase_global_fast_wf_glob. + eapply ErasureFunctionProperties.erase_global_fast_wf_glob. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. Defined. @@ -175,9 +175,9 @@ Lemma expanded_erase_program {guard : abstract_guard_impl} p {normalization_in n Proof. intros [etaenv etat]. split; unfold erase_program, erase_pcuic_program. - eapply ErasureFunction.expanded_erase_global_fast, etaenv; try reflexivity; eauto. + eapply ErasureFunctionProperties.expanded_erase_global_fast, etaenv; try reflexivity; eauto. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. - apply: (ErasureFunction.expanded_erase_fast (X_type:=optimized_abstract_env_impl)). + apply: (ErasureFunctionProperties.expanded_erase_fast (X_type:=optimized_abstract_env_impl)). unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. reflexivity. exact etat. Qed. @@ -214,14 +214,14 @@ Next Obligation. destruct erase_program eqn:e. split. - unfold erase_program, erase_pcuic_program in e. - set (egf := ErasureFunction.erase_global_fast _ _ _ _ _) in e. - set (ef := ErasureFunction.erase _ _ _ _ _) in e. + set (egf := erase_global_fast _ _ _ _ _) in e. + set (ef := erase _ _ _ _ _) in e. cbn -[egf ef] in e. injection e. intros <- <-. split. - eapply ErasureFunction.erase_global_fast_wf_glob; eauto; + eapply erase_global_fast_wf_glob; eauto; try match goal with H : _ |- _ => eapply H end. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. - apply: (ErasureFunction.erase_wellformed_fast (X_type:=optimized_abstract_env_impl)); eauto; + apply: (erase_wellformed_fast (X_type:=optimized_abstract_env_impl)); eauto; try match goal with H : _ |- _ => eapply H end. unshelve edestruct erase_pcuic_program_normalization_helper; cbn in *; eauto. - rewrite -e. cbn. @@ -240,8 +240,8 @@ Next Obligation. set (Σ' := build_wf_env_from_env _ _). assert (ev' :forall Σ0 : PCUICAst.PCUICEnvironment.global_env, Σ0 = Σ' -> PCUICWcbvEval.eval Σ0 t v). { intros; now subst. } - eapply (ErasureFunction.erase_correct optimized_abstract_env_impl Σ' Σ.2 _ _ _ _ _ (EAstUtils.term_global_deps _)) in ev'. - 4:{ erewrite <- ErasureFunction.erase_global_deps_fast_spec. reflexivity. } + eapply (erase_correct optimized_abstract_env_impl Σ' Σ.2 _ _ _ _ _ (EAstUtils.term_global_deps _)) in ev'. + 4:{ erewrite <- erase_global_deps_fast_spec. reflexivity. } all:trea. 2:eapply Kernames.KernameSet.subset_spec; reflexivity. destruct ev' as [v' [he [hev]]]. exists v'; split => //. diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 5c0facb2e..5b32b75a6 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -4,9 +4,9 @@ From MetaCoq.Common Require Import Transform config. From MetaCoq.Utils Require Import bytestring utils. From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram. From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl. -From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness EPretty Extract. +From MetaCoq.Erasure Require EAstUtils ErasureCorrectness EPretty Extract. From MetaCoq Require Import ETransform EConstructorsAsBlocks. -From MetaCoq.Erasure Require Import EWcbvEvalNamed. +From MetaCoq.Erasure Require Import EWcbvEvalNamed ErasureFunction ErasureFunctionProperties. From MetaCoq.ErasurePlugin Require Import Erasure. Import PCUICProgram. (* Import TemplateProgram (template_eta_expand). @@ -269,7 +269,7 @@ Lemma extends_erase_pcuic_program (efl := EWcbvEval.default_wcbv_flags) {guard : @PCUICFirstorder.firstorder_ind Σ (PCUICFirstorder.firstorder_env Σ) i -> let pt := @erase_pcuic_program guard (Σ, t) nin0 nin0' wf' ty' in let pv := @erase_pcuic_program guard (Σ, v) nin nin' wf ty in - EGlobalEnv.extends pv.1 pt.1 /\ ∥ eval pt.1 pt.2 pv.2 ∥. + EGlobalEnv.extends pv.1 pt.1 /\ ∥ eval pt.1 pt.2 pv.2 ∥ /\ firstorder_evalue pt.1 pv.2. Proof. intros ev axf ht fo. cbn -[erase_pcuic_program]. @@ -285,26 +285,25 @@ Proof. set (env := build_wf_env_from_env _ _). set (X := PCUICWfEnv.abstract_make_wf_env_ext _ _ _). set (X' := PCUICWfEnv.abstract_make_wf_env_ext _ _ _). - unfold ErasureFunction.erase_global_fast. + unfold erase_global_fast. set (prf7 := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). set (et := ErasureFunction.erase _ _ _ _ _). set (et' := ErasureFunction.erase _ _ _ _ _). destruct Σ as [Σ ext]. cbn -[et et' PCUICWfEnv.abstract_make_wf_env_ext] in *. - unshelve (epose proof ErasureFunction.erase_global_deps_fast_erase_global_deps as [norm eq]; + unshelve (epose proof erase_global_deps_fast_erase_global_deps as [norm eq]; erewrite eq). { cbn. now intros ? ->. } - unshelve (epose proof ErasureFunction.erase_global_deps_fast_erase_global_deps as [norm' eq']; + unshelve (epose proof erase_global_deps_fast_erase_global_deps as [norm' eq']; erewrite eq'). { cbn. now intros ? ->. } set (prf := (fun (Σ0 : PCUICAst.PCUICEnvironment.global_env) => _)). cbn in prf. rewrite (ErasureFunction.erase_global_deps_irr optimized_abstract_env_impl (EAstUtils.term_global_deps et) env' env _ prf prf). { cbn. now intros ? ? -> ->. } clearbody prf0 prf1 prf2 prf3 prf4 prf5 prf6 prf7. - epose proof (ErasureFunction.erase_correct_strong optimized_abstract_env_impl (v:=v) env ext prf2 + epose proof (erase_correct_strong optimized_abstract_env_impl (v:=v) env ext prf2 (PCUICAst.PCUICEnvironment.declarations Σ) norm' prf prf6 X eq_refl axf ht fo). pose proof wf as []. - forward H by (eapply Kernames.KernameSet.subset_spec; reflexivity). forward H by unshelve (eapply PCUICClassification.wcbveval_red; tea). forward H. { intros [? hr]. @@ -312,14 +311,18 @@ Proof. eapply PCUICFirstorder.firstorder_value_spec; tea. apply X0. constructor. eapply PCUICClassification.subject_reduction_eval; tea. eapply PCUICWcbvEval.eval_to_value; tea. } - destruct H as [wt' []]. + destruct H as [wt' [[] hfo]]. split => //. - eapply (ErasureFunction.erase_global_deps_eval optimized_abstract_env_impl env env' ext). + eapply (erase_global_deps_eval optimized_abstract_env_impl env env' ext). unshelve erewrite (ErasureFunction.erase_irrel_global_env (X_type:=optimized_abstract_env_impl) (t:=v)); tea. red. intros. split; reflexivity. + split => //. sq. unfold et', et. unshelve erewrite (ErasureFunction.erase_irrel_global_env (X_type:=optimized_abstract_env_impl) (t:=v)); tea. red. intros. split; reflexivity. + subst et et' X X'. + unshelve erewrite (ErasureFunction.erase_irrel_global_env (X_type:=optimized_abstract_env_impl) (t:=v)); tea. + red. intros. split; reflexivity. Qed. Lemma expand_lets_fo (Σ : global_env_ext_map) t : @@ -336,23 +339,170 @@ Proof. now eapply forall_map_id_spec. Qed. +Definition pcuic_lookup_inductive_pars Σ ind := + match PCUICAst.PCUICEnvironment.lookup_env Σ (Kernames.inductive_mind ind) with + | Some (PCUICAst.PCUICEnvironment.InductiveDecl mdecl) => Some mdecl.(PCUICAst.PCUICEnvironment.ind_npars) + | _ => None + end. + Fixpoint compile_value_box Σ (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := match t with | PCUICAst.tApp f a => compile_value_box Σ f (compile_value_box Σ a [] :: acc) | PCUICAst.tConstruct i n _ => - match PCUICAst.PCUICEnvironment.lookup_env Σ (Kernames.inductive_mind i) with - | Some (PCUICAst.PCUICEnvironment.InductiveDecl mdecl) => - EAst.tConstruct i n (skipn mdecl.(PCUICAst.PCUICEnvironment.ind_npars) acc) - | _ => EAst.tVar "error" + match pcuic_lookup_inductive_pars Σ i with + | Some npars => EAst.tConstruct i n (skipn npars acc) + | None => EAst.tVar "error" end | _ => EAst.tVar "error" end. From Equations Require Import Equations. + +Inductive firstorder_evalue_block : EAst.term -> Prop := + | is_fo_block i n args : + Forall (firstorder_evalue_block) args -> + firstorder_evalue_block (EAst.tConstruct i n args). + +Lemma firstorder_evalue_block_elim {P : EAst.term -> Prop} : + (forall i n args, + Forall firstorder_evalue_block args -> + Forall P args -> + P (EAst.tConstruct i n args)) -> + forall t, firstorder_evalue_block t -> P t. +Proof. + intros Hf. + fix aux 2. + intros t fo; destruct fo. + eapply Hf => //. + move: args H. + fix aux' 2. + intros args []; constructor. + now apply aux. now apply aux'. +Qed. + +Import EWcbvEval. +Arguments erase_global_deps _ _ _ _ _ : clear implicits. +Arguments erase_global_deps_fast _ _ _ _ _ _ : clear implicits. + +(*Lemma erase_pcuic_program_spec {guard : abstract_guard_impl} + (p : pcuic_program) + (nin : (wf_ext p.1 -> PCUICSN.NormalizationIn p.1)) + (nin' : (wf_ext p.1 -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p.1)) + (wfext : ∥ wf_ext p.1 ∥) + (wt : ∥ ∑ T : PCUICAst.term, p.1;;; [] |- p.2 : T ∥) : + erase_pcuic_program p nin nin'wfext wt = + let et' := @erase optimized_abstract_env_impl + @erase_global_deps optimized_abstract_env_impl*) + +Section PCUICProof. + Import PCUICAst.PCUICEnvironment. + + Definition erase_preserves_inductives Σ Σ' := + (forall kn decl decl', EGlobalEnv.lookup_env Σ' kn = Some (EAst.InductiveDecl decl) -> + lookup_env Σ kn = Some (PCUICAst.PCUICEnvironment.InductiveDecl decl') -> + decl = erase_mutual_inductive_body decl'). + + Lemma lookup_env_in_erase_global_deps X_type X deps decls kn normalization_in prf decl : + EnvMap.EnvMap.fresh_globals decls -> + EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf).1 kn = Some (EAst.InductiveDecl decl) -> + exists decl', lookup_global decls kn = Some (InductiveDecl decl') /\ decl = erase_mutual_inductive_body decl'. + Proof. + induction decls in deps, X, normalization_in, prf |- *; cbn [erase_global_deps] => //. + destruct a => //. destruct g => //. + - case: (knset_mem_spec k deps) => // hdeps. + cbn [EGlobalEnv.lookup_env fst lookup_env lookup_global]. + { destruct (eqb_spec kn k) => //. + intros hl. eapply IHdecls. now depelim hl. } + { intros hl. depelim hl. + intros hl'. + eapply IHdecls in hl. destruct hl. + exists x. + cbn. + destruct (eqb_spec kn k) => //. subst k. + destruct H0. + now eapply PCUICWeakeningEnv.lookup_global_Some_fresh in H0. + exact hl'. } + - intros hf; depelim hf. + case: (knset_mem_spec k deps) => // hdeps. + cbn [EGlobalEnv.lookup_env fst lookup_env lookup_global]. + { destruct (eqb_spec kn k) => //. + intros hl. noconf hl. subst k. eexists; split; cbn; eauto. + intros hl'. eapply IHdecls => //. tea. } + { intros hl'. eapply IHdecls in hf; tea. destruct hf. + exists x. + cbn. + destruct (eqb_spec kn k) => //. subst k. + destruct H0. + now eapply PCUICWeakeningEnv.lookup_global_Some_fresh in H0. } + Qed. + + Lemma erase_tranform_firstorder (no := PCUICSN.extraction_normalizing) (wfl := default_wcbv_flags) + {p : Transform.program global_env_ext_map PCUICAst.term} {pr v i u args} + {normalization_in : PCUICSN.NormalizationIn p.1} : + forall (wt : p.1 ;;; [] |- p.2 : PCUICAst.mkApps (PCUICAst.tInd i u) args), + axiom_free p.1 -> + @PCUICFirstorder.firstorder_ind p.1 (PCUICFirstorder.firstorder_env p.1) i -> + PCUICWcbvEval.eval p.1 p.2 v -> + forall ep, transform erase_transform p pr = ep -> + erase_preserves_inductives p.1 ep.1 /\ + ∥ EWcbvEval.eval ep.1 ep.2 (compile_value_erase v []) ∥ /\ + firstorder_evalue ep.1 (compile_value_erase v []). + Proof. + destruct p as [Σ t]; cbn. + intros ht ax fo ev [Σe te]; cbn. + unfold erase_program, erase_pcuic_program. + set (obl := ETransform.erase_pcuic_program_obligation_6 _ _ _ _ _ _). + move: obl. + rewrite /erase_global_fast. + set (prf0 := fun (Σ0 : global_env) => _). + set (prf1 := fun (Σ0 : global_env_ext) => _). + set (prf2 := fun (Σ0 : global_env_ext) => _). + set (prf3 := fun (Σ0 : global_env) => _). + set (prf4 := fun n (H : n < _) => _). + set (gext := PCUICWfEnv.abstract_make_wf_env_ext _ _ _). + set (et := erase _ _ _ _ _). + set (g := build_wf_env_from_env _ _). + assert (hprefix: forall Σ0 : global_env, PCUICWfEnv.abstract_env_rel g Σ0 -> declarations Σ0 = declarations g). + { intros Σ' eq; cbn in eq. rewrite eq; reflexivity. } + destruct (@erase_global_deps_fast_erase_global_deps (EAstUtils.term_global_deps et) optimized_abstract_env_impl g + (declarations Σ) prf4 prf3 hprefix) as [nin' eq]. + cbn [fst snd]. + rewrite eq. + set (eg := erase_global_deps _ _ _ _ _ _). + intros obl. + epose proof (@erase_correct_strong optimized_abstract_env_impl g Σ.2 prf0 t v i u args _ _ hprefix prf1 prf2 Σ eq_refl ax ht fo). + pose proof (proj1 pr) as [[]]. + forward H. eapply PCUICClassification.wcbveval_red; tea. + assert (PCUICFirstorder.firstorder_value Σ [] v). + { eapply PCUICFirstorder.firstorder_value_spec; tea. apply w. constructor. + eapply PCUICClassification.subject_reduction_eval; tea. + eapply PCUICWcbvEval.eval_to_value; tea. } + forward H. + { intros [v' redv]. eapply PCUICNormalization.firstorder_value_irred; tea. } + destruct H as [wt' [ev' fo']]. + assert (erase optimized_abstract_env_impl (PCUICWfEnv.abstract_make_wf_env_ext (X_type:=optimized_abstract_env_impl) g Σ.2 prf0) [] v wt' = + compile_value_erase v []). + { clear -H0. + clearbody prf0 prf1. + destruct pr as []. + destruct s as [[]]. + epose proof (erases_erase (X_type := optimized_abstract_env_impl) wt' _ eq_refl). + eapply erases_firstorder' in H; eauto. } + rewrite H in ev', fo'. + intros [=]; subst te Σe. + split => //. + cbn. subst eg. + intros kn decl decl' hl hl'. + eapply lookup_env_in_erase_global_deps in hl as [decl'' [hl eq']]. + rewrite /lookup_env hl in hl'. now noconf hl'. + eapply wf_fresh_globals, w. + Qed. +End PCUICProof. Lemma erase_transform_fo_gen (p : pcuic_program) pr : PCUICFirstorder.firstorder_value p.1 [] p.2 -> - forall ep, transform erase_transform p pr = ep -> ep.2 = compile_value_erase p.2 []. + forall ep, transform erase_transform p pr = ep -> + ep.2 = compile_value_erase p.2 []. Proof. destruct p as [Σ t]. cbn. intros hev ep <-. move: hev pr. @@ -377,87 +527,6 @@ Proof. eapply erase_transform_fo_gen; tea. reflexivity. Qed. -Inductive firstorder_evalue Σ : EAst.term -> Prop := - | is_fo i n args npars : - EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> - Forall (firstorder_evalue Σ) (skipn npars args) -> - firstorder_evalue Σ (EAst.mkApps (EAst.tConstruct i n []) args). - -Lemma list_size_skipn {A} (l : list A) size n : - list_size size (skipn n l) <= list_size size l. -Proof. - induction n in l |- *. - - rewrite skipn_0 //. - - destruct l. rewrite skipn_nil. now cbn. - rewrite skipn_S. cbn. specialize (IHn l); lia. -Qed. - -Section elim. - Context (Σ : E.global_context). - Context (P : EAst.term -> Prop). - Context (ih : (forall i n args npars, - EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> - Forall (firstorder_evalue Σ) (skipn npars args) -> - Forall P (skipn npars args) -> - P (EAst.mkApps (EAst.tConstruct i n []) args))). - - Equations? firstorder_evalue_elim (t : EAst.term) (fo : firstorder_evalue Σ t) : P t by wf t (MR lt EInduction.size) := - { | _, is_fo i n args npars hl hf => _ }. - Proof. - eapply ih; tea. - eapply In_Forall. intros x hin. - eapply PCUICWfUniverses.Forall_In in hf; tea. - apply firstorder_evalue_elim => //. red. - rewrite EInduction.size_mkApps. - eapply (In_size id EInduction.size) in hin. - unfold id in *. pose proof (list_size_skipn args EInduction.size npars). - change (fun x => EInduction.size x) with EInduction.size in hin. clear -hin H. - eapply Nat.lt_le_trans; tea. cbn. lia. - Qed. -End elim. - -(*Lemma firstorder_evalue_elim Σ {P : EAst.term -> Prop} : - (forall i n args npars, - EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> - Forall (firstorder_evalue Σ) (skipn npars args) -> - Forall P (skipn npars args) -> - P (EAst.mkApps (EAst.tConstruct i n []) args)) -> - forall t, firstorder_evalue Σ t -> P t. -Proof. - intros Hf. - induction t using term_size - fix aux 2. - intros t fo; destruct fo.x - eapply Hf => //; tea. - clear H. - move: H0. - move: args H0. - fix aux' 2. - intros args []; constructor. - now apply aux. now apply aux'. -Qed.*) - -Inductive firstorder_evalue_block : EAst.term -> Prop := - | is_fo_block i n args : - Forall (firstorder_evalue_block) args -> - firstorder_evalue_block (EAst.tConstruct i n args). - -Lemma firstorder_evalue_block_elim {P : EAst.term -> Prop} : - (forall i n args, - Forall firstorder_evalue_block args -> - Forall P args -> - P (EAst.tConstruct i n args)) -> - forall t, firstorder_evalue_block t -> P t. -Proof. - intros Hf. - fix aux 2. - intros t fo; destruct fo. - eapply Hf => //. - move: args H. - fix aux' 2. - intros args []; constructor. - now apply aux. now apply aux'. -Qed. (* Import PCUICAst. @@ -467,13 +536,6 @@ Lemma compile_fo_value (Σ : global_env_ext) Σ' t : firstorder_evalue Σ (compile_value_erase t []). Proof. Admitted. *) -Fixpoint compile_evalue_box (t : EAst.term) (acc : list EAst.term) := - match t with - | EAst.tApp f a => compile_evalue_box f (compile_evalue_box a [] :: acc) - | EAst.tConstruct i n _ => EAst.tConstruct i n acc - | _ => EAst.tVar "error" - end. - Import MetaCoq.Common.Transform. From Coq Require Import Morphisms. @@ -552,40 +614,97 @@ End ETransformPresFO. Import EWellformed. -Lemma compile_value_box_mkApps Σ i n ui args acc : +Fixpoint compile_evalue_box_strip Σ (t : EAst.term) (acc : list EAst.term) := + match t with + | EAst.tApp f a => compile_evalue_box_strip Σ f (compile_evalue_box_strip Σ a [] :: acc) + | EAst.tConstruct i n _ => + match lookup_inductive_pars Σ (Kernames.inductive_mind i) with + | Some npars => EAst.tConstruct i n (skipn npars acc) + | None => EAst.tVar "error" + end + | _ => EAst.tVar "error" + end. + +Fixpoint compile_evalue_box (t : EAst.term) (acc : list EAst.term) := + match t with + | EAst.tApp f a => compile_evalue_box f (compile_evalue_box a [] :: acc) + | EAst.tConstruct i n _ => EAst.tConstruct i n acc + | _ => EAst.tVar "error" + end. + +Lemma compile_value_box_mkApps {Σ i n ui args npars acc} : + pcuic_lookup_inductive_pars Σ i = Some npars -> compile_value_box Σ (PCUICAst.mkApps (PCUICAst.tConstruct i n ui) args) acc = - EAst.tConstruct i n (List.map (flip compile_value_box []) args ++ acc). + EAst.tConstruct i n (skipn npars (List.map (flip (compile_value_box Σ) []) args ++ acc)). Proof. revert acc; induction args using rev_ind. - - cbn. auto. + - intros acc. cbn. intros ->. reflexivity. - intros acc. rewrite PCUICAstUtils.mkApps_app /=. cbn. - now rewrite IHargs map_app /= -app_assoc /=. + intros hl. + now rewrite IHargs // map_app /= -app_assoc /=. Qed. -Lemma compile_evalue_box_mkApps i n ui args acc : +Lemma compile_evalue_box_strip_mkApps {Σ i n ui args acc npars} : + lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + compile_evalue_box_strip Σ (EAst.mkApps (EAst.tConstruct i n ui) args) acc = + EAst.tConstruct i n (skipn npars (List.map (flip (compile_evalue_box_strip Σ) []) args ++ acc)). +Proof. + revert acc; induction args using rev_ind. + - intros acc. cbn. intros ->. auto. + - intros acc hl. rewrite EAstUtils.mkApps_app /=. cbn. + now rewrite IHargs // map_app /= -app_assoc /=. +Qed. + +Lemma compile_evalue_box_mkApps {i n ui args acc} : compile_evalue_box (EAst.mkApps (EAst.tConstruct i n ui) args) acc = EAst.tConstruct i n (List.map (flip compile_evalue_box []) args ++ acc). Proof. revert acc; induction args using rev_ind. - - cbn. auto. + - now intros acc. - intros acc. rewrite EAstUtils.mkApps_app /=. cbn. - now rewrite IHargs map_app /= -app_assoc /=. + now rewrite IHargs // map_app /= -app_assoc /=. Qed. +Derive Signature for firstorder_evalue. -Lemma compile_evalue_erase Σ v : +Lemma compile_evalue_erase (Σ : PCUICAst.PCUICEnvironment.global_env_ext) (Σ' : EEnvMap.GlobalContextMap.t) v : + wf Σ.1 -> PCUICFirstorder.firstorder_value Σ [] v -> - compile_evalue_box (compile_value_erase v []) [] = compile_value_box v []. + firstorder_evalue Σ' (compile_value_erase v []) -> + erase_preserves_inductives (PCUICAst.PCUICEnvironment.fst_ctx Σ) Σ' -> + compile_evalue_box_strip Σ' (compile_value_erase v []) [] = compile_value_box (PCUICAst.PCUICEnvironment.fst_ctx Σ) v []. Proof. - move=> fo; move: v fo. + move=> wf fo fo' hΣ; move: v fo fo'. apply: PCUICFirstorder.firstorder_value_inds. intros i n ui u args pandi hty hargs ih isp. - rewrite compile_value_erase_mkApps compile_value_box_mkApps compile_evalue_box_mkApps. + eapply PCUICInductiveInversion.Construct_Ind_ind_eq' in hty as [mdecl [idecl [cdecl [declc _]]]] => //. + rewrite compile_value_erase_mkApps. + intros fo'. depelim fo'. EAstUtils.solve_discr. noconf H1. + assert (npars = PCUICAst.PCUICEnvironment.ind_npars mdecl). + { destruct declc as [[declm decli] declc]. + unshelve eapply declared_minductive_to_gen in declm. 3:exact wf. red in declm. + rewrite /EGlobalEnv.lookup_inductive_pars /EGlobalEnv.lookup_minductive in H. + destruct (PCUICAst.PCUICEnvironment.lookup_env) eqn:hl => //. + noconf declm. + destruct (EGlobalEnv.lookup_env) eqn:hl' => //. destruct g => //. + red in hΣ. + eapply hΣ in hl'; tea. cbn in H. noconf H. subst m. reflexivity. } + subst npars. + rewrite (compile_value_box_mkApps (npars := PCUICAst.PCUICEnvironment.ind_npars mdecl)). + { destruct declc as [[declm decli] declc]. + unshelve eapply declared_minductive_to_gen in declm. 3:exact wf. + rewrite /PCUICAst.declared_minductive_gen in declm. + rewrite /pcuic_lookup_inductive_pars // declm //. } + rewrite (compile_evalue_box_strip_mkApps (npars := PCUICAst.PCUICEnvironment.ind_npars mdecl)) //. + rewrite lookup_inductive_pars_spec //. rewrite !app_nil_r. f_equal. - rewrite map_map. - now eapply map_ext_Forall. + rewrite app_nil_r skipn_map in H0. + eapply Forall_map_inv in H0. + eapply (Forall_skipn _ (PCUICAst.PCUICEnvironment.ind_npars mdecl)) in ih. + rewrite !skipn_map /flip map_map. + ELiftSubst.solve_all. Qed. -Lemma compile_evalue_box_firstorder {efl : EEnvFlags} Σ v : +Lemma compile_evalue_box_firstorder {efl : EEnvFlags} {Σ : EEnvMap.GlobalContextMap.t} v : has_cstr_params = false -> EWellformed.wf_glob Σ -> firstorder_evalue Σ v -> firstorder_evalue_block (flip compile_evalue_box [] v). @@ -593,7 +712,7 @@ Proof. intros hpars wf. move: v; apply: firstorder_evalue_elim. intros. - rewrite /flip compile_evalue_box_mkApps app_nil_r. + rewrite /flip (compile_evalue_box_mkApps) // ?app_nil_r. rewrite /EGlobalEnv.lookup_inductive_pars /= in H. destruct EGlobalEnv.lookup_minductive eqn:e => //. eapply wellformed_lookup_inductive_pars in hpars; tea => //. @@ -697,7 +816,8 @@ Proof. rewrite /transform_blocks_program /=. f_equal. rewrite EConstructorsAsBlocks.transform_blocks_decompose. rewrite EAstUtils.decompose_app_mkApps // /=. - rewrite compile_evalue_box_mkApps app_nil_r. + rewrite compile_evalue_box_mkApps // ?app_nil_r. + (* rewrite lookup_inductive_pars_spec //. *) admit. Admitted. @@ -739,9 +859,17 @@ Proof. intros fo. destruct lambdabox_pres_fo as [fn [tr hfn]]. rewrite (ETransformPresFO.transform_fo _ _ _ _ (t:=tr)). - nowrewrite hfn. + now rewrite hfn. Qed. +Lemma compile_evalue_strip (Σer : EEnvMap.GlobalContextMap.t) p : + firstorder_evalue Σer p -> + compile_evalue_box (ERemoveParams.strip Σer p) [] = compile_evalue_box_strip Σer p []. +Proof. +Admitted. + +Arguments PCUICFirstorder.firstorder_ind _ _ : clear implicits. + Section pipeline_theorem. Instance cf : checker_flags := extraction_checker_flags. @@ -782,14 +910,14 @@ Section pipeline_theorem. - red. cbn. split; eauto. eexists. eapply PCUICClassification.subject_reduction_eval; eauto. - - todo "preservation of eta expandedness". + - todo "preservation of eta expandedness". - cbn. todo "normalization". - todo "normalization". Qed. Let Σ_t := (transform verified_erasure_pipeline (Σ, t) precond).1. Let t_t := (transform verified_erasure_pipeline (Σ, t) precond).2. - Let v_t := compile_value_box Σ v []. + Let v_t := compile_value_box (PCUICExpandLets.trans_global_env Σ) v []. Lemma fo_v : PCUICFirstorder.firstorder_value Σ [] v. Proof. @@ -801,7 +929,7 @@ Section pipeline_theorem. Lemma v_t_spec : v_t = (transform verified_erasure_pipeline (Σ, v) precond2).2. Proof. - unfold v_t. generalize fo_v, precond2. clear. + unfold v_t. generalize fo_v, precond2. intros hv pre. unfold verified_erasure_pipeline. rewrite -transform_compose_assoc. @@ -811,23 +939,40 @@ Section pipeline_theorem. cbn [fst snd]. intros h. destruct_compose. - rewrite erase_transform_fo. cbn. unfold global_env_ext_map_global_env_ext; cbn. - todo "expand lets preserves fo values". + assert (PCUICFirstorder.firstorder_value (PCUICExpandLets.trans_global_env Σ.1, Σ.2) [] v). + { todo "expand lets preserves fo values". } + assert (Normalisation': PCUICSN.NormalizationIn (PCUICExpandLets.trans_global Σ)). + { destruct h as [[] ?]. apply H0. cbn. apply X. } + set (Σ' := build_global_env_map _). + set (p := transform erase_transform _ _). + pose proof (@erase_tranform_firstorder _ h v i u args Normalisation'). + forward H0. + { todo "preserves typing of fo values". } + forward H0. + { cbn. todo "preserves axiom freeness". } + forward H0. + { cbn. todo "preserves fo ind". } + forward H0. + { cbn. todo "preserves values". } + specialize (H0 _ eq_refl). + rewrite /p. + rewrite erase_transform_fo //. set (Σer := (transform erase_transform _ _).1). cbn [fst snd]. intros pre'. symmetry. + destruct Heval as [Heval']. + assert (firstorder_evalue Σer (compile_value_erase v [])). + { apply H0. } erewrite transform_lambda_box_firstorder; tea. - now eapply compile_evalue_erase. - clear -hv. - move: v hv; eapply PCUICFirstorder.firstorder_value_inds. - intros. rewrite compile_value_erase_mkApps app_nil_r. - econstructor. ELiftSubst.solve_all. + rewrite compile_evalue_strip //. + destruct pre as [[wt] ?]. destruct wt. + apply (compile_evalue_erase (PCUICExpandLets.trans_global Σ) Σer) => //. + { cbn. now eapply (@PCUICExpandLetsCorrectness.trans_wf extraction_checker_flags Σ). } + destruct H0. cbn -[transform erase_transform] in H0. apply H0. Qed. Import PCUICWfEnv. - - Lemma verified_erasure_pipeline_theorem : ∥ eval (wfl := extraction_wcbv_flags) Σ_t t_t v_t∥. Proof. @@ -891,7 +1036,7 @@ Section pipeline_theorem. destruct H. destruct s as [[]]. set (wfe := build_wf_env_from_env em (map_squash (PCUICTyping.wf_ext_wf (em, Σ.2)) (map_squash fst (conj (sq (w0, s)) a).p1))). destruct Heval. - eapply (ErasureFunction.firstorder_erases_deterministic optimized_abstract_env_impl wfe Σ.2) in b0. 3:tea. + eapply (ErasureFunctionProperties.firstorder_erases_deterministic optimized_abstract_env_impl wfe Σ.2) in b0. 3:tea. 2:{ cbn. reflexivity. } 2:{ eapply PCUICExpandLetsCorrectness.trans_wcbveval. eapply PCUICWcbvEval.eval_closed; tea. apply HΣ. admit. @@ -908,6 +1053,7 @@ Section pipeline_theorem. clear obs b0 ev e w. eapply extends_erase_pcuic_program. cbn. eapply (PCUICExpandLetsCorrectness.trans_wcbveval (Σ := (Σ.1, Σ.2))). admit. exact X0. + cbn. 2:cbn. 3:cbn. Admitted. Lemma verified_erasure_pipeline_lambda : diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in index 3a16a4112..5397184fa 100644 --- a/erasure/_CoqProject.in +++ b/erasure/_CoqProject.in @@ -26,6 +26,7 @@ theories/EArities.v theories/ErasureProperties.v theories/ErasureCorrectness.v theories/ErasureFunction.v +theories/ErasureFunctionProperties.v theories/EExtends.v theories/EOptimizePropDiscr.v theories/EEtaExpandedFix.v diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index 3b11eeb08..666de6ffb 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -10,7 +10,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICWellScopedCumulativity PCUICContextConversion PCUICConversion PCUICClassification PCUICSpine PCUICInductives PCUICInductiveInversion PCUICConfluence - PCUICArities PCUICPrincipality. + PCUICArities PCUICPrincipality PCUICFirstorder. From MetaCoq.Erasure Require Import Extract. @@ -836,7 +836,7 @@ Qed. Lemma isErasable_Propositional {Σ : global_env_ext} {Γ ind n u args} : wf_ext Σ -> - isErasable Σ Γ (mkApps (tConstruct ind n u) args) -> isPropositional Σ ind true. + isErasable Σ Γ (mkApps (tConstruct ind n u) args) -> isPropositional Σ ind. Proof. intros wfΣ ise. eapply tConstruct_no_Type in ise; eauto. @@ -871,7 +871,7 @@ Qed. Lemma nisErasable_Propositional {Σ : global_env_ext} {Γ ind n u} : wf_ext Σ -> welltyped Σ Γ (tConstruct ind n u) -> - (isErasable Σ Γ (tConstruct ind n u) -> False) -> isPropositional Σ ind false. + (isErasable Σ Γ (tConstruct ind n u) -> False) -> ~~ isPropositional Σ ind. Proof. intros wfΣ wt ise. destruct wt as [T HT]. @@ -881,7 +881,7 @@ Proof. pose proof d as [decli ?]. destruct (on_declared_constructor d). destruct p as [onind oib]. - red. unfold lookup_inductive. + unfold isPropositional, lookup_inductive. pose proof (wfΣ' := wfΣ.1). unshelve epose proof (decli_ := declared_inductive_to_gen decli); eauto. rewrite (declared_inductive_lookup_gen decli_). @@ -925,18 +925,18 @@ Lemma isPropositional_propositional Σ {wfΣ: wf Σ} (Σ' : E.global_context) in EGlobalEnv.declared_inductive Σ' ind mdecl' idecl' -> erases_mutual_inductive_body mdecl mdecl' -> erases_one_inductive_body idecl idecl' -> - forall b, isPropositional Σ ind b -> EGlobalEnv.inductive_isprop_and_pars Σ' ind = Some (b, mdecl.(ind_npars)). + EGlobalEnv.inductive_isprop_and_pars Σ' ind = Some (isPropositional Σ ind, mdecl.(ind_npars)). Proof. - intros decli decli' [_ indp] [] b. + intros decli decli' [_ indp] []. unfold isPropositional, EGlobalEnv.inductive_isprop_and_pars. unfold lookup_inductive. unshelve epose proof (decli_ := declared_inductive_to_gen decli); eauto. rewrite (declared_inductive_lookup_gen decli_). rewrite (EGlobalEnv.declared_inductive_lookup decli') /= /isPropositionalArity. - destruct H0 as [_ [_ [_ isP]]]. red in isP. + destruct H0 as [_ [_ [_ isP]]]. unfold isPropositionalArity in isP. destruct destArity as [[ctx s]|] eqn:da => //. - rewrite isP. intros ->. f_equal. f_equal. now rewrite indp. + rewrite isP; congruence. congruence. Qed. Lemma isPropositional_propositional_cstr Σ (Σ' : E.global_context) ind c mdecl idecl cdecl mdecl' idecl' : @@ -945,11 +945,10 @@ Lemma isPropositional_propositional_cstr Σ (Σ' : E.global_context) ind c mdecl EGlobalEnv.declared_inductive Σ' ind mdecl' idecl' -> erases_mutual_inductive_body mdecl mdecl' -> erases_one_inductive_body idecl idecl' -> - forall b, isPropositional Σ ind b -> EGlobalEnv.constructor_isprop_pars_decl Σ' ind c = - Some (b, mdecl.(ind_npars), EAst.mkConstructor cdecl.(cstr_name) (context_assumptions cdecl.(cstr_args))). + Some (isPropositional Σ ind, mdecl.(ind_npars), EAst.mkConstructor cdecl.(cstr_name) (context_assumptions cdecl.(cstr_args))). Proof. - intros wfΣ declc decli' em ei b isp. + intros wfΣ declc decli' em ei. pose proof declc as [decli'' _]. eapply isPropositional_propositional in decli''; tea. move: decli''. diff --git a/erasure/theories/ESubstitution.v b/erasure/theories/ESubstitution.v index e4f7b558a..5ff50816b 100644 --- a/erasure/theories/ESubstitution.v +++ b/erasure/theories/ESubstitution.v @@ -5,7 +5,7 @@ From MetaCoq.Utils Require Import utils. From MetaCoq.Common Require Import config. From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICTyping PCUICGlobalEnv PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution - PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICOnFreeVars PCUICElimination. + PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICOnFreeVars PCUICElimination PCUICFirstorder. From MetaCoq.Erasure Require Import EGlobalEnv Extract Prelim. Local Set Keyed Unification. @@ -80,9 +80,11 @@ Proof. all: try now (econstructor; eauto). all: try now (econstructor; eapply Is_type_extends; eauto; tc). - econstructor. - red. red in H4. unfold PCUICAst.lookup_inductive in H4. + move: H4; apply contraNN. + unfold isPropositional. + unfold PCUICAst.lookup_inductive. unshelve eapply declared_constructor_to_gen in isdecl; eauto. - rewrite (PCUICAst.declared_inductive_lookup_gen isdecl.p1) in H4. + rewrite (PCUICAst.declared_inductive_lookup_gen isdecl.p1). destruct isdecl as [decli declc]. eapply declared_inductive_from_gen in decli. eapply PCUICWeakeningEnv.weakening_env_declared_inductive in decli; tea; eauto; tc. diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v index ae4ddaec8..8a3c835ba 100644 --- a/erasure/theories/ErasureCorrectness.v +++ b/erasure/theories/ErasureCorrectness.v @@ -269,7 +269,7 @@ Proof. depelim H2. eapply isErasable_Propositional in X0; eauto. rewrite -eq_npars. - eapply isPropositional_propositional; eauto. + erewrite isPropositional_propositional; eauto. now rewrite X0. apply declared_inductive_from_gen; eauto. invs e. cbn in *. rewrite map_length. @@ -355,7 +355,8 @@ Proof. now rewrite closedn_mkApps /=. } solve_all. eapply (erases_closed _ []); tea. } rewrite -eq_npars. - eapply isPropositional_propositional_cstr; eauto. + erewrite isPropositional_propositional_cstr; eauto. + move/negbTE: H13 => ->. reflexivity. eapply declared_constructor_from_gen; eauto. rewrite -(Forall2_length H3) /= e1 //. rewrite skipn_length -(Forall2_length H3) -e6 /= map_length. @@ -369,9 +370,9 @@ Proof. -- eapply Is_type_app in X1 as []; auto. 2:{ eapply subject_reduction_eval. 2:eassumption. eauto. } assert (ispind : inductive_isprop_and_pars Σ' ind = Some (true, ind_npars mdecl)). - { eapply isPropositional_propositional; eauto. - apply declared_inductive_from_gen; eauto. - eapply isErasable_Propositional; eauto. } + { erewrite isPropositional_propositional; eauto. f_equal. f_equal. + eapply isErasable_Propositional; eauto. + apply declared_inductive_from_gen; eauto. } eapply tConstruct_no_Type in X1; auto. eapply H6 in X1 as []; eauto. @@ -492,9 +493,9 @@ Proof. unshelve eapply declared_projection_to_gen in decli; eauto. destruct (declared_inductive_inj decli.p1 d.p1) as [<- <-]. assert (isprop : inductive_isprop_and_pars Σ' p.(proj_ind) = Some (true, ind_npars mdecl)). - { eapply isPropositional_propositional; eauto. - eapply declared_inductive_from_gen; exact d. all:eauto. apply decli'. - eapply isErasable_Propositional; eauto. } + { erewrite isPropositional_propositional; eauto. f_equal. f_equal. + eapply isErasable_Propositional; eauto. + eapply declared_inductive_from_gen; exact d. all:eauto. apply decli'. } split. eapply Is_type_app in X as []; eauto. 2:{ rewrite -mkApps_app. eapply subject_reduction_eval; eauto. } rewrite -mkApps_app in X. @@ -532,15 +533,16 @@ Proof. invs H2. -- exists x9. split; eauto. constructor. eapply Ee.eval_proj; eauto. rewrite -eqpars. - eapply isPropositional_propositional_cstr; eauto. + erewrite isPropositional_propositional_cstr; eauto. + move/negbTE: H9 => ->. reflexivity. eapply declared_constructor_from_gen. apply d0. cbn. eapply decli'. cbn. rewrite -lenx5 //. move: eargs. unfold PCUICWcbvEval.cstr_arity; cbn. now rewrite -eqpars. -- exists EAst.tBox. assert (isprop : inductive_isprop_and_pars Σ' p.(proj_ind) = Some (true, ind_npars mdecl)). - { eapply isPropositional_propositional; eauto. - eapply declared_inductive_from_gen. apply d. apply decli'. - eapply (isErasable_Propositional (args:=[])); eauto. } + { erewrite isPropositional_propositional; eauto. do 2 f_equal. + eapply (isErasable_Propositional (args:=[])); eauto. + eapply declared_inductive_from_gen. apply d. apply decli'. } split. eapply Is_type_app in X as []; eauto. 2:{ eapply subject_reduction_eval; [|eauto]; eauto. } diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 528be6234..75ca06fa8 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -1775,273 +1775,8 @@ Proof. destruct KernameSet.mem; cbn. f_equal. f_equal. 1-2:f_equal. all:now eapply IHdecls. Qed. -Definition global_erased_with_deps (Σ : global_env) (Σ' : EAst.global_declarations) kn := - (exists cst, declared_constant Σ kn cst /\ - exists cst' : EAst.constant_body, - EGlobalEnv.declared_constant Σ' kn cst' /\ - erases_constant_body (Σ, cst_universes cst) cst cst' /\ - (forall body : EAst.term, - EAst.cst_body cst' = Some body -> erases_deps Σ Σ' body)) \/ - (exists mib mib', declared_minductive Σ kn mib /\ - EGlobalEnv.declared_minductive Σ' kn mib' /\ - erases_mutual_inductive_body mib mib'). - -Definition includes_deps (Σ : global_env) (Σ' : EAst.global_declarations) deps := - forall kn, - KernameSet.In kn deps -> - global_erased_with_deps Σ Σ' kn. - -Lemma includes_deps_union (Σ : global_env) (Σ' : EAst.global_declarations) deps deps' : - includes_deps Σ Σ' (KernameSet.union deps deps') -> - includes_deps Σ Σ' deps /\ includes_deps Σ Σ' deps'. -Proof. - intros. - split; intros kn knin; eapply H; rewrite KernameSet.union_spec; eauto. -Qed. - -Lemma includes_deps_fold {A} (Σ : global_env) (Σ' : EAst.global_declarations) brs deps (f : A -> EAst.term) : - includes_deps Σ Σ' - (fold_left - (fun (acc : KernameSet.t) (x : A) => - KernameSet.union (term_global_deps (f x)) acc) brs - deps) -> - includes_deps Σ Σ' deps /\ - (forall x, In x brs -> - includes_deps Σ Σ' (term_global_deps (f x))). -Proof. - intros incl; split. - intros kn knin; apply incl. - rewrite knset_in_fold_left. left; auto. - intros br brin. intros kn knin. apply incl. - rewrite knset_in_fold_left. right. - now exists br. -Qed. - -Definition declared_kn Σ kn := - ∥ ∑ decl, lookup_env Σ kn = Some decl ∥. - -Lemma term_global_deps_spec {cf} {Σ : global_env_ext} {Γ t et T} : - wf Σ.1 -> - Σ ;;; Γ |- t : T -> - Σ;;; Γ |- t ⇝ℇ et -> - forall x, KernameSet.In x (term_global_deps et) -> declared_kn Σ x. -Proof. - intros wf wt er. - induction er in T, wt |- * using erases_forall_list_ind; - cbn in *; try solve [constructor]; intros kn' hin; - repeat match goal with - | [ H : KernameSet.In _ KernameSet.empty |- _ ] => - now apply KernameSet.empty_spec in hin - | [ H : KernameSet.In _ (KernameSet.union _ _) |- _ ] => - apply KernameSet.union_spec in hin as [?|?] - end. - - apply inversion_Lambda in wt as (? & ? & ? & ? & ?); eauto. - - apply inversion_LetIn in wt as (? & ? & ? & ? & ? & ?); eauto. - - apply inversion_LetIn in wt as (? & ? & ? & ? & ? & ?); eauto. - - apply inversion_App in wt as (? & ? & ? & ? & ? & ?); eauto. - - apply inversion_App in wt as (? & ? & ? & ? & ? & ?); eauto. - - apply inversion_Const in wt as (? & ? & ? & ? & ?); eauto. - eapply KernameSet.singleton_spec in hin; subst. - unshelve eapply declared_constant_to_gen in d; eauto. - red in d. red. sq. rewrite d. intuition eauto. - - apply inversion_Construct in wt as (? & ? & ? & ? & ? & ? & ?); eauto. - destruct kn. - eapply KernameSet.singleton_spec in hin; subst. - destruct d as [[H' _] _]. - unshelve eapply declared_minductive_to_gen in H'; eauto. - red in H'. simpl in *. - red. sq. rewrite H'. intuition eauto. - - apply inversion_Case in wt as (? & ? & ? & ? & [] & ?); eauto. - destruct ci as [kn i']; simpl in *. - eapply KernameSet.singleton_spec in H1; subst. - destruct x1 as [d _]. - unshelve eapply declared_minductive_to_gen in d; eauto. - red in d. - simpl in *. eexists; intuition eauto. - - apply inversion_Case in wt as (? & ? & ? & ? & [] & ?); eauto. - eapply knset_in_fold_left in H1. - destruct H1. eapply IHer; eauto. - destruct H1 as [br [inbr inkn]]. - eapply Forall2_All2 in H0. - assert (All (fun br => ∑ T, Σ ;;; Γ ,,, inst_case_branch_context p br |- br.(bbody) : T) brs). - eapply All2i_All_right. eapply brs_ty. - simpl. intuition auto. eexists ; eauto. - now rewrite -(PCUICCasesContexts.inst_case_branch_context_eq a). - eapply All2_All_mix_left in H0; eauto. simpl in H0. - eapply All2_In_right in H0; eauto. - destruct H0. - destruct X1 as [br' [[T' HT] ?]]. - eauto. - - - eapply KernameSet.singleton_spec in H0; subst. - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?&?); eauto. - unshelve eapply declared_projection_to_gen in d; eauto. - destruct d as [[[d _] _] _]. - red in d. eexists; eauto. - - - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?); eauto. - - - apply inversion_Fix in wt as (?&?&?&?&?&?&?); eauto. - eapply knset_in_fold_left in hin as [|]. - now eapply KernameSet.empty_spec in H0. - destruct H0 as [? [ina indeps]]. - eapply Forall2_All2 in H. - eapply All2_All_mix_left in H; eauto. - eapply All2_In_right in H; eauto. - destruct H as [[def [Hty Hdef]]]. - eapply Hdef; eauto. - - - apply inversion_CoFix in wt as (?&?&?&?&?&?&?); eauto. - eapply knset_in_fold_left in hin as [|]. - now eapply KernameSet.empty_spec in H0. - destruct H0 as [? [ina indeps]]. - eapply Forall2_All2 in H. - eapply All2_All_mix_left in H; eauto. - eapply All2_In_right in H; eauto. - destruct H as [[def [Hty Hdef]]]. - eapply Hdef; eauto. -Qed. - -Global Remove Hints erases_deps_eval : core. - -Lemma erase_global_erases_deps {Σ} {Σ' : EAst.global_declarations} {Γ t et T} : - wf_ext Σ -> - Σ;;; Γ |- t : T -> - Σ;;; Γ |- t ⇝ℇ et -> - includes_deps Σ Σ' (term_global_deps et) -> - erases_deps Σ Σ' et. -Proof. - intros wf wt er. - induction er in er, t, T, wf, wt |- * using erases_forall_list_ind; - cbn in *; try solve [constructor]; intros Σer; - repeat match goal with - | [ H : includes_deps _ _ (KernameSet.union _ _ ) |- _ ] => - apply includes_deps_union in H as [? ?] - end. - - now apply inversion_Evar in wt. - - constructor. - now apply inversion_Lambda in wt as (? & ? & ? & ? & ?); eauto. - - apply inversion_LetIn in wt as (? & ? & ? & ? & ? & ?); eauto. - constructor; eauto. - - apply inversion_App in wt as (? & ? & ? & ? & ? & ?); eauto. - now constructor; eauto. - - apply inversion_Const in wt as (? & ? & ? & ? & ?); eauto. - specialize (Σer kn). - forward Σer. rewrite KernameSet.singleton_spec //. - pose proof (wf' := wf.1). - unshelve eapply declared_constant_to_gen in d; eauto. - destruct Σer as [[c' [declc' (? & ? & ? & ?)]]|]. - unshelve eapply declared_constant_to_gen in declc'; eauto. - pose proof (declared_constant_inj _ _ d declc'). subst x. - econstructor; eauto. eapply declared_constant_from_gen; eauto. - destruct H as [mib [mib' [declm declm']]]. - unshelve eapply declared_minductive_to_gen in declm; eauto. - red in declm, d. unfold declared_minductive_gen in declm. - rewrite d in declm. noconf declm. - - apply inversion_Construct in wt as (? & ? & ? & ? & ? & ?); eauto. - red in Σer. destruct kn. - setoid_rewrite KernameSetFact.singleton_iff in Σer. - pose (wf' := wf.1). - destruct (Σer _ eq_refl) as [ (? & ? & ? & ? & ? & ?) | (? & ? & ? & ? & ?) ]. - + destruct d as [[]]. - unshelve eapply declared_constant_to_gen in H0; eauto. - unshelve eapply declared_minductive_to_gen in H4; eauto. - red in H4, H. cbn in *. unfold PCUICEnvironment.fst_ctx in *. congruence. - + pose proof H2 as H2'. destruct d. cbn in *. - destruct H3. cbn in *. red in H3. - unshelve eapply declared_minductive_to_gen in H0, H3; eauto. - red in H0, H3. rewrite H0 in H3. invs H3. - destruct H2. - red in H1. - eapply Forall2_nth_error_Some_l in H2 as (? & ? & ?); eauto. pose proof H6 as H6'. destruct H6 as (? & ? & ? & ? & ?); eauto. - eapply Forall2_nth_error_Some_l in H6 as ([] & ? & ? & ?); subst; eauto. - econstructor. - eapply declared_constructor_from_gen; eauto. repeat eapply conj; eauto. - repeat eapply conj; cbn; eauto. eauto. eauto. - - apply inversion_Case in wt as (? & ? & ? & ? & [] & ?); eauto. - destruct ci as [[kn i'] ? ?]; simpl in *. - apply includes_deps_fold in H2 as [? ?]. - pose proof (wf' := wf.1). - specialize (H1 kn). forward H1. - now rewrite KernameSet.singleton_spec. red in H1. destruct H1. - elimtype False. destruct H1 as [cst [declc _]]. - { destruct x1 as [d _]. - unshelve eapply declared_minductive_to_gen in d; eauto. - unshelve eapply declared_constant_to_gen in declc; eauto. - red in d, declc. - unfold declared_constant_gen in declc. rewrite d in declc. noconf declc. } - destruct H1 as [mib [mib' [declm [declm' em]]]]. - pose proof em as em'. destruct em'. - destruct x1 as [x1 hnth]. - unshelve eapply declared_minductive_to_gen in x1, declm; eauto. - red in x1, declm. unfold declared_minductive_gen in declm. rewrite x1 in declm. noconf declm. - eapply Forall2_nth_error_left in H1; eauto. destruct H1 as [? [? ?]]. - eapply erases_deps_tCase; eauto. - apply declared_inductive_from_gen; auto. - split; eauto. split; eauto. - destruct H1. - eapply In_Forall in H3. - eapply All_Forall. eapply Forall_All in H3. - eapply Forall2_All2 in H0. - eapply All2_All_mix_right in H0; eauto. - assert (All (fun br => ∑ T, Σ ;;; Γ ,,, inst_case_branch_context p br |- br.(bbody) : T) brs). - eapply All2i_All_right. eapply brs_ty. - simpl. intuition auto. eexists ; eauto. - now rewrite -(PCUICCasesContexts.inst_case_branch_context_eq a). - ELiftSubst.solve_all. destruct a0 as [T' HT]. eauto. - - - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?&?); eauto. - destruct (proj1 d). - pose proof (wf' := wf.1). - specialize (H0 (inductive_mind p.(proj_ind))). forward H0. - now rewrite KernameSet.singleton_spec. red in H0. destruct H0. - elimtype False. destruct H0 as [cst [declc _]]. - { - unshelve eapply declared_constant_to_gen in declc; eauto. - red in declc. destruct d as [[[d _] _] _]. - unshelve eapply declared_minductive_to_gen in d; eauto. - red in d. - unfold declared_constant_gen in declc. rewrite d in declc. noconf declc. } - destruct H0 as [mib [mib' [declm [declm' em]]]]. - assert (mib = x0). - { destruct d as [[[]]]. - unshelve eapply declared_minductive_to_gen in declm, H0; eauto. - red in H0, declm. unfold declared_minductive_gen in declm. rewrite H0 in declm. now noconf declm. } - subst x0. - pose proof em as em'. destruct em'. - eapply Forall2_nth_error_left in H0 as (x' & ? & ?); eauto. - 2:{ apply d. } - simpl in *. - destruct (ind_ctors x1) => //. noconf H3. - set (H1' := H5). destruct H1' as []. - set (d' := d). destruct d' as [[[]]]. - eapply Forall2_All2 in H3. eapply All2_nth_error_Some in H3 as [? [? []]]; tea. - destruct H6 as [Hprojs _]. - eapply Forall2_All2 in Hprojs. eapply All2_nth_error_Some in Hprojs as [? []]; tea. - 2:eapply d. - econstructor; tea. all:eauto. - split => //. 2:split; eauto. - split; eauto. split; eauto. - rewrite -H4. symmetry; apply d. - - - constructor. - apply inversion_Fix in wt as (?&?&?&?&?&?&?); eauto. - eapply All_Forall. eapply includes_deps_fold in Σer as [_ Σer]. - eapply In_Forall in Σer. - eapply Forall_All in Σer. - eapply Forall2_All2 in H. - ELiftSubst.solve_all. - - constructor. - apply inversion_CoFix in wt as (?&?&?&?&?&?&?); eauto. - eapply All_Forall. eapply includes_deps_fold in Σer as [_ Σer]. - eapply In_Forall in Σer. - eapply Forall_All in Σer. - eapply Forall2_All2 in H. - ELiftSubst.solve_all. Unshelve. -Qed. - (* TODO: Figure out if this (and [erases]) should use [strictly_extends_decls] or [extends] -Jason Gross *) -Lemma erases_weakeninv_env {Σ Σ' : global_env_ext} {Γ t t' T} : +Lemma erases_weakening_env {Σ Σ' : global_env_ext} {Γ t t' T} : wf Σ -> wf Σ' -> strictly_extends_decls Σ Σ' -> Σ ;;; Γ |- t : T -> erases Σ Γ t t' -> erases (Σ'.1, Σ.2) Γ t t'. @@ -2050,181 +1785,6 @@ Proof. eapply (env_prop_typing ESubstitution.erases_extends); tea. Qed. -Lemma erases_deps_weaken kn d (Σ : global_env) (Σ' : EAst.global_declarations) t : - wf (add_global_decl Σ (kn, d)) -> - erases_deps Σ Σ' t -> - erases_deps (add_global_decl Σ (kn, d)) Σ' t. -Proof. - intros wfΣ er. - assert (wfΣ' : wf Σ) - by now eapply strictly_extends_decls_wf; tea; split => //; eexists [_]. - induction er using erases_deps_forall_ind; try solve [now constructor]. - - inv wfΣ. inv X. - assert (wf Σ) by (inversion H4;econstructor; eauto). - pose proof (H_ := H). unshelve eapply declared_constant_to_gen in H; eauto. - assert (kn <> kn0). - { intros <-. - eapply lookup_env_Some_fresh in H. destruct X1. contradiction. } - eapply erases_deps_tConst with cb cb'; eauto. - eapply declared_constant_from_gen. - red. rewrite /declared_constant_gen /lookup_env lookup_env_cons_fresh //. - red. - red in H1. - destruct (cst_body cb) eqn:cbe; - destruct (E.cst_body cb') eqn:cbe'; auto. - specialize (H3 _ eq_refl). - eapply on_declared_constant in H_; auto. - red in H_. rewrite cbe in H_. simpl in H_. - eapply (erases_weakeninv_env (Σ := (Σ, cst_universes cb)) - (Σ' := (add_global_decl Σ (kn, d), cst_universes cb))); eauto. - simpl. econstructor; eauto. econstructor; eauto. - split => //; eexists [(kn, d)]; intuition eauto. - - econstructor; eauto. eapply weakening_env_declared_constructor; eauto; tc. - eapply extends_decls_extends, strictly_extends_decls_extends_decls. econstructor; try reflexivity. eexists [(_, _)]; reflexivity. - - econstructor; eauto. - eapply declared_inductive_from_gen. - inv wfΣ. inv X. - assert (wf Σ) by (inversion H5;econstructor; eauto). - unshelve eapply declared_inductive_to_gen in H; eauto. - red. destruct H. split; eauto. - red in H. red. - rewrite -H. simpl. unfold lookup_env; simpl. destruct (eqb_spec (inductive_mind p.1) kn); try congruence. - eapply lookup_env_Some_fresh in H. destruct X1. subst kn; contradiction. - - econstructor; eauto. - inv wfΣ. inv X. - assert (wf Σ) by (inversion H3;econstructor; eauto). - eapply declared_projection_from_gen. - unshelve eapply declared_projection_to_gen in H; eauto. - red. destruct H. split; eauto. - destruct H; split; eauto. - destruct H; split; eauto. - red in H |- *. - rewrite -H. simpl. unfold lookup_env; simpl; destruct (eqb_spec (inductive_mind p.(proj_ind)) kn); try congruence. - eapply lookup_env_Some_fresh in H. subst kn. destruct X1. contradiction. -Qed. - -Lemma lookup_env_ext {Σ kn kn' d d'} : - wf (add_global_decl Σ (kn', d')) -> - lookup_env Σ kn = Some d -> - kn <> kn'. -Proof. - intros wf hl. - eapply lookup_env_Some_fresh in hl. - inv wf. inv X. - destruct (eqb_spec kn kn'); subst; destruct X1; congruence. -Qed. - -Lemma lookup_env_cons_disc {Σ kn kn' d} : - kn <> kn' -> - lookup_env (add_global_decl Σ (kn', d)) kn = lookup_env Σ kn. -Proof. - intros Hk. simpl; unfold lookup_env; simpl. - destruct (eqb_spec kn kn'); congruence. -Qed. - -Lemma elookup_env_cons_disc {Σ kn kn' d} : - kn <> kn' -> - EGlobalEnv.lookup_env ((kn', d) :: Σ) kn = EGlobalEnv.lookup_env Σ kn. -Proof. - intros Hk. simpl. - destruct (eqb_spec kn kn'); congruence. -Qed. - -Lemma global_erases_with_deps_cons kn kn' d d' Σ Σ' : - wf (add_global_decl Σ (kn', d)) -> - global_erased_with_deps Σ Σ' kn -> - global_erased_with_deps (add_global_decl Σ (kn', d)) ((kn', d') :: Σ') kn. -Proof. - intros wf [[cst [declc [cst' [declc' [ebody IH]]]]]|]. - red. inv wf. inv X. - assert (wfΣ : PCUICTyping.wf Σ). - { eapply strictly_extends_decls_wf; split; tea ; eauto. econstructor; eauto. - now eexists [_]. - } - left. - exists cst. split. - eapply declared_constant_from_gen. - unshelve eapply declared_constant_to_gen in declc; eauto. - red in declc |- *. unfold declared_constant_gen, lookup_env in *. - rewrite lookup_env_cons_fresh //. - { eapply lookup_env_Some_fresh in declc. destruct X1. - intros <-; contradiction. } - exists cst'. - pose proof (declc_ := declc). - unshelve eapply declared_constant_to_gen in declc; eauto. - unfold EGlobalEnv.declared_constant. rewrite EGlobalEnv.elookup_env_cons_fresh //. - { eapply lookup_env_Some_fresh in declc. destruct X1. - intros <-; contradiction. } - red in ebody. unfold erases_constant_body. - destruct (cst_body cst) eqn:bod; destruct (E.cst_body cst') eqn:bod' => //. - intuition auto. - eapply (erases_weakeninv_env (Σ := (_, cst_universes cst)) (Σ' := (add_global_decl Σ (kn', d), cst_universes cst))); eauto. - constructor; eauto. constructor; eauto. - split => //. exists [(kn', d)]; intuition eauto. - eapply on_declared_constant in declc_; auto. - red in declc_. rewrite bod in declc_. eapply declc_. - noconf H0. - eapply erases_deps_cons; eauto. - constructor; auto. - - right. - pose proof (wf_ := wf). inv wf. inv X. - assert (wf Σ) by (inversion H0;econstructor; eauto). - destruct H as [mib [mib' [? [? ?]]]]. - unshelve eapply declared_minductive_to_gen in H; eauto. - exists mib, mib'. intuition eauto. - * eapply declared_minductive_from_gen. - red. red in H. pose proof (lookup_env_ext wf_ H). unfold declared_minductive_gen. - now rewrite lookup_env_cons_disc. - * red. pose proof (lookup_env_ext wf_ H). - now rewrite elookup_env_cons_disc. -Qed. - -Lemma global_erases_with_deps_weaken kn kn' d Σ Σ' : - wf (add_global_decl Σ (kn', d)) -> - global_erased_with_deps Σ Σ' kn -> - global_erased_with_deps (add_global_decl Σ (kn', d)) Σ' kn. -Proof. - intros wf [[cst [declc [cst' [declc' [ebody IH]]]]]|]. - red. inv wf. inv X. left. - assert (wfΣ : PCUICTyping.wf Σ). - { eapply strictly_extends_decls_wf; split; tea ; eauto. econstructor; eauto. - now eexists [_]. - } - exists cst. split. - eapply declared_constant_from_gen. - unshelve eapply declared_constant_to_gen in declc; eauto. - red in declc |- *. - unfold declared_constant_gen, lookup_env in *. - rewrite lookup_env_cons_fresh //. - { eapply lookup_env_Some_fresh in declc. - intros <-. destruct X1. contradiction. } - exists cst'. - unfold EGlobalEnv.declared_constant. - red in ebody. unfold erases_constant_body. - destruct (cst_body cst) eqn:bod; destruct (E.cst_body cst') eqn:bod' => //. - intuition auto. - eapply (erases_weakeninv_env (Σ := (Σ, cst_universes cst)) (Σ' := (add_global_decl Σ (kn', d), cst_universes cst))). 5:eauto. - split; auto. constructor; eauto. constructor; eauto. - split; auto; exists [(kn', d)]; intuition eauto. - eapply on_declared_constant in declc; auto. - red in declc. rewrite bod in declc. eapply declc. - noconf H0. - apply erases_deps_weaken; auto. - constructor; eauto. constructor; eauto. - - right. destruct H as [mib [mib' [Hm [? ?]]]]. - exists mib, mib'; intuition auto. pose proof (wf_ := wf). - inv wf. inv X. - assert (wf Σ) by (inversion H;econstructor; eauto). - eapply declared_minductive_from_gen. - - unshelve eapply declared_minductive_to_gen in Hm; eauto. - red. unfold declared_minductive_gen, lookup_env in *. - rewrite lookup_env_cons_fresh //. - now epose proof (lookup_env_ext wf_ Hm). -Qed. - (* TODO: Figure out if this (and [erases]) should use [strictly_extends_decls] or [extends] -Jason Gross *) Lemma erase_constant_body_correct X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} cb (onc : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ on_constant_decl (lift_typing typing) Σ cb ∥) : @@ -2235,7 +1795,7 @@ Proof. red. destruct cb as [name [bod|] univs]; simpl; eauto. intros. set (ecbo := erase_constant_body_obligation_1 X_type X _ _ _ _). clearbody ecbo. cbn in *. specialize_Σ H. sq. - eapply (erases_weakeninv_env (Σ := Σ) (Σ' := (Σ', univs))); simpl; eauto. + eapply (erases_weakening_env (Σ := Σ) (Σ' := (Σ', univs))); simpl; eauto. now eapply erases_erase. Qed. @@ -2277,2322 +1837,4 @@ Proof. cbn in *. intuition auto. induction ind_projs0; constructor; auto. - unfold isPropositionalArity. - destruct destArity as [[? ?]|] eqn:da; auto. -Qed. - -Lemma erase_global_includes X_type (X:X_type.π1) deps decls {normalization_in} prf deps' : - (forall d, KernameSet.In d deps' -> - forall Σ : global_env, abstract_env_rel X Σ -> ∥ ∑ decl, lookup_env Σ d = Some decl ∥) -> - KernameSet.subset deps' deps -> - forall Σ : global_env, abstract_env_rel X Σ -> - let Σ' := erase_global_deps deps X decls (normalization_in:=normalization_in) prf in - includes_deps Σ (fst Σ') deps'. -Proof. - intros ? sub Σ wfΣ; cbn. induction decls in X, H, sub, prf, deps, deps', Σ , wfΣ, normalization_in |- *. - - simpl. intros i hin. elimtype False. - specialize (H i hin) as [[decl Hdecl]]; eauto. - rewrite /lookup_env (prf _ wfΣ) in Hdecl. noconf Hdecl. - - intros i hin. - destruct (abstract_env_wf _ wfΣ) as [wf]. - destruct a as [kn d]. - eapply KernameSet.subset_spec in sub. - edestruct (H i hin) as [[decl Hdecl]]; eauto. unfold lookup_env in Hdecl. - pose proof (eqb_spec i kn). - rewrite (prf _ wfΣ) in Hdecl. move: Hdecl. cbn -[erase_global_deps]. - elim: H0. intros -> [= <-]. - * destruct d as [|]; [left|right]. - { cbn. set (Xpop := abstract_pop_decls X). - unfold erase_constant_decl. - set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). - epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]. - epose proof (abstract_env_ext_exists Xmake) as [[Σmake wfmake]]. - exists c. split; auto. - eapply declared_constant_from_gen. - unfold declared_constant_gen, lookup_env; simpl; rewrite (prf _ wfΣ). cbn. - rewrite eq_kername_refl //. - pose proof (sub _ hin) as indeps. - eapply KernameSet.mem_spec in indeps. - unfold EGlobalEnv.declared_constant. - edestruct (H _ hin) as [[decl hd]]; eauto. - eexists; intuition eauto. - rewrite indeps. cbn. - rewrite eq_kername_refl. reflexivity. - cut (strictly_extends_decls Σpop Σ) => [?|]. - eapply (erase_constant_body_correct _ _ _ _ (Σpop , _)); eauto. - rewrite <- (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake); eauto. - { now eapply strictly_extends_decls_wf. } - red. simpl. unshelve epose (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop). - { intros. now eexists. } - split => //. intuition eauto. - exists [(kn, ConstantDecl c)]; intuition eauto. rewrite H0; eauto. - now destruct a. - rewrite indeps. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. - { intros. now eexists. } - pose (prf' := prf _ wfΣ). - destruct Σ. cbn in *. rewrite Hpop' Hpop'' prf'. rewrite <- Hpop at 1. - eapply (erases_deps_cons Σpop). - rewrite <- Hpop'. apply wf. - rewrite Hpop. rewrite prf' in wf. destruct wf. now rewrite Hpop'' Hpop' in o0. - - pose proof (erase_constant_body_correct' H0). specialize_Σ wfmake. - sq. destruct H1 as [bod [bodty [[Hbod Hebod] Heqdeps]]]. - rewrite (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake) in Hbod, Hebod. - eapply (erase_global_erases_deps (Σ := (Σpop, cst_universes c))); simpl; auto. - { constructor; simpl; auto. depelim wf. rewrite Hpop' Hpop'' in o0. - cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. rewrite Hpop' in o. clear -o o0. - now depelim o0. - depelim wf. rewrite Hpop' in o0. - cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. clear -o0. depelim o0. - now destruct o. - } - all: eauto. - apply IHdecls; eauto. - { intros. pose proof (abstract_env_wf _ wfpop) as [wf']. - destruct Σpop. cbn in *. clear prf'. subst. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ H2) as [Hpop Hpop']. - { intros. now eexists. } - destruct Σ. cbn in *. subst. - eapply term_global_deps_spec in Hebod; eauto. } - { eapply KernameSet.subset_spec. - intros x hin'. eapply KernameSet.union_spec. right; auto. - now rewrite -Heqdeps. } } - { eexists m, _; intuition eauto. - eapply declared_minductive_from_gen. - simpl. rewrite /declared_minductive /declared_minductive_gen /lookup_env prf; eauto. - simpl. rewrite eq_kername_refl. reflexivity. - specialize (sub _ hin). - eapply KernameSet.mem_spec in sub. - simpl. rewrite sub. - red. cbn. rewrite eq_kername_refl. - reflexivity. - assert (declared_minductive Σ kn m). - { eapply declared_minductive_from_gen. red. unfold declared_minductive_gen, lookup_env. rewrite prf; eauto. cbn. now rewrite eqb_refl. } - eapply on_declared_minductive in H0; tea. - now eapply erases_mutual. } - - * intros ikn Hi. - destruct d as [|]. - ++ simpl. destruct (KernameSet.mem kn deps) eqn:eqkn. - unfold erase_constant_decl. - set (Xpop := abstract_pop_decls X). - set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - pose proof (abstract_env_wf _ wfpop) as [wfΣp]. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. - { intros. now eexists. } - pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. - eapply global_erases_with_deps_cons; eauto. - eapply (IHdecls Xpop _ _ _ (KernameSet.singleton i)); auto. - 3:{ eapply KernameSet.singleton_spec => //. } - intros. - eapply KernameSet.singleton_spec in H0. - pose proof (abstract_env_irr _ H1 wfpop). subst. - sq; exists decl; eauto. - eapply KernameSet.subset_spec. intros ? ?. - eapply KernameSet.union_spec. left. - eapply KernameSet.singleton_spec in H0; subst. - now eapply sub. - - cbn. set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - pose proof (abstract_env_wf _ wfpop) as [wfΣp]. - unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. - { intros. now eexists. } - pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. - eapply global_erases_with_deps_weaken. eauto. - eapply IHdecls => //. - 3:now eapply KernameSet.singleton_spec. - intros d ind%KernameSet.singleton_spec. - intros. pose proof (abstract_env_irr _ H0 wfpop). subst. - sq; eexists; eauto. - eapply KernameSet.subset_spec. - intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. - - ++ simpl. set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - pose proof (abstract_env_wf _ wfpop) as [wfΣp]. - unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. - { intros. now eexists. } - pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. - destruct (KernameSet.mem kn deps) eqn:eqkn. - { eapply (global_erases_with_deps_cons _ kn (InductiveDecl _) _ Σp); eauto. - eapply (IHdecls Xpop _ _ _ (KernameSet.singleton i)); auto. - 3:{ eapply KernameSet.singleton_spec => //. } - intros. - eapply KernameSet.singleton_spec in H0. subst. - pose proof (abstract_env_irr _ H1 wfpop). subst. - sq; eexists; eauto. - eapply KernameSet.subset_spec. intros ? ?. - eapply KernameSet.singleton_spec in H0; subst. - now eapply sub. } - - { eapply (global_erases_with_deps_weaken _ kn (InductiveDecl _) Σp). eauto. - eapply (IHdecls Xpop _ _ _ (KernameSet.singleton i)) => //. - 3:now eapply KernameSet.singleton_spec. - intros d ind%KernameSet.singleton_spec. - intros. pose proof (abstract_env_irr _ H0 wfpop). subst. - sq; eexists; eauto. - eapply KernameSet.subset_spec. - intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. } -Qed. - -Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) - univs wfext t v Σ' t' deps decls {normalization_in} prf - (Xext := abstract_make_wf_env_ext X univs wfext) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} - : - forall wt : forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t, - erase X_type Xext [] t wt = t' -> - KernameSet.subset (term_global_deps t') deps -> - erase_global_deps deps X decls (normalization_in:=normalization_in) prf = Σ' -> - (forall Σ : global_env, abstract_env_rel X Σ -> Σ |-p t ⇓ v) -> - forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> - exists v', Σ ;;; [] |- v ⇝ℇ v' /\ ∥ fst Σ' ⊢ t' ⇓ v' ∥. -Proof. - intros wt. - intros HΣ' Hsub Ht' ev Σext wfΣex. - pose proof (erases_erase (X := Xext) wt). - rewrite HΣ' in H. - destruct (wt _ wfΣex) as [T wt']. - pose proof (abstract_env_ext_wf _ wfΣex) as [wfΣ]. - specialize (H _ wfΣex). - unshelve epose proof (erase_global_erases_deps (Σ' := fst Σ') wfΣ wt' H _); cycle 2. - rewrite <- Ht'. - eapply erase_global_includes; eauto. - intros. eapply term_global_deps_spec in H; eauto. - now rewrite (abstract_make_wf_env_ext_correct X univs wfext Σ _ H1 wfΣex) in H. - - epose proof (abstract_env_exists X) as [[Σ wfΣX]]. - now rewrite (abstract_make_wf_env_ext_correct X univs wfext Σ _ wfΣX wfΣex). - epose proof (abstract_env_exists X) as [[Σ wfΣX]]. - eapply erases_correct; tea. - - eexists; eauto. - - rewrite (abstract_make_wf_env_ext_correct X univs wfext _ _ wfΣX wfΣex); eauto. -Qed. - -Lemma global_env_ind (P : global_env -> Type) - (Pnil : forall univs retro, P {| universes := univs; declarations := []; retroknowledge := retro |}) - (Pcons : forall (Σ : global_env) d, P Σ -> P (add_global_decl Σ d)) - (Σ : global_env) : P Σ. -Proof. - destruct Σ as [univs Σ]. - induction Σ; cbn. apply Pnil. - now apply (Pcons {| universes := univs; declarations := Σ |} a). -Qed. - -Lemma on_global_env_ind (P : forall Σ : global_env, wf Σ -> Type) - (Pnil : forall univs retro (onu : on_global_univs univs), P {| universes := univs; declarations := []; retroknowledge := retro |} - (onu, globenv_nil _ _ _ _)) - (Pcons : forall (Σ : global_env) kn d (wf : wf Σ) - (Hfresh : fresh_global kn Σ.(declarations)) - (udecl := PCUICLookup.universes_decl_of_decl d) - (onud : on_udecl Σ.(universes) udecl) - (pd : on_global_decl cumulSpec0 (lift_typing typing) - ({| universes := Σ.(universes); declarations := Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}, udecl) kn d), - P Σ wf -> P (add_global_decl Σ (kn, d)) - (fst wf, globenv_decl _ _ Σ.(universes) Σ.(retroknowledge) Σ.(declarations) kn d (snd wf) - {| kn_fresh := Hfresh ; on_udecl_udecl := onud ; on_global_decl_d := pd |})) - (Σ : global_env) (wfΣ : wf Σ) : P Σ wfΣ. -Proof. - destruct Σ as [univs Σ]. destruct wfΣ; cbn in *. - induction o0. apply Pnil. destruct o1. - apply (Pcons {| universes := univs; declarations := Σ |} kn d (o, o0)). - exact IHo0. -Qed. - -Ltac inv_eta := - lazymatch goal with - | [ H : PCUICEtaExpand.expanded _ _ |- _ ] => depelim H - end. - -Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : - wf_ext Σ -> - PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> - Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> - leq_universe (global_ext_constraints Σ) u' u. -Proof. - intros wfΣ leq hv hv' isp. - eapply orb_true_iff in isp as [isp | isp]. - - eapply leq_term_prop_sorted_l; eauto. - - eapply leq_term_sprop_sorted_l; eauto. -Qed. - -Fixpoint map_erase (X_type:abstract_env_impl) (X : X_type.π2.π1) {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ - (ts : list term) - (H2 : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> - Forall (welltyped Σ Γ) ts) {struct ts}: list E.term. -destruct ts as [ | t ts]. -- exact []. -- eapply cons. refine (erase X_type X Γ t _). - 2: eapply (map_erase X_type X _ Γ ts). - all: intros; specialize_Σ H; now inversion H2; subst. -Defined. - -Lemma map_erase_irrel X_type X {normalization_in1 normalization_in2 : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t H1 H2 : - map_erase X_type X Γ t H1 (normalization_in:=normalization_in1) = map_erase X_type X Γ t H2 (normalization_in:=normalization_in2). -Proof. - epose proof (abstract_env_ext_exists X) as [[Σ wfΣX]]. - induction t. - - reflexivity. - - cbn. f_equal. - + eapply erase_irrel. - + eapply IHt. -Qed. - -Arguments map_erase _ _ _ _ _, _ _ {_} _ _ _, _ _ {_} _ _ {_}. - -Lemma erase_mkApps {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t args H2 Ht Hargs : - (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> wf_local Σ Γ) -> - (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ~ ∥ isErasable Σ Γ (mkApps t args) ∥) -> - erase X_type X Γ (mkApps t args) H2 = - E.mkApps (erase X_type X Γ t Ht) (map_erase X_type X Γ args Hargs). -Proof. - epose proof (abstract_env_ext_exists X) as [[Σ wfΣX]]. - pose proof (abstract_env_ext_wf X wfΣX) as [wf]. - intros Hwflocal Herasable. induction args in t, H2, Ht, Hargs, Herasable |- *. - - cbn. eapply erase_irrel. - - cbn [mkApps]. - rewrite IHargs; clear IHargs. - all: intros; specialize_Σ H; try pose proof (abstract_env_ext_wf _ H) as [wfH]. - 1: inversion Hargs; eauto. - 2: eauto. - 2:{ destruct H2. cbn in X0. eapply inversion_mkApps in X0 as (? & ? & ?). - econstructor. eauto. } - etransitivity. simp erase. reflexivity. unfold erase_clause_1. - unfold inspect. unfold erase_clause_1_clause_2. - Unshelve. - elim: is_erasableP. - + intros. exfalso. - eapply Herasable; eauto. specialize_Σ wfΣX. destruct p. - cbn. destruct H2. eapply Is_type_app; eauto. - + cbn [map_erase]. - epose proof (fst (erase_irrel _ _)). cbn. - intros he. f_equal => //. f_equal. - eapply erase_irrel. eapply erase_irrel. - eapply map_erase_irrel. -Qed. - -Lemma map_erase_length X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t H1 : length (map_erase X_type X Γ t H1) = length t. -Proof. - induction t; cbn; f_equal; eauto. -Qed. - -Local Hint Constructors expanded : expanded. - -Local Arguments erase_global_deps _ _ _ _ _ : clear implicits. - -(*Lemma lookup_env_erase X_type X deps decls normalization_in prf kn d : - KernameSet.In kn deps -> - forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some (InductiveDecl d) -> - EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf) kn = Some (EAst.InductiveDecl (erase_mutual_inductive_body d)). -Proof. - intros hin Σ wfΣ. pose proof (prf _ wfΣ). unfold lookup_env. rewrite H. clear H. - rewrite /lookup_env. - induction decls in X, Σ , wfΣ ,prf, deps, hin, normalization_in |- *. - - move=> /= //. - - destruct a as [kn' d']. - cbn -[erase_global_deps]. - case: (eqb_spec kn kn'); intros e'; subst. - intros [= ->]. - unfold erase_global_deps. - eapply KernameSet.mem_spec in hin. rewrite hin /=. - now rewrite eq_kername_refl. - intros hl. destruct d'. simpl. - set (Xpop := abstract_pop_decls X). - set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - destruct KernameSet.mem. cbn. - rewrite (negbTE (proj2 (neqb _ _) e')). - eapply IHdecls => //; eauto. eapply KernameSet.union_spec. left => //. - eapply IHdecls => //; eauto. - simpl. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - destruct KernameSet.mem. cbn. - rewrite (negbTE (proj2 (neqb _ _) e')). - eapply IHdecls => //; eauto. - eapply IHdecls => //; eauto. -Qed. -*) - -Lemma lookup_env_erase_decl_None X_type X deps decls normalization_in prf kn : - forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = None -> - EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf).1 kn = None. -Proof. - intros Σ wfΣ. - pose proof (prf _ wfΣ). - unfold lookup_env. rewrite H. clear H. - rewrite /lookup_env. - induction decls in X, Σ , wfΣ ,prf, deps, normalization_in |- *. - - move=> /= //. - - destruct a as [kn' d']. - cbn -[erase_global_deps]. - case: (eqb_spec kn kn'); intros e'; subst. - intros [= ->]. - cbn. destruct d'. cbn. - case_eq (KernameSet.mem kn' deps); move => hin'; cbn. - + destruct (eqb_spec kn kn') => //. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - now eapply IHdecls. - + intros. set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - now eapply IHdecls. - + intros hin. - case_eq (KernameSet.mem kn' deps); move => hin'; cbn. - destruct (eqb_spec kn kn') => //. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - now eapply IHdecls. - intros. set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - now eapply IHdecls. -Qed. - -Lemma lookup_env_erase_global_diff X_type X deps decls kn kn' d' normalization_in prf : - kn <> kn' -> - exists deps' nin' prf', - KernameSet.Subset deps deps' /\ - EGlobalEnv.lookup_env (erase_global_deps X_type deps X ((kn', d') :: decls) normalization_in prf).1 kn = - EGlobalEnv.lookup_env (erase_global_deps X_type deps' (abstract_pop_decls X) decls nin' prf').1 kn /\ - (KernameSet.In kn (erase_global_deps X_type deps X ((kn', d') :: decls) normalization_in prf).2 -> - KernameSet.In kn (erase_global_deps X_type deps' (abstract_pop_decls X) decls nin' prf').2). -Proof. - intros hd. - simpl. destruct d'. - + destruct KernameSet.mem. cbn. - destruct (eqb_spec kn kn') => //. - do 3 eexists. split; [|split;[reflexivity|]]. knset. - auto. - do 3 eexists. split; [|split;[reflexivity|]]. knset. - auto. - + destruct KernameSet.mem. cbn. - destruct (eqb_spec kn kn') => //. - do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. - do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. -Qed. - -Lemma lookup_env_In_map_fst Σ kn decl : lookup_global Σ kn = Some decl -> In kn (map fst Σ). -Proof. - induction Σ; cbn => //. - case: eqb_spec. - + intros -> [= <-]. now left. - + intros _ hl. eauto. -Qed. - -Lemma erase_constant_decl_deps {X_type : abstract_env_impl} (X : X_type.π1) (cb : constant_body) normalization_in oncb : - forall Σ : global_env, abstract_env_rel X Σ -> - forall kn, KernameSet.In kn (erase_constant_decl X cb normalization_in oncb).2 -> In kn (map fst (declarations Σ)). -Proof. - intros Σ wfΣ kn. - unfold erase_constant_decl. - set (ec := erase_constant_body _ _ _ _). - destruct cb. destruct cst_body0. - 2:{ subst ec; cbn. knset. } - intros hc. - epose proof (erase_constant_body_correct' (@eq_refl _ (EAst.cst_body ec.1))). - subst ec. - set (ec := erase_constant_body _ _ _ _) in *. - set (X' := abstract_make_wf_env_ext _ _ _) in *. - pose proof (abstract_env_ext_exists X') as [[Σ' H']]. - pose proof (abstract_env_ext_wf _ H') as [wfΣ']. - specialize (H _ H') as [[t0 [T []]]]. - rewrite -e in hc. - destruct p as [hty her]. - epose proof (term_global_deps_spec wfΣ' hty her _ hc). - epose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ wfΣ H'). cbn in H0. subst Σ'. - red in H. destruct H as [[decl hl]]. - now eapply lookup_env_In_map_fst in hl. -Qed. - -Lemma in_erase_global_deps_acc X_type X deps decls kn normalization_in prf : - KernameSet.In kn (erase_global_deps X_type deps X decls normalization_in prf).2 -> - KernameSet.In kn deps \/ In kn (map fst decls). -Proof. - induction decls in X, prf, deps, normalization_in |- *. - cbn; auto. destruct a as [kn' []]. - + cbn. set (ec := erase_constant_decl _ _ _ _). - set (eg := erase_global_deps _ _ _ _ _ _). - set (eg' := erase_global_deps _ _ _ _ _ _). - case_eq (KernameSet.mem kn' deps). - * cbn; intros. specialize (IHdecls _ _ _ _ H0). - destruct IHdecls as [Hu|Hm]; auto. - eapply KernameSet.union_spec in Hu. destruct Hu; auto. - unfold ec in H1; cbn in H1. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - eapply erase_constant_decl_deps in H1; tea. - pose proof (abstract_env_exists X) as [[ΣX HX]]. - unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ HX wfpop). - intros. rewrite prf => //. now eexists. - now destruct H2 as [<- _]. - * intros hdeps hin. - eapply IHdecls in hin. intuition auto. - + cbn; set (eg := erase_global_deps _ _ _ _ _ _); - set (eg' := erase_global_deps _ _ _ _ _ _). - case_eq (KernameSet.mem kn' deps). - * cbn; intros. specialize (IHdecls _ _ _ _ H0). - destruct IHdecls as [Hu|Hm]; auto. - * intros hdeps hin. - eapply IHdecls in hin. intuition auto. -Qed. - -Lemma wf_fresh_globals {cf : checker_flags} (Σ : global_env) : wf Σ -> EnvMap.EnvMap.fresh_globals Σ.(declarations). -Proof. - destruct Σ as [univs Σ]; cbn. - move=> [] onu; cbn. induction 1; try destruct o; constructor; auto; constructor; eauto. -Qed. - -Lemma lookup_env_erase_decl X_type X deps decls normalization_in prf kn decl : - forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some decl -> - let er := erase_global_deps X_type deps X decls normalization_in prf in - KernameSet.In kn er.2 -> - match decl with - | ConstantDecl cb => - exists (X' : X_type.π1) nin pf, - (EGlobalEnv.lookup_env er.1 kn = - Some (EAst.ConstantDecl (fst (erase_constant_decl X' cb nin pf)))) /\ - (forall Σ Σ', Σ ∼ X -> Σ' ∼ X' -> ∥ strictly_extends_decls Σ' Σ ∥) - | InductiveDecl mib => - EGlobalEnv.lookup_env er.1 kn = - Some (EAst.InductiveDecl (erase_mutual_inductive_body mib)) - end. -Proof. - intros Σ wfΣ. pose proof (prf _ wfΣ). - unfold lookup_env. rewrite H. clear H. - rewrite /lookup_env. - induction decls in X, Σ , wfΣ ,prf, deps, decl, normalization_in |- *. - - move=> /= //. - - destruct a as [kn' d']. - cbn -[erase_global_deps]. - case: (eqb_spec kn kn'); intros e'; subst. - intros [= ->]. - destruct decl. - + cbn; set (ec := erase_constant_decl _ _ _ _); - set (eg := erase_global_deps _ _ _ _ _ _); - set (eg' := erase_global_deps _ _ _ _ _ _). - case_eq (KernameSet.mem kn' deps). - move/KernameSet.mem_spec => hin'; cbn. - ++ intros hin. cbn; rewrite eqb_refl; - do 3 eexists. split; [reflexivity|]. - intros ? ? hx hpop. - unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ hx hpop). intros. rewrite prf => //. now eexists. - destruct H as [? []]. unfold strictly_extends_decls. rewrite H. sq; split => //. clear ec eg eg' hin. specialize (prf _ hx). rewrite prf. - now eexists [_]. - ++ intros kn'deps kn'eg'. - eapply in_erase_global_deps_acc in kn'eg'. - destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. - elimtype False. clear -prf wfΣ H. - specialize (prf _ wfΣ). - pose proof (abstract_env_wf _ wfΣ) as []. eapply wf_fresh_globals in X0. - rewrite prf in X0. depelim X0. - apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. - + cbn; - set (eg := erase_global_deps _ _ _ _ _ _); - set (eg' := erase_global_deps _ _ _ _ _ _). - case_eq (KernameSet.mem kn' deps). - move/KernameSet.mem_spec => hin'; cbn. - ++ intros hin. cbn; rewrite eqb_refl; - do 3 eexists. - ++ intros kn'deps kn'eg'. - eapply in_erase_global_deps_acc in kn'eg'. - destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. - elimtype False. clear -prf wfΣ H. - specialize (prf _ wfΣ). - pose proof (abstract_env_wf _ wfΣ) as []. eapply wf_fresh_globals in X0. - rewrite prf in X0. depelim X0. - apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. - + intros hl hin. - epose proof (lookup_env_erase_global_diff X_type X deps decls kn kn' d' _ _ e'). - destruct H as [deps' [nin' [prf' [sub [hl' hin']]]]]. - eapply hin' in hin. - erewrite hl'. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - specialize (IHdecls Xpop deps'). specialize (IHdecls nin' prf' decl _ wfpop hl hin). - destruct decl; intuition auto. - destruct IHdecls as [X' [nin [pf []]]]. exists X', nin, pf. split => //. - intros. - unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H1 wfpop). intros. rewrite prf => //. now eexists. - specialize (H0 _ _ wfpop H2). destruct H0; sq. move: X0; rewrite /strictly_extends_decls. destruct H3 as [? []]. - rewrite H4 H0 H3. rewrite -(prf' _ wfpop). pose proof (prf _ H1). rewrite -H0 in H5. rewrite H5. - intros []; split => //. destruct s as [Σ'' eq]. eexists ((kn', d') :: Σ''). now rewrite eq. -Qed. - -Lemma fresh_global_app kn Σ Σ' : fresh_global kn (Σ ++ Σ') -> - fresh_global kn Σ /\ fresh_global kn Σ'. -Proof. - induction Σ; cbn; intuition auto. - - constructor. - - depelim H. constructor => //. - now eapply Forall_app in H0. - - depelim H. - now eapply Forall_app in H0. -Qed. - -Lemma lookup_global_app_wf Σ Σ' kn : EnvMap.EnvMap.fresh_globals (Σ ++ Σ') -> - forall decl, lookup_global Σ' kn = Some decl -> lookup_global (Σ ++ Σ') kn = Some decl. -Proof. - induction Σ in kn |- *; cbn; auto. - intros fr; depelim fr. - intros decl hd; cbn. - destruct (eqb_spec kn kn0). - eapply PCUICWeakeningEnv.lookup_global_Some_fresh in hd. - subst. now eapply fresh_global_app in H as [H H']. - now eapply IHΣ. -Qed. - -Lemma strictly_extends_decls_lookup {Σ Σ'} : - wf Σ' -> - strictly_extends_decls Σ Σ' -> - forall kn d, lookup_env Σ kn = Some d -> - lookup_env Σ' kn = Some d. -Proof. - intros. - destruct X0 as [? []]. - rewrite /lookup_env in H *. rewrite e0. - erewrite lookup_global_app_wf. reflexivity. 2:eauto. - eapply wf_fresh_globals in X. now rewrite -e0. -Qed. - -Lemma in_deps_in_erase_global_deps X_type X deps decls normalization_in prf kn : - KernameSet.In kn deps -> - KernameSet.In kn (erase_global_deps X_type deps X decls normalization_in prf).2. -Proof. - induction decls in X, deps, normalization_in, prf |- *. - - intros. now cbn. - - intros. cbn. - pose proof (abstract_env_exists X) as [[Σ H']]. - set (Xpop := abstract_pop_decls X). - epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H' wfpop). intros. rewrite prf => //. now eexists. - destruct H0 as [Hd [Hu Hr]]. - destruct a. destruct g. - + set (eg := erase_global_deps _ _ _ _ _ _); - set (eg' := erase_global_deps _ _ _ _ _ _). - case_eq (KernameSet.mem k deps). - * cbn. intros hm. - destruct (eqb_spec k kn). - ++ subst k. eapply IHdecls. knset. - ++ eapply IHdecls. - knset. - * intros hnin. eapply IHdecls; tea. - + set (eg := erase_global_deps _ _ _ _ _ _); - set (eg' := erase_global_deps _ _ _ _ _ _). - case_eq (KernameSet.mem k deps). - * cbn. intros hm. - destruct (eqb_spec k kn). - ++ subst k. eapply KernameSet.mem_spec in hm. - now eapply IHdecls. - ++ eapply IHdecls. tea. - * intros hnin. eapply IHdecls; tea. -Qed. - -Fixpoint filter_deps deps decls := - match decls with - | [] => [] - | (kn, decl) :: decls => - if KernameSet.mem kn deps then - match decl with - | EAst.ConstantDecl cst => - (kn, decl) :: filter_deps (KernameSet.union deps (constant_decls_deps cst)) decls - | _ => (kn, decl) :: filter_deps deps decls - end - else filter_deps deps decls - end. - -Lemma erase_global_deps_erase_global (X_type : abstract_env_impl) (X:X_type.π1) deps decls {normalization_in} prf : - (@erase_global_deps X_type deps X decls normalization_in prf).1 = - filter_deps deps (@erase_global X_type X decls normalization_in prf). -Proof. - symmetry. - generalize normalization_in at 1. - generalize prf at 1. - intros prf' normalization_in'. - induction decls in normalization_in, normalization_in', prf, prf', X, deps |- *. - - cbn. auto. - - destruct a as [kn []]. - cbn. - + destruct (KernameSet.mem kn deps). - destruct c as [? [] ? ?]. - set (ec := erase_constant_decl _ _ _ _). - set (ec' := erase_constant_decl _ _ _ _). - assert (ec = ec') as <-. - { unfold ec, ec'. eapply erase_constant_decl_irrel. red. cbn. - intros. pose proof (abstract_env_irr _ H H0). subst. red. split; auto. congruence. } - cbn; f_equal. set (d := KernameSet.union _ _). eapply IHdecls. - cbn. f_equal. eapply IHdecls. - eapply IHdecls. - + cbn; destruct (KernameSet.mem kn deps). - cbn. f_equal. eapply IHdecls. - eapply IHdecls. -Qed. - - -Lemma filter_deps_filter {efl : EWellformed.EEnvFlags} deps Σ : - EWellformed.wf_glob Σ -> - (* (forall kn, KernameSet.In kn deps -> In kn (map fst Σ)) -> *) - filter_deps deps Σ = filter (flip KernameSet.mem (global_deps Σ deps) ∘ fst) Σ. -Proof. - induction Σ in deps |- *. - - now cbn. - - destruct a as [kn [[[]]|]]. - + cbn. unfold flip. - destruct (knset_mem_spec kn deps). - * case: (knset_mem_spec kn _). - ** intros hin' hwf. f_equal. depelim hwf. now eapply IHΣ. - ** intros nhin. - elim: nhin. - rewrite global_deps_union. - rewrite KernameSet.union_spec. left. - now eapply in_global_deps. - * intros hwf. - case: (knset_mem_spec kn _); intros hin. - ** elimtype False. - depelim hwf. - eapply in_global_deps_fresh in hin => //. - ** depelim hwf. rewrite -IHΣ => //. - + intros wf; depelim wf. - cbn. unfold flip. - * case: (knset_mem_spec kn _). - ** intros hin'. - case: (knset_mem_spec kn _) => hin''. - ++ f_equal. now eapply IHΣ. - ++ elim: hin''. - rewrite !global_deps_union. - rewrite KernameSet.union_spec. left. - now eapply in_global_deps. - ** intros hwf. - case: (knset_mem_spec kn _); intros hin. - *** elimtype False. - eapply in_global_deps_fresh in hin => //. - *** rewrite -IHΣ => //. - + intros wf; depelim wf. - cbn. unfold flip. - * case: (knset_mem_spec kn _). - ** intros hin'. - case: (knset_mem_spec kn _) => hin''. - ++ f_equal. rewrite IHΣ //. eapply filter_ext. - intros ?. unfold flip. rewrite global_deps_union /=. - rewrite global_deps_empty. - now rewrite KernameSetFact.union_b KernameSetFact.empty_b orb_false_r. - ++ elim: hin''. - rewrite !global_deps_union. - rewrite KernameSet.union_spec. left. - now eapply in_global_deps. - ** intros hwf. - case: (knset_mem_spec kn _); intros hin. - *** elimtype False. - eapply in_global_deps_fresh in hin => //. - *** rewrite -IHΣ => //. -Qed. - -Lemma erase_global_declared_constructor X_type X ind c mind idecl cdecl deps decls normalization_in prf: - forall Σ : global_env, abstract_env_rel X Σ -> declared_constructor Σ (ind, c) mind idecl cdecl -> - KernameSet.In ind.(inductive_mind) deps -> - EGlobalEnv.declared_constructor (erase_global_deps X_type deps X decls normalization_in prf).1 (ind, c) - (erase_mutual_inductive_body mind) (erase_one_inductive_body idecl) - (EAst.mkConstructor cdecl.(cstr_name) cdecl.(cstr_arity)). -Proof. - intros Σ wfΣ [[]] Hin. pose (abstract_env_wf _ wfΣ). sq. - cbn in *. split. split. - - unshelve eapply declared_minductive_to_gen in H; eauto. - red in H |- *. eapply (lookup_env_erase_decl _ _ _ _ _ _ _ (InductiveDecl mind)); eauto. - eapply in_deps_in_erase_global_deps; tea. - - - cbn. now eapply map_nth_error. - - cbn. erewrite map_nth_error; eauto. -Qed. - -Import EGlobalEnv. -Lemma erase_global_deps_fresh X_type kn deps X decls normalization_in heq : - let Σ' := erase_global_deps X_type deps X decls normalization_in heq in - PCUICAst.fresh_global kn decls -> - fresh_global kn Σ'.1. -Proof. - cbn. - revert deps X normalization_in heq. - induction decls; [cbn; auto|]. - - intros. red. constructor. - - destruct a as [kn' d]. intros. depelim H. - cbn in H, H0. - destruct d as []; simpl; destruct KernameSet.mem. - + cbn [EGlobalEnv.closed_env forallb]. cbn. - constructor => //. eapply IHdecls => //. - + eapply IHdecls => //. - + constructor; auto. - eapply IHdecls => //. - + eapply IHdecls => //. -Qed. - -Lemma erase_global_fresh X_type kn X decls normalization_in heq : - let Σ' := @erase_global X_type X decls normalization_in heq in - PCUICAst.fresh_global kn decls -> - fresh_global kn Σ'. -Proof. - cbn. - revert X normalization_in heq. - induction decls; [cbn; auto|]. - - intros. red. constructor. - - destruct a as [kn' d]. intros. depelim H. - cbn in H, H0. cbn. - destruct d as []; simpl. - + cbn [EGlobalEnv.closed_env forallb]. cbn. - constructor => //. eapply IHdecls => //. - + constructor; auto. - eapply IHdecls => //. -Qed. - -From MetaCoq.Erasure Require Import EEtaExpandedFix. - -Lemma erase_brs_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ p ts wt : - erase_brs X_type X Γ p ts wt = - map_All (fun br wt => (erase_context (bcontext br), erase X_type X _ (bbody br) wt)) ts wt. -Proof. - funelim (map_All _ ts wt); cbn; auto. - f_equal => //. f_equal => //. apply erase_irrel. - rewrite -H. eapply erase_irrel. -Qed. - -Lemma erase_fix_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ ts wt : - erase_fix X_type X Γ ts wt = map_All (fun d wt => - let dbody' := erase X_type X _ (dbody d) (fun Σ abs => proj2 (wt Σ abs)) in - let dbody' := if isBox dbody' then - match d.(dbody) with - | tLambda na _ _ => E.tLambda (binder_name na) E.tBox - | _ => dbody' - end else dbody' - in - {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |}) ts wt. -Proof. - funelim (map_All _ ts wt); cbn; auto. - f_equal => //. f_equal => //. - rewrite (fst (erase_irrel _ _) _ _ _ _ (fun (Σ : global_env_ext) (abs : abstract_env_ext_rel X Σ) => - (map_All_obligation_1 x xs h Σ abs).p2)). - destruct erase => //. - rewrite -H. eapply erase_irrel. -Qed. - -Lemma erase_cofix_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ ts wt : - erase_cofix X_type X Γ ts wt = map_All (fun d wt => - let dbody' := erase X_type X _ (dbody d) wt in - {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |}) ts wt. -Proof. - funelim (map_All _ ts wt); cbn; auto. - f_equal => //. f_equal => //. - apply erase_irrel. - rewrite -H. eapply erase_irrel. -Qed. - -Lemma isConstruct_erase X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t wt : - ~ (PCUICEtaExpand.isConstruct t || PCUICEtaExpand.isFix t || PCUICEtaExpand.isRel t) -> - ~ (isConstruct (erase X_type X Γ t wt) || isFix (erase X_type X Γ t wt) || isRel (erase X_type X Γ t wt)). -Proof. - apply (erase_elim X_type X - (fun Γ t wt e => ~ (PCUICEtaExpand.isConstruct t || PCUICEtaExpand.isFix t || PCUICEtaExpand.isRel t) -> ~ (isConstruct e || isFix e || isRel e)) - (fun Γ l awt e => True) - (fun Γ p l awt e => True) - (fun Γ l awt e => True) - (fun Γ l awt e => True)); intros => //. bang. -Qed. - -Lemma apply_expanded Σ Γ Γ' t t' : - expanded Σ Γ t -> Γ = Γ' -> t = t' -> expanded Σ Γ' t'. -Proof. intros; now subst. Qed. - -Lemma isLambda_inv t : isLambda t -> exists na ty bod, t = tLambda na ty bod. -Proof. destruct t => //; eauto. Qed. - -Lemma erases_deps_erase (cf := config.extraction_checker_flags) - {X_type X} univs - (wfΣ : forall Σ, (abstract_env_rel X Σ) -> ∥ wf_ext (Σ, univs) ∥) decls {normalization_in} prf - (X' := abstract_make_wf_env_ext X univs wfΣ) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} - Γ t - (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) : - let et := erase X_type X' Γ t wt in - let deps := EAstUtils.term_global_deps et in - forall Σ, (abstract_env_rel X Σ) -> - erases_deps Σ (erase_global_deps X_type deps X decls normalization_in prf).1 et. -Proof. - intros et deps Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. - pose proof (wt _ wfΣ'). destruct H. pose proof (wfΣ _ wf) as [w]. - rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ') in X0. - eapply (erase_global_erases_deps w); tea. - eapply (erases_erase (X := X') (Γ := Γ)). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply erase_global_includes. - intros. rewrite (abstract_env_irr _ H0 wf). - eapply term_global_deps_spec in H; eauto. - assumption. - eapply (erases_erase (X := X') (Γ := Γ)). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply KernameSet.subset_spec. reflexivity. - now cbn. -Qed. - -Lemma erases_deps_erase_weaken (cf := config.extraction_checker_flags) - {X_type X} univs - (wfΣ : forall Σ, (abstract_env_rel X Σ) -> ∥ wf_ext (Σ, univs) ∥) decls {normalization_in} prf - (X' := abstract_make_wf_env_ext X univs wfΣ) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} - Γ t - (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) - deps : - let et := erase X_type X' Γ t wt in - let tdeps := EAstUtils.term_global_deps et in - forall Σ, (abstract_env_rel X Σ) -> - erases_deps Σ (erase_global_deps X_type (KernameSet.union deps tdeps) X decls normalization_in prf).1 et. -Proof. - intros et tdeps Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. - pose proof (wt _ wfΣ'). destruct H. pose proof (wfΣ _ wf) as [w]. - rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ') in X0. - eapply (erase_global_erases_deps w); tea. - eapply (erases_erase (X := X') (Γ := Γ)). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply erase_global_includes. - intros. rewrite (abstract_env_irr _ H0 wf). - eapply term_global_deps_spec in H; eauto. - assumption. - eapply (erases_erase (X := X') (Γ := Γ)). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply KernameSet.subset_spec. intros x hin. - eapply KernameSet.union_spec. now right. - now cbn. -Qed. - -Lemma eta_expand_erase {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Σ' {Γ t} - (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) Γ' : - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> - PCUICEtaExpand.expanded Σ Γ' t -> - erases_global Σ Σ' -> - expanded Σ' Γ' (erase X_type X Γ t wt). -Proof. - intros Σ wfΣ exp deps. - pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. - eapply expanded_erases. apply wf. - eapply erases_erase; eauto. assumption. - pose proof (wt _ wfΣ). destruct H as [T ht]. - eapply erases_global_erases_deps; tea. - eapply erases_erase; eauto. -Qed. - -Lemma erase_global_closed X_type X deps decls {normalization_in} prf : - let X' := erase_global_deps X_type deps X decls normalization_in prf in - EGlobalEnv.closed_env X'.1. -Proof. - revert X normalization_in prf deps. - induction decls; [cbn; auto|]. - intros X normalization_in prf deps. - destruct a as [kn d]. - destruct d as []; simpl; destruct KernameSet.mem; - unfold erase_constant_decl; - set (Xpop := abstract_pop_decls X); - try (set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); - assert (normalization_in_Xmake : forall Σ : global_env_ext, wf_ext Σ -> Σ ∼_ext Xmake -> NormalizationIn Σ) - by (subst Xmake; unshelve eapply (normalization_in 0); revgoals; try reflexivity; cbn; lia)). - + cbn [EGlobalEnv.closed_env forallb]. cbn. - rewrite [forallb _ _](IHdecls) // andb_true_r. - rewrite /test_snd /EGlobalEnv.closed_decl /=. - destruct c as [ty [] univs]; cbn. - unfold erase_constant_decl. - set (obl := erase_constant_body_obligation_1 _ _ _ _ _). - unfold erase_constant_body. cbn. clearbody obl. cbn in obl. - 2:auto. - pose proof (abstract_env_ext_exists Xmake) as [[Σmake wfmake]]. - pose proof (abstract_env_ext_wf _ wfmake) as [[?]]. - unshelve epose proof (erases_erase (X := Xmake) (obl eq_refl) _ _) as H; eauto. - eapply erases_closed in H. - 1: edestruct erase_irrel as [-> _]; eassumption. - cbn. destruct (obl eq_refl _ wfmake). clear H. - now eapply PCUICClosedTyp.subject_closed in X0. - + eapply IHdecls => //. - + cbn [EGlobalEnv.closed_env forallb]. - eapply IHdecls => //. - + eapply IHdecls => //. - Unshelve. eauto. -Qed. - -Import EWellformed. - -Section wffix. - Import EAst. - Fixpoint wf_fixpoints (t : term) : bool := - match t with - | tRel i => true - | tEvar ev args => List.forallb (wf_fixpoints) args - | tLambda N M => wf_fixpoints M - | tApp u v => wf_fixpoints u && wf_fixpoints v - | tLetIn na b b' => wf_fixpoints b && wf_fixpoints b' - | tCase ind c brs => - let brs' := forallb (wf_fixpoints ∘ snd) brs in - wf_fixpoints c && brs' - | tProj p c => wf_fixpoints c - | tFix mfix idx => - (idx isLambda d.(dbody) && wf_fixpoints d.(dbody)) mfix - | tCoFix mfix idx => - (idx true - | tConstruct ind c _ => true - | tVar _ => true - | tBox => true - | tPrim _ => true - end. - -End wffix. - -Lemma erases_deps_wellformed (cf := config.extraction_checker_flags) (efl := all_env_flags) {Σ} {Σ'} et : - erases_deps Σ Σ' et -> - forall n, ELiftSubst.closedn n et -> - wf_fixpoints et -> - wellformed Σ' n et. -Proof. - intros ed. - induction ed using erases_deps_forall_ind; intros => //; - try solve [cbn in *; unfold wf_fix in *; rtoProp; intuition eauto; solve_all]. - - cbn. red in H0. rewrite H0 //. - - cbn -[lookup_constructor]. - cbn. now destruct H0 as [[-> ->] ->]. - - cbn in *. move/andP: H5 => [] cld clbrs. - cbn. apply/andP; split. apply/andP; split. - * now destruct H0 as [-> ->]. - * now move/andP: H6. - * move/andP: H6; solve_all. - - cbn -[lookup_projection] in *. apply/andP; split; eauto. - now rewrite (declared_projection_lookup H0). -Qed. - -Lemma erases_wf_fixpoints Σ Γ t t' : Σ;;; Γ |- t ⇝ℇ t' -> - ErasureProperties.wellformed Σ t -> wf_fixpoints t'. -Proof. - induction 1 using erases_forall_list_ind; cbn; auto; try solve [rtoProp; repeat solve_all]. - - move/andP => []. rewrite (All2_length X) => -> /=. unfold test_def in *. - eapply Forall2_All2 in H. - eapply All2_All2_mix in X; tea. solve_all. - destruct b0; eapply erases_isLambda in H1; tea. - - move/andP => []. rewrite (All2_length X) => -> /=. - unfold test_def in *. solve_all. -Qed. - -Lemma erase_wf_fixpoints (efl := all_env_flags) {X_type X} univs wfΣ {Γ t} wt - (X' := abstract_make_wf_env_ext X univs wfΣ) {normalization_in} : - let t' := erase X_type X' (normalization_in:=normalization_in) Γ t wt in - wf_fixpoints t'. -Proof. - cbn. pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. - pose proof (abstract_env_exists X) as [[Σ wf]]. - eapply erases_wf_fixpoints. - eapply erases_erase; eauto. - specialize (wt _ wf'). destruct (wfΣ _ wf). - unshelve eapply welltyped_wellformed in wt; eauto. - now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wf'). -Qed. - -Lemma erases_global_erase_global (efl := all_env_flags) {X_type X} Σ decls {normalization_in} prf : - Σ ∼ X -> - erases_global Σ (@erase_global X_type X decls normalization_in prf). -Proof. - intros h. pose proof (prf _ h). red. rewrite H. clear H. - induction decls in X, Σ, prf, normalization_in, h |- *. - - cbn. constructor. - - cbn. - set (Xpop := abstract_pop_decls X). - destruct (abstract_env_exists Xpop) as [[Σpop hpop]]. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ h hpop). - intros; eexists; now eapply prf. - destruct H as [? []]. - destruct a as [kn []]. - * constructor. cbn. - unfold erase_constant_decl. - set (Σd := {| universes := _ |}). - assert (Σd = Σpop). - { subst Σd. rewrite -H H0 H1. now destruct Σpop. } - subst Σd. - set (ext := abstract_make_wf_env_ext _ _ _). - pose proof (abstract_env_ext_exists ext) as [[Σ' wf']]. - epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ hpop wf'). - subst Σ'. - cbn. pose proof (abstract_env_wf _ hpop) as []. - eapply (erase_constant_body_correct _ _ _ _ (Σpop, cst_universes c)) => //. - now rewrite H2. rewrite H2. split => //. now exists []. - rewrite H0 H1. - now eapply IHdecls. - * pose proof (abstract_env_wf _ h) as [wfΣ]. - destruct wfΣ. rewrite (prf _ h) in o0. - depelim o0. depelim o1. - constructor. - eapply erases_mutual. eapply on_global_decl_d. - rewrite H0 H1. - now eapply IHdecls. -Qed. - -Lemma erase_global_wellformed (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt - (X' := abstract_make_wf_env_ext X univs wfΣ) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} - (t' := erase X_type X' Γ t wt) : - wellformed (@erase_global X_type X decls normalization_in prf) #|Γ| t'. -Proof. - cbn. - epose proof (@erases_erase X_type X' normalization_in' _ _ wt). - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. - pose proof (abstract_env_ext_wf _ wf') as [?]. - eapply (erases_wellformed (wt _ wf')) in H; eauto; tea. - eapply erases_global_all_deps. apply X0. - epose proof (abstract_make_wf_env_ext_correct _ _ wfΣ _ _ wf wf'). subst Σ'. - now eapply erases_global_erase_global. -Qed. - -Lemma erase_wellformed_deps (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt - (X' := abstract_make_wf_env_ext X univs wfΣ) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} - (t' := erase X_type X' Γ t wt) : - wellformed (erase_global_deps X_type (term_global_deps t') X decls normalization_in prf).1 #|Γ| t'. -Proof. - cbn. - epose proof (@erases_deps_erase X_type X univs wfΣ decls normalization_in prf _ Γ t wt). - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. - pose proof (abstract_env_ext_wf _ wf') as [[?]]. - epose proof (erases_deps_wellformed _ H #|Γ|). - apply H0. - eapply (erases_closed _ Γ). - destruct (wt _ wf'). - cbn in X. destruct (wfΣ _ wf). - eapply PCUICClosedTyp.subject_closed in X0. eassumption. - eapply erases_erase; eauto. - eapply erase_wf_fixpoints. Unshelve. eauto. -Qed. - -Lemma erase_wellformed_weaken (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt -(X' := abstract_make_wf_env_ext X univs wfΣ) -{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} -deps: -let t' := erase X_type X' Γ t wt in - wellformed (erase_global_deps X_type (KernameSet.union deps (term_global_deps t')) X decls normalization_in prf).1 #|Γ| t'. -Proof. - set (t' := erase _ _ _ _ _). cbn. - epose proof (@erases_deps_erase_weaken _ X univs wfΣ decls _ prf _ Γ t wt deps). - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. - pose proof (abstract_env_ext_wf _ wf') as [[?]]. - epose proof (erases_deps_wellformed _ H #|Γ|). - apply H0. - eapply (erases_closed _ Γ). - - destruct (wt _ wf'). - destruct (wfΣ _ wf). - eapply PCUICClosedTyp.subject_closed in X0. eassumption. - - eapply erases_erase; eauto. - - eapply erase_wf_fixpoints. - Unshelve. eauto. -Qed. - -Lemma erase_constant_body_correct'' {X_type X} {cb} {decls normalization_in prf} {univs wfΣ} -(X' := abstract_make_wf_env_ext X univs wfΣ) -{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} -{onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} deps : - EAst.cst_body (fst (erase_constant_body X_type X' cb onc)) = Some body -> - forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> - ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * - (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * - wellformed (efl:=all_env_flags) (erase_global_deps X_type (KernameSet.union deps (term_global_deps body)) X decls normalization_in prf).1 0 body ∥. -Proof. - intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. - destruct cb as [name [bod|] udecl]; simpl. - simpl in H. noconf H. - set (obl :=(erase_constant_body_obligation_1 X_type X' - {| - cst_type := name; - cst_body := Some bod; - cst_universes := udecl |} onc bod eq_refl)). clearbody obl. - destruct (obl _ wfΣ'). sq. - have er : (Σ, univs);;; [] |- bod ⇝ℇ erase X_type X' [] bod obl. - { eapply (erases_erase (X:=X')). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - } - exists bod, A; intuition auto. - now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply erase_wellformed_weaken. - now simpl in H. -Qed. - -Lemma erase_global_cst_decl_wf_glob X_type X deps decls normalization_in heq : - forall cb wfΣ hcb, - let X' := abstract_make_wf_env_ext X (cst_universes cb) wfΣ in - forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, - let ecb := erase_constant_body X_type X' cb hcb in - let Σ' := erase_global_deps X_type (KernameSet.union deps ecb.2) X decls normalization_in heq in - (@wf_global_decl all_env_flags Σ'.1 (EAst.ConstantDecl ecb.1) : Prop). -Proof. - intros cb wfΣ hcb X' normalization_in' ecb Σ'. - unfold wf_global_decl. cbn. - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. - destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. - destruct EAst.cst_body eqn:hb => /= //. - eapply (erase_constant_body_correct'') in hb; eauto. - destruct hb as [[t0 [T [[] ?]]]]. rewrite e in i. exact i. -Qed. - -Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls normalization_in kn m} heq : - (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> - let m' := erase_mutual_inductive_body m in - let Σ' := erase_global_deps X_type deps X decls normalization_in heq in - @wf_global_decl all_env_flags Σ'.1 (EAst.InductiveDecl m'). -Proof. - set (m' := erase_mutual_inductive_body m). - set (Σ' := erase_global_deps _ _ _ _ _ _). simpl. - intros oni. - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). - { eapply (erases_mutual (mdecl:=kn)); tea. } - eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ'.1)) in H; tea. - rewrite -(heq _ wf). now destruct Σ. -Qed. - -Lemma erase_global_deps_wf_glob X_type X deps decls normalization_in heq : - let Σ' := erase_global_deps X_type deps X decls normalization_in heq in - @wf_glob all_env_flags Σ'.1. -Proof. - cbn. - pose proof (abstract_env_exists X) as [[Σ wf]]. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - revert deps X Σ wf wfΣ normalization_in heq. - induction decls; [cbn; auto|]. - { intros. constructor. } - intros. destruct a as [kn []]; simpl; destruct KernameSet.mem; set (Xpop := abstract_pop_decls X); - try set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); - epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; - pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. - + constructor. eapply IHdecls => //; eauto. eapply erase_global_cst_decl_wf_glob; auto. - eapply erase_global_deps_fresh; auto. - destruct wfΣ. destruct wfΣpop. - rewrite (heq _ wf) in o0. depelim o0. now destruct o3. - + cbn. eapply IHdecls; eauto. - + constructor. eapply IHdecls; eauto. - destruct wfΣ as [[onu ond]]. - rewrite (heq _ wf) in o. depelim o. destruct o0. - eapply (erase_global_ind_decl_wf_glob (kn:=kn)); tea. - intros. rewrite (abstract_env_irr _ H wfpop). - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. - {intros; now eexists. } - destruct Σpop, Σ; cbn in *. now subst. - eapply erase_global_deps_fresh. - destruct wfΣ as [[onu ond]]. - rewrite (heq _ wf) in o. depelim o. now destruct o0. - + eapply IHdecls; eauto. -Qed. - -Lemma erase_constant_body_correct_glob {X_type X} {cb} {decls normalization_in prf} {univs wfΣ} - (X' := abstract_make_wf_env_ext X univs wfΣ) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} - {onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} : - EAst.cst_body (fst (erase_constant_body X_type X' cb onc)) = Some body -> - forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> - ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * - (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * - wellformed (efl:=all_env_flags) (@erase_global X_type X decls normalization_in prf) 0 body ∥. -Proof. - intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. - destruct cb as [name [bod|] udecl]; simpl. - simpl in H. noconf H. - set (obl :=(erase_constant_body_obligation_1 X_type X' - {| - cst_type := name; - cst_body := Some bod; - cst_universes := udecl |} onc bod eq_refl)). clearbody obl. - destruct (obl _ wfΣ'). sq. - have er : (Σ, univs);;; [] |- bod ⇝ℇ erase X_type X' [] bod obl. - { eapply (erases_erase (X:=X')). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - } - exists bod, A; intuition auto. - now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply (erase_global_wellformed decls _ _ _ (Γ := [])). - now simpl in H. -Qed. - -Lemma erase_global_cst_wf_glob X_type X decls normalization_in heq : - forall cb wfΣ hcb, - let X' := abstract_make_wf_env_ext X (cst_universes cb) wfΣ in - forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, - let ecb := erase_constant_body X_type X' cb hcb in - let Σ' := @erase_global X_type X decls normalization_in heq in - (@wf_global_decl all_env_flags Σ' (EAst.ConstantDecl ecb.1) : Prop). -Proof. - intros cb wfΣ hcb X' normalization_in' ecb Σ'. - unfold wf_global_decl. cbn. - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. - destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. - destruct EAst.cst_body eqn:hb => /= //. - eapply (erase_constant_body_correct_glob) in hb; eauto. - destruct hb as [[t0 [T [[] ?]]]]. exact i. -Qed. - -Lemma erase_global_ind_decl_wf_glob' {X_type X} {decls normalization_in kn m} heq : - (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> - let m' := erase_mutual_inductive_body m in - let Σ' := @erase_global X_type X decls normalization_in heq in - @wf_global_decl all_env_flags Σ' (EAst.InductiveDecl m'). -Proof. - set (m' := erase_mutual_inductive_body m). - set (Σ' := erase_global _ _ _). simpl. - intros oni. - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). - { eapply (erases_mutual (mdecl:=kn)); tea. } - eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ')) in H; tea. - rewrite -(heq _ wf). now destruct Σ. -Qed. - -Lemma erase_global_wf_glob X_type X decls normalization_in heq : - let Σ' := @erase_global X_type X decls normalization_in heq in - @wf_glob all_env_flags Σ'. -Proof. - cbn. - pose proof (abstract_env_exists X) as [[Σ wf]]. - pose proof (abstract_env_wf _ wf) as [wfΣ]. - revert X Σ wf wfΣ normalization_in heq. - induction decls; [cbn; auto|]. - { intros. constructor. } - intros. destruct a as [kn []]; simpl; set (Xpop := abstract_pop_decls X); - try set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); - epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; - pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. - + constructor. eapply IHdecls => //; eauto. - eapply erase_global_cst_wf_glob; auto. - eapply erase_global_fresh; auto. - destruct wfΣ. destruct wfΣpop. - rewrite (heq _ wf) in o0. depelim o0. now destruct o3. - + constructor. eapply IHdecls; eauto. - destruct wfΣ as [[onu ond]]. - rewrite (heq _ wf) in o. depelim o. destruct o0. - eapply (erase_global_ind_decl_wf_glob' (kn:=kn)); tea. - intros. rewrite (abstract_env_irr _ H wfpop). - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. - { intros; now eexists. } - destruct Σpop, Σ; cbn in *. now subst. - eapply erase_global_fresh. - destruct wfΣ as [[onu ond]]. - rewrite (heq _ wf) in o. depelim o. now destruct o0. -Qed. - -Lemma extends_cons d Σ Σ' : extends Σ Σ' -> extends (d :: Σ) (d :: Σ'). -Proof. - intros ext kn decl. - cbn. - case: (eqb_spec kn d.1). - - now intros -> [= <-]. - - intros hin. apply ext. -Qed. - -Lemma extends_fresh Σ Σ' kn d : - fresh_global kn Σ' -> - extends Σ Σ' -> - extends Σ ((kn, d) :: Σ'). -Proof. - intros fr ext. - intros kn' decl hl. - cbn. destruct (eqb_spec kn' kn) => //. subst. - eapply ext in hl. now eapply lookup_env_Some_fresh in hl. - now eapply ext. -Qed. - -Lemma Forall_filter {A} {P} f l : @Forall A P l -> Forall P (filter f l). -Proof. - induction 1; try econstructor; auto. - cbn. case E: (f x) => //. now constructor. -Qed. - -Lemma extends_filter_impl {efl : EEnvFlags} (f f' : kername * EAst.global_decl -> bool) Σ : - (forall x, f x -> f' x) -> - wf_glob Σ -> - extends (filter f Σ) (filter f' Σ). -Proof. - intros hf; induction Σ; cbn; auto. - - red; auto. - - intros wf; depelim wf. - case E: (f _); auto. rewrite (hf _ E). - now eapply extends_cons. - case E': (f' _); auto. - eapply extends_fresh. now eapply Forall_filter. - auto. -Qed. - -Lemma extends_filter {efl : EEnvFlags} (f : kername * EAst.global_decl -> bool) Σ : - wf_glob Σ -> - extends (filter f Σ) Σ. -Proof. - intros wf hf; induction Σ; cbn; auto. - intros decl. depelim wf. cbn in *. - case E: (f _); auto; cbn. - case (eqb_spec hf kn) => //. - - intros hd. now eapply IHΣ. - - intros hl; eapply IHΣ in hl => //. rewrite hl. - case (eqb_spec hf kn) => heq. - subst. now eapply lookup_env_Some_fresh in hl. - reflexivity. -Qed. - -Lemma erase_global_deps_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X X':X_type.π1) ext wfX wfX' {normalization_in} {normalization_in'} decls nin prf Γ t wt v wv : - let Xext := abstract_make_wf_env_ext X ext wfX in - let Xext' := abstract_make_wf_env_ext X' ext wfX' in - let t' := erase X_type Xext (normalization_in := normalization_in) Γ t wt in - let v' := erase X_type Xext' (normalization_in := normalization_in') Γ v wv in - let eg := erase_global_deps X_type (term_global_deps t') X decls nin prf in - let eg' := erase_global_deps X_type (term_global_deps v') X decls nin prf in - eg.1 ⊢ t' ⇓ v' -> EGlobalEnv.extends eg'.1 eg.1. -Proof. - intros. - move: (erase_global_deps_wf_glob X_type X (term_global_deps t') decls nin prf). - subst eg eg'. - rewrite !erase_global_deps_erase_global. - assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls nin prf)). - { eapply erase_global_wf_glob. } - rewrite !(filter_deps_filter (efl := all_env_flags)) //. - cbn. - intros wf. - eapply extends_filter_impl; tea. unfold flip in *. - intros [kn d]; cbn. clear d. - rewrite /is_true !KernameSet.mem_spec. revert kn. - eapply EWcbvEval.weakening_eval_env in H. 2:exact wfer. - now eapply eval_global_deps in H. - rewrite !erase_global_deps_erase_global (filter_deps_filter (efl := all_env_flags)) //. - now eapply extends_filter. -Qed. - -Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {deps deps' decls normalization_in prf} : - KernameSet.Subset deps deps' -> - EExtends.global_subset (erase_global_deps X_type deps X decls normalization_in prf).1 (erase_global_deps X_type deps' X decls normalization_in prf).1. -Proof. - intros sub. - rewrite !erase_global_deps_erase_global. - assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls normalization_in prf)). - { eapply erase_global_wf_glob. } - rewrite !(filter_deps_filter (efl := all_env_flags)) //. - eapply extends_filter_impl => //. 2:exact wfer. - unfold flip. - move=> x /KernameSet.mem_spec hin. - apply/KernameSet.mem_spec. - eapply global_deps_subset; tea. -Qed. - -Lemma expanded_weakening_global X_type X deps deps' decls normalization_in prf Γ t : - KernameSet.Subset deps deps' -> - expanded (erase_global_deps X_type deps X decls normalization_in prf).1 Γ t -> - expanded (erase_global_deps X_type deps' X decls normalization_in prf).1 Γ t. -Proof. - intros hs. - eapply expanded_ind; intros; try solve [econstructor; eauto]. - - eapply expanded_tFix; tea. solve_all. - - eapply expanded_tConstruct_app; tea. - destruct H. split; tea. - destruct d; split => //. - cbn in *. red in H. - eapply lookup_erase_global in H; tea. -Qed. - -Lemma expanded_erase (cf := config.extraction_checker_flags) - {X_type X decls normalization_in prf} univs wfΣ t wtp : - forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded Σ [] t -> - let X' := abstract_make_wf_env_ext X univs wfΣ in - forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, - let et := (erase X_type X' [] t wtp) in - let deps := EAstUtils.term_global_deps et in - expanded (erase_global_deps X_type deps X decls normalization_in prf).1 [] et. -Proof. - intros Σ wf hexp X' normalization_in'. - pose proof (abstract_env_wf _ wf) as [wf']. - pose proof (abstract_env_ext_exists X') as [[? wfmake]]. - eapply (expanded_erases (Σ := (Σ, univs))); tea. - eapply (erases_erase (X := X')); eauto. - now erewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ). - cbn. - eapply (erases_deps_erase (X := X) univs wfΣ); eauto. -Qed. - -Lemma expanded_erase_global (cf := config.extraction_checker_flags) - deps {X_type X decls normalization_in prf} : - forall Σ : global_env, abstract_env_rel X Σ -> - PCUICEtaExpand.expanded_global_env Σ -> - expanded_global_env (erase_global_deps X_type deps X decls normalization_in prf).1. -Proof. - intros Σ wf etaΣ. pose proof (prf _ wf). - destruct Σ as [univ decls']. - red. revert wf. red in etaΣ. cbn in *. subst. - revert deps X normalization_in prf. - induction etaΣ; intros deps. intros. constructor. intros. - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop wfpop]]. - unshelve epose proof (abstract_pop_decls_correct X Σ _ _ _ wf wfpop) as [? [? ?]]. - { now eexists. } - destruct Σpop. cbn in H0, H1, H2. subst. - destruct decl as [kn []]; - destruct (KernameSet.mem kn deps) eqn:eqkn; simpl; rewrite eqkn. - constructor; [eapply IHetaΣ; auto|]. - red. cbn. red. cbn in *. - unfold erase_constant_decl. - set (deps' := KernameSet.union _ _). hidebody deps'. - set (wfext := abstract_make_wf_env_ext _ _ _). hidebody wfext. - destruct H. - destruct c as [cst_na [cst_body|] cst_type cst_rel]. - cbn in *. - eapply expanded_weakening_global. - 2:{ eapply expanded_erase; tea. } - set (et := erase _ _ _ _) in *. - unfold deps'. unfold hidebody. intros x hin. - eapply KernameSet.union_spec. right => //. - now cbn. - eapply IHetaΣ; eauto. - constructor. eapply IHetaΣ; eauto. - red. cbn => //. - eapply IHetaΣ; eauto. -Qed. - -(* Sanity checks: the [erase] function maximally erases terms *) -Lemma erasable_tBox_value (wfl := Ee.default_wcbv_flags) (Σ : global_env_ext) (wfΣ : wf_ext Σ) t T v : - forall wt : Σ ;;; [] |- t : T, - Σ |-p t ⇓ v -> erases Σ [] v E.tBox -> ∥ isErasable Σ [] t ∥. -Proof. - intros. - depind H. - eapply Is_type_eval_inv; eauto. eexists; eauto. -Qed. - -Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) - {X_type X} {univs wfext t v Σ' t' deps decls normalization_in prf} - (Xext := abstract_make_wf_env_ext X univs wfext) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} - : - forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, - erase X_type Xext [] t wt = t' -> - KernameSet.subset (term_global_deps t') deps -> - erase_global_deps X_type deps X decls normalization_in prf = Σ' -> - forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> - (forall Σ : global_env, abstract_env_rel X Σ -> - PCUICWcbvEval.eval Σ t v) -> - @Ee.eval Ee.default_wcbv_flags Σ'.1 t' E.tBox -> ∥ isErasable Σext [] t ∥. -Proof. - intros wt. - intros. - destruct (erase_correct X_type X univs wfext _ _ Σ' _ _ decls prf wt H H0 H1 X0 _ H2) as [ev [eg [eg']]]. - pose proof (Ee.eval_deterministic H3 eg'). subst. - pose proof (abstract_env_exists X) as [[? wf]]. - destruct (wfext _ wf). destruct (wt _ H2) as [T wt']. - pose proof (abstract_env_ext_wf _ H2) as [?]. - eapply erasable_tBox_value; eauto. - pose proof (abstract_make_wf_env_ext_correct X univs wfext _ _ wf H2). subst. - apply X0; eauto. -Qed. - -Lemma erase_eval_to_box_eager (wfl := Ee.default_wcbv_flags) - {X_type X} {univs wfext t v Σ' t' deps decls normalization_in prf} - (Xext := abstract_make_wf_env_ext X univs wfext) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} - : - forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, - erase X_type Xext [] t wt = t' -> - KernameSet.subset (term_global_deps t') deps -> - erase_global_deps X_type deps X decls normalization_in prf = Σ' -> - forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> - (forall Σ : global_env, abstract_env_rel X Σ -> - PCUICWcbvEval.eval Σ t v) -> - @Ee.eval Ee.default_wcbv_flags Σ'.1 t' E.tBox -> t' = E.tBox. -Proof. - intros wt. - intros. - destruct (erase_eval_to_box wt H H0 H1 _ H2 X0 H3). - subst t'. - destruct (inspect_bool (is_erasableb X_type Xext [] t wt)) eqn:heq. - - simp erase. rewrite heq. - simp erase => //. - - elimtype False. - pose proof (abstract_env_exists X) as [[? wf]]. - destruct (@is_erasableP X_type Xext _ [] t wt) => //. apply n. - intros. sq. now rewrite (abstract_env_ext_irr _ H H2). -Qed. - -From MetaCoq.PCUIC Require Import PCUICFirstorder. - - -Lemma welltyped_mkApps_inv {cf} {Σ : global_env_ext} Γ f args : ∥ wf Σ ∥ -> - welltyped Σ Γ (mkApps f args) -> welltyped Σ Γ f /\ Forall (welltyped Σ Γ) args. -Proof. - intros wf (A & HA). sq. eapply inversion_mkApps in HA as (? & ? & ?). - split. eexists; eauto. - induction t0 in f |- *; econstructor; eauto; econstructor; eauto. -Qed. - -From MetaCoq.PCUIC Require Import PCUICProgress. - -Lemma firstorder_erases_deterministic X_type (X : X_type.π1) - univs wfext {v t' i u args} - (Xext := abstract_make_wf_env_ext X univs wfext) - {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} - : - forall wv : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] v), - forall Σ, Σ ∼_ext Xext -> - Σ ;;; [] |- v : mkApps (tInd i u) args -> - Σ |-p v ⇓ v -> - @firstorder_ind Σ (firstorder_env Σ) i -> - erases Σ [] v t' -> - t' = erase X_type Xext (normalization_in:=normalization_in) [] v wv. -Proof. - intros wv Σ Hrel Hty Hvalue Hfo Herase. - destruct (firstorder_lookup_inv Hfo) as [mind Hdecl]. - assert (Hext : ∥ wf_ext Σ∥) by now eapply heΣ. - sq. eapply firstorder_value_spec in Hty as Hfov; eauto. - clear - Hrel Hext Hfov Herase. - revert t' wv Herase. - pattern v. - revert v Hfov. - eapply firstorder_value_inds. intros. - rewrite erase_mkApps. - - intros Σ0 HΣ0. pose proof (abstract_env_ext_irr _ HΣ0 Hrel). subst. - eapply PCUICValidity.inversion_mkApps in X0 as (? & XX & Happ). - clear XX. revert Happ. clear. generalize (mkApps (tInd i u) pandi). induction 1. - + econstructor. - + econstructor. econstructor; eauto. eauto. - - intros. eapply erases_mkApps_inv in Herase as [(? & ? & ? & -> & [Herasable] & ? & ? & ->)|(? & ? & -> & ? & ?)]. all:eauto. - + exfalso. eapply isErasable_Propositional in Herasable; eauto. - red in H1, Herasable. unfold PCUICAst.lookup_inductive, lookup_inductive_gen, PCUICAst.lookup_minductive, lookup_minductive_gen, isPropositionalArity in *. - edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; try congruence. - + inv H2. - * cbn. unfold erase_clause_1. destruct (inspect_bool (is_erasableb X_type Xext [] (tConstruct i n ui) Hyp0)). - -- exfalso. sq. destruct (@is_erasableP _ _ _ [] (tConstruct i n ui) Hyp0) => //. - specialize_Σ Hrel. sq. - eapply (isErasable_Propositional (args := [])) in s; eauto. - red in H1, s. unfold PCUICAst.lookup_inductive, lookup_inductive_gen, PCUICAst.lookup_minductive, lookup_minductive_gen, isPropositionalArity in *. - edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; congruence. - -- f_equal. eapply Forall2_eq. clear X0 H wv. induction H3. - ++ cbn. econstructor. - ++ cbn. econstructor. - ** inv H0. eapply H5. eauto. - ** inv H0. eapply IHForall2. eauto. - * exfalso. eapply (isErasable_Propositional (args := [])) in X1; eauto. - red in H1, X1. - unfold PCUICAst.lookup_inductive, lookup_inductive_gen, PCUICAst.lookup_minductive, lookup_minductive_gen, isPropositionalArity in *. - edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; congruence. - - eauto. - - intros ? ? H3. assert (Hext_ : ∥ wf_ext Σ0∥) by now eapply heΣ. - sq. - specialize_Σ H2. - eapply (isErasable_Propositional) in H3; eauto. - pose proof (abstract_env_ext_irr _ H2 Hrel). subst. - red in H1, H3. unfold PCUICAst.lookup_inductive, lookup_inductive_gen, PCUICAst.lookup_minductive, lookup_minductive_gen, isPropositionalArity in *. - edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; congruence. - - intros. assert (Hext__ : ∥ wf_ext Σ0∥) by now eapply heΣ. - specialize_Σ H2. eapply welltyped_mkApps_inv in wv; eauto. eapply wv. - now sq. - Unshelve. all: try exact False. - - eapply PCUICWcbvEval.eval_to_value; eauto. -Qed. - -Lemma erase_correct_strong' (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) -univs wfext {t v Σ' t' deps i u args} decls normalization_in prf -(Xext := abstract_make_wf_env_ext X univs wfext) -{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} -: -forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), -forall Σ, abstract_env_ext_rel Xext Σ -> - axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> - @firstorder_ind Σ (firstorder_env Σ) i -> - erase X_type Xext [] t wt = t' -> - KernameSet.subset (term_global_deps t') deps -> - erase_global_deps X_type deps X decls normalization_in prf = Σ' -> - red Σ [] t v -> - ¬ { t' & Σ ;;; [] |- v ⇝ t'} -> - forall wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. -Proof. - intros wt Σ Hrel Hax Hty Hfo <- Hsub <- Hred Hirred wt'. - destruct (firstorder_lookup_inv Hfo) as [mind Hdecl]. - pose proof (heΣ _ _ _ Hrel) as [Hwf]. eapply wcbv_standardization_fst in Hty as Heval; eauto. - edestruct (erase_correct X_type X univs wfext t v) as [v' [H1 H2]]; eauto. - 1:{ intros ? H_. sq. enough (Σ0 = Σ) as -> by eauto. - pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ H_ Hrel). now subst. } - eapply firstorder_erases_deterministic in H1; eauto. - { rewrite H1 in H2. eapply H2. } - { eapply subject_reduction; eauto. } - { eapply PCUICWcbvEval.value_final. eapply PCUICWcbvEval.eval_to_value. eauto. } - all: eauto. - Unshelve. eauto. -Qed. - -Lemma erase_correct_strong (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) -univs wfext {t v deps i u args} decls normalization_in prf -(Xext := abstract_make_wf_env_ext X univs wfext) -{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} -: -forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), -forall Σ, abstract_env_ext_rel Xext Σ -> - axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> - let t' := erase X_type Xext [] t wt in - let Σ' := erase_global_deps X_type deps X decls normalization_in prf in - @firstorder_ind Σ (firstorder_env Σ) i -> - KernameSet.subset (term_global_deps t') deps -> - red Σ [] t v -> - ¬ { v' & Σ ;;; [] |- v ⇝ v'} -> - exists wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. -Proof. - intros wt Σ Hrel Hax Hty Hdecl Hfo Hsub Hred Hirred. - unshelve eexists. - - abstract (intros Σ_ H_; pose proof (heΣ _ _ _ H_); sq; - pose proof (abstract_env_ext_irr _ H_ Hrel); subst; eapply red_welltyped; eauto; econstructor; eauto). - - eapply erase_correct_strong'; eauto. - all: reflexivity. -Qed. - -Lemma unique_decls {X_type} {X : X_type.π1} univs wfext -(Xext := abstract_make_wf_env_ext X univs wfext) {Σ'} (wfΣ' : Σ' ∼_ext Xext) : - forall Σ, Σ ∼ X -> declarations Σ = declarations Σ'. -Proof. - intros Σ wfΣ. pose (abstract_make_wf_env_ext_correct X univs wfext Σ Σ' wfΣ wfΣ'). - rewrite e. reflexivity. -Qed. - -Lemma unique_type {X_type : abstract_env_impl} {X : X_type.π2.π1} - {Σ:global_env_ext} - (wfΣ : Σ ∼_ext X) {t T}: - Σ ;;; [] |- t : T -> forall Σ, Σ ∼_ext X -> welltyped Σ [] t. -Proof. - intros wt Σ' wfΣ'. erewrite (abstract_env_ext_irr X wfΣ' wfΣ). - now exists T. -Qed. - -Definition erase_correct_firstorder (wfl := Ee.default_wcbv_flags) - X_type (X : X_type.π1) univs wfext {t v i u args} -(Xext := abstract_make_wf_env_ext X univs wfext) -{normalization_in : forall X Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} -: -forall Σ (wfΣ : abstract_env_ext_rel Xext Σ) - (wt : Σ ;;; [] |- t : mkApps (tInd i u) args), - axiom_free Σ -> - let t' := erase X_type Xext [] t (unique_type wfΣ wt) in - let decls := declarations (fst Σ) in - let Σ' := erase_global_deps X_type (term_global_deps t') X decls - (fun _ _ _ _ _ _ _ => normalization_in _ _) (unique_decls univs wfext wfΣ) in - @firstorder_ind Σ (firstorder_env Σ) i -> - red Σ [] t v -> - ¬ { v' & Σ ;;; [] |- v ⇝ v'} -> - exists wt', ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥. -Proof. - intros. - eapply erase_correct_strong; eauto. - apply KernameSetOrdProp.P.Dec.F.subset_iff. reflexivity. -Qed. - -(* we use the [match] trick to get typeclass resolution to pick up the right instances without leaving any evidence in the resulting term, and without having to pass them manually everywhere *) -Notation NormalizationIn_erase_global_deps_fast X decls - := (match extraction_checker_flags, extraction_normalizing return _ with - | cf, no - => forall n, - n < List.length decls -> - forall kn cb pf, - List.hd_error (List.skipn n decls) = Some (kn, ConstantDecl cb) -> - let Xext := abstract_make_wf_env_ext X (cst_universes cb) pf in - forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ - end) - (only parsing). - - -Section EraseGlobalFast. - - Import PCUICEnvironment. - -Definition decls_prefix decls (Σ' : global_env) := - ∑ Σ'', declarations Σ' = Σ'' ++ decls. - -Lemma on_global_decls_prefix {cf} Pcmp P univs retro decls decls' : - PCUICAst.on_global_decls Pcmp P univs retro (decls ++ decls') -> - PCUICAst.on_global_decls Pcmp P univs retro decls'. -Proof using Type. - induction decls => //. - intros ha; depelim ha. - now apply IHdecls. -Qed. - -Lemma decls_prefix_wf {decls Σ} : - decls_prefix decls Σ -> wf Σ -> wf {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |}. -Proof using Type. - intros [Σ' hd] wfΣ. - split. apply wfΣ. - cbn. destruct wfΣ as [_ ond]. rewrite hd in ond. - now eapply on_global_decls_prefix in ond. -Qed. - -Lemma incl_cs_refl cs : cs ⊂_cs cs. -Proof using Type. - split; [lsets|csets]. -Qed. - -Lemma weaken_prefix {decls Σ kn decl} : - decls_prefix decls Σ -> - wf Σ -> - lookup_env {| universes := Σ; declarations := decls; retroknowledge := Σ.(retroknowledge) |} kn = Some decl -> - on_global_decl cumulSpec0 (lift_typing typing) (Σ, universes_decl_of_decl decl) kn decl. -Proof using Type. - intros prefix wfΣ. - have wfdecls := decls_prefix_wf prefix wfΣ. - epose proof (weakening_env_lookup_on_global_env (lift_typing typing) _ Σ kn decl - weaken_env_prop_typing wfΣ wfdecls). - forward X. apply extends_strictly_on_decls_extends, strictly_extends_decls_extends_strictly_on_decls. red; split => //. - now apply (X wfdecls). -Qed. - - -(* This version of global environment erasure keeps the same global environment throughout the whole - erasure, while folding over the list of declarations. *) - -Local Obligation Tactic := program_simpl. - -Program Fixpoint erase_global_deps_fast (deps : KernameSet.t) - X_type (X:X_type.π1) (decls : global_declarations) - {normalization_in : NormalizationIn_erase_global_deps_fast X decls} - (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations * KernameSet.t := - match decls with - | [] => ([],deps) - | (kn, ConstantDecl cb) :: decls => - if KernameSet.mem kn deps then - let Xext' := abstract_make_wf_env_ext X (cst_universes cb) _ in - let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) - let cb' := @erase_constant_body X_type Xext' normalization_in' cb _ in - let deps := KernameSet.union deps (snd cb') in - let Σ' := erase_global_deps_fast deps X_type X decls _ in - (((kn, E.ConstantDecl (fst cb')) :: Σ'.1), Σ'.2) - else - erase_global_deps_fast deps X_type X decls _ - - | (kn, InductiveDecl mib) :: decls => - if KernameSet.mem kn deps then - let mib' := erase_mutual_inductive_body mib in - let Σ' := erase_global_deps_fast deps X_type X decls _ in - (((kn, E.InductiveDecl mib') :: Σ'.1), Σ'.2) - else erase_global_deps_fast deps X_type X decls _ - end. -Next Obligation. - pose proof (abstract_env_wf _ H) as [?]. - specialize_Σ H. sq. split. cbn. apply X3. cbn. - eapply decls_prefix_wf in X3; tea. - destruct X3 as [onu ond]. cbn in ond. - depelim ond. now destruct o. -Qed. -Next Obligation. - cbv [id]. - unshelve eapply (normalization_in 0); cbn; try reflexivity; try lia. -Defined. -Next Obligation. - pose proof (abstract_env_ext_wf _ H) as [?]. - pose proof (abstract_env_exists X) as [[? wf]]. - pose proof (abstract_env_wf _ wf) as [?]. - pose proof (prop' := prop _ wf). - sq. eapply (weaken_prefix (kn := kn)) in prop'; tea. - 2:{ cbn. rewrite eqb_refl //. } - epose proof (abstract_make_wf_env_ext_correct X (cst_universes cb) _ _ _ wf H). subst. - apply prop'. -Qed. -Next Obligation. - unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Defined. -Next Obligation. - specialize_Σ H. sq; red. destruct prop as [Σ' ->]. - eexists (Σ' ++ [(kn, ConstantDecl cb)]); rewrite -app_assoc //. -Qed. -Next Obligation. - unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Defined. -Next Obligation. - specialize_Σ H. sq; red. destruct prop as [Σ' ->]. - eexists (Σ' ++ [(kn, ConstantDecl cb)]); rewrite -app_assoc //. -Qed. -Next Obligation. - unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Defined. -Next Obligation. - specialize_Σ H. sq; red. destruct prop as [Σ' ->]. - eexists (Σ' ++ [(kn, _)]); rewrite -app_assoc //. -Qed. -Next Obligation. - unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. -Defined. -Next Obligation. - specialize_Σ H. sq; red. destruct prop as [Σ' ->]. - eexists (Σ' ++ [(kn, _)]); rewrite -app_assoc //. -Qed. - -Import PCUICAst PCUICEnvironment. - -Lemma wf_lookup Σ kn d suffix g : - wf Σ -> - declarations Σ = suffix ++ (kn, d) :: g -> - lookup_env Σ kn = Some d. -Proof using Type. - unfold lookup_env. - intros [_ ond] eq. rewrite eq in ond |- *. - move: ond; clear. - induction suffix. - - cbn. rewrite eqb_refl //. - - cbn. intros ond. - depelim ond. destruct o as [f ? ? ? ]. cbn. red in f. - eapply Forall_app in f as []. depelim H0. cbn in H0. - destruct (eqb_spec kn kn0); [contradiction|]. - now apply IHsuffix. -Qed. - -Definition add_suffix suffix Σ := set_declarations Σ (suffix ++ Σ.(declarations)). - -Lemma add_suffix_cons d suffix Σ : add_suffix (d :: suffix) Σ = add_global_decl (add_suffix suffix Σ) d. -Proof using Type. reflexivity. Qed. - -Lemma global_erased_with_deps_weaken_prefix suffix Σ Σ' kn : - wf (add_suffix suffix Σ) -> - global_erased_with_deps Σ Σ' kn -> - global_erased_with_deps (add_suffix suffix Σ) Σ' kn. -Proof using Type. - induction suffix. - - unfold add_suffix; cbn. intros wf hg. - now rewrite /set_declarations /= -eta_global_env. - - rewrite add_suffix_cons. intros wf H. - destruct a as [kn' d]. eapply global_erases_with_deps_weaken => //. - apply IHsuffix => //. - destruct wf as [onu ond]. now depelim ond. -Qed. - - -(* Using weakening it is trivial to show that a term found to be erasable in Σ - will be found erasable in any well-formed extension. The converse is not so trivial: - some valid types in the extension are not valid in the restricted global context. - So, we will rather show that the erasure function is invariant under extension. *) - -Lemma isErasable_irrel_global_env {Σ Σ' : global_env_ext} {Γ t} : - wf Σ -> - wf Σ' -> - extends Σ' Σ -> - Σ.2 = Σ'.2 -> - isErasable Σ' Γ t -> isErasable Σ Γ t. -Proof using Type. - unfold isErasable. - intros wfΣ wfΣ' ext eqext [T [ht isar]]. - destruct Σ as [Σ decl], Σ' as [Σ' decl']. cbn in eqext; subst decl'. - exists T; split. - eapply (env_prop_typing weakening_env (Σ', decl)) => //=. - destruct isar as [|s]; [left|right] => //. - destruct s as [u [Hu isp]]. - exists u; split => //. - eapply (env_prop_typing weakening_env (Σ', decl)) => //=. Qed. - -Definition reduce_stack_eq {cf} {fl} {no:normalizing_flags} {X_type : abstract_env_impl} {X : X_type.π2.π1} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t π wi : reduce_stack fl X_type X Γ t π wi = ` (reduce_stack_full fl X_type X Γ t π wi). -Proof using Type. - unfold reduce_stack. destruct reduce_stack_full => //. -Qed. - -Definition same_principal_type {cf} - {X_type : abstract_env_impl} {X : X_type.π2.π1} - {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} - {Γ : context} {t} (p : PCUICSafeRetyping.principal_type X_type X Γ t) (p' : PCUICSafeRetyping.principal_type X_type' X' Γ t) := - p.π1 = p'.π1. - -(*Lemma erase_global_deps_suffix {deps} {Σ Σ' : wf_env} {decls hprefix hprefix'} : - wf Σ -> wf Σ' -> - universes Σ = universes Σ' -> - erase_global_deps_fast deps Σ decls hprefix = - erase_global_deps_fast deps Σ' decls hprefix'. -Proof using Type. - intros wfΣ wfΣ' equ. - induction decls in deps, hprefix, hprefix' |- *; cbn => //. - destruct a as [kn []]. - set (obl := (erase_global_deps_fast_obligation_1 Σ ((kn, ConstantDecl c) :: decls) - hprefix kn c decls eq_refl)). clearbody obl. - destruct obl. - set (eb := erase_constant_body _ _ _). - set (eb' := erase_constant_body _ _ _). - assert (eb = eb') as <-. - { subst eb eb'. - set (wfΣx := abstract_make_wf_env_ext _ _ _). - set (wfΣ'x := abstract_make_wf_env_ext _ _ _). - set (obl' := erase_global_deps_fast_obligation_2 _ _ _ _ _ _ _). - clearbody obl'. - set (Σd := {| universes := Σ.(universes); declarations := decls |}). - assert (wfΣd : wf Σd). - { eapply decls_prefix_wf; tea. - clear -hprefix. move: hprefix. unfold decls_prefix. - intros [Σ'' eq]. exists (Σ'' ++ [(kn, ConstantDecl c)]). - rewrite -app_assoc //. } - set (wfΣdwfe := build_wf_env_from_env _ (sq wfΣd)). - assert (wfextΣd : wf_ext (Σd, cst_universes c)). - { split => //. cbn. apply w. } - set (wfΣdw := abstract_make_wf_env_ext wfΣdwfe (cst_universes c) (sq wfextΣd)). - assert (ond' : ∥ on_constant_decl (lift_typing typing) (Σd, cst_universes c) c ∥ ). - { pose proof (decls_prefix_wf hprefix wfΣ). - destruct X as [onu ond]. depelim ond. sq. apply o0. } - assert (extd' : extends_decls Σd Σ). - { clear -hprefix. move: hprefix. - intros [? ?]. split => //. eexists (x ++ [(kn, ConstantDecl c)]). cbn. - now rewrite -app_assoc. } - assert (extd'' : extends_decls Σd Σ'). - { clear -equ hprefix'. move: hprefix'. - intros [? ?]. split => //. eexists (x ++ [(kn, ConstantDecl c)]). cbn. - now rewrite -app_assoc. } - rewrite (erase_constant_suffix (Σ := wfΣx) (Σ' := wfΣdw) (ondecl' := ond') wfΣ extd') //. - rewrite (erase_constant_body_irrel (Σ := wfΣ'x) (Σ' := wfΣdw) (ondecl' := ond') wfΣ' extd'') //. } - destruct KernameSet.mem => //. f_equal. - eapply IHdecls. - destruct KernameSet.mem => //. f_equal. - eapply IHdecls. -Qed.*) - -Lemma strictly_extends_decls_extends_global_env Σ Σ' : - wf Σ' -> - strictly_extends_decls Σ Σ' -> - extends_global_env Σ Σ'. -Proof. - intros wfΣ' [uni [Σ'' de] retr]. red. - cbn. unfold lookup_env. rewrite de /primitive_constant retr. - split => //. intros kn decl. - intros hl. - apply lookup_global_Some_iff_In_NoDup. - apply EnvMap.EnvMap.fresh_globals_iff_NoDup. - rewrite -de. now apply wf_fresh_globals. - apply lookup_global_Some_iff_In_NoDup in hl. - apply in_app_iff. now right. - apply EnvMap.EnvMap.fresh_globals_iff_NoDup. - apply wf_fresh_globals in wfΣ'. rewrite de in wfΣ'. - clear -wfΣ'. induction Σ''; auto. apply IHΣ''. - now depelim wfΣ'. -Qed. - -Lemma extends_global_env_equiv_env Σ Σ' : - extends_global_env Σ Σ' -> equiv_env_inter Σ Σ'. -Proof. - intros ext. split. intros kn decl decl' hl hl'. - destruct ext. apply H in hl. congruence. - now destruct ext. -Qed. - -Lemma erase_global_deps_fast_spec_gen {deps} - {X_type X X'} {decls normalization_in normalization_in' hprefix hprefix'} : - (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> - erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = - erase_global_deps X_type deps X' decls normalization_in' hprefix'. -Proof using Type. - intros equ. - induction decls in X, X', equ, deps, normalization_in, normalization_in', hprefix, hprefix' |- * => //. - pose proof (abstract_env_exists X) as [[Σ wfΣ]]. - pose proof (abstract_env_exists X') as [[Σ' wfΣ']]. - pose proof (abstract_env_wf _ wfΣ) as [wf]. - pose proof (abstract_env_exists (abstract_pop_decls X')) as [[? wfpop]]. - unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' wfpop) as [? [? ?]]. - { now eexists. } - - destruct a as [kn []]. - - cbn. unfold erase_constant_decl. - set (obl := (erase_global_deps_fast_obligation_1 X_type X ((kn, ConstantDecl c) :: decls) - _ hprefix kn c decls eq_refl)). - set (eb := erase_constant_body _ _ _ _). - set (eb' := erase_constant_body _ _ _ _). - set (eg := erase_global_deps _ _ _ _ _ _). - set (eg' := erase_global_deps _ _ _ _ _ _). - - assert (eb = eb') as <-. - { subst eb eb'. - destruct (hprefix _ wfΣ) as [[Σ'' eq]]. - eapply erase_constant_body_irrel; cbn => //. - eapply equiv_env_inter_hlookup. - intros ? ? H2 H3. - epose proof (abstract_make_wf_env_ext_correct X (cst_universes c) _ _ _ wfΣ H2). - epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wfpop H3). - subst. eapply equiv_env_inter_sym. - eapply extends_global_env_equiv_env. - pose proof (abstract_env_wf _ wfΣ) as []. - apply strictly_extends_decls_extends_global_env. - apply X0. red. - rewrite eq. rewrite <- H0, <- H1. split. cbn. symmetry; apply equ; eauto. - cbn. - eexists (Σ'' ++ [(kn, ConstantDecl c)]). cbn. subst. now rewrite -app_assoc. subst. - symmetry. now apply equ. } - destruct KernameSet.mem => //; f_equal; try eapply IHdecls. - f_equal. f_equal. eapply IHdecls. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - f_equal. eapply IHdecls. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - - - cbn. - destruct KernameSet.mem => //; f_equal; try eapply IHdecls. - f_equal; f_equal; eapply IHdecls. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } - intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - intros. - f_equal; eapply IHdecls. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } - intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - intros; unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } - intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. -Qed. - -Lemma erase_global_deps_fast_spec {deps} {X_type X} {decls normalization_in normalization_in' hprefix hprefix'} : - erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = - erase_global_deps X_type deps X decls normalization_in' hprefix'. -Proof using Type. - eapply erase_global_deps_fast_spec_gen; intros. - rewrite (abstract_env_irr _ H H0); eauto. -Qed. - -Lemma cored_extends (Σ Σ' : global_env_ext) Γ x y : - wf Σ' -> - extends Σ Σ' -> - cored Σ Γ x y -> cored Σ' Γ x y. -Proof. - intros wf ext. - induction 1. - - constructor. - eapply PCUICWeakeningEnvConv.weakening_env_red1. apply wf. exact ext. - exact X. - - econstructor 2; tea. - eapply PCUICWeakeningEnvConv.weakening_env_red1. apply wf. - exact ext. - exact X. -Qed. - -Lemma normalization_in_extends (Σ Σ' : global_env) ext : - wf Σ -> wf Σ' -> - extends Σ' Σ -> - NormalizationIn (Σ, ext) -> NormalizationIn (Σ', ext). -Proof. - intros wfΣ wfΣ' extH nin. - red in nin. intros Γ t wt. - assert (welltyped (Σ, ext) Γ t). - { destruct wt. exists A. eapply (env_prop_typing weakening_env) in X; tea; cbn. } - specialize (nin _ _ H). clear H. - induction nin. - constructor. intros y r. - eapply H0. eapply cored_extends in r; tea. - eapply cored_welltyped; tea. -Qed. - -Lemma iter_abstract_pop_decls_correct {cf} {abstract_env_impl abstract_env_ext_impl : Type} - {abstract_env_struct0 : abstract_env_struct abstract_env_impl - abstract_env_ext_impl} : - abstract_env_prop abstract_env_impl abstract_env_ext_impl -> - forall (X : abstract_env_impl) (decls : list (kername × global_decl)) n, - (forall Σ : global_env, - Σ ∼ X -> exists decls', #|decls'| = n /\ declarations Σ = decls' ++ decls) -> - let X' := iter abstract_pop_decls n X in - forall Σ Σ' : global_env, - Σ ∼ X -> - Σ' ∼ X' -> - declarations Σ' = decls /\ universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ'. -Proof. - intros ap X decls. - induction n in X, decls |- *. cbn. - - intros hdecl Σ Σ' HX HX'. - specialize (hdecl _ HX) as [decls' [hlen hde]]. - destruct decls' => //. cbn in hde. - now rewrite -hde (abstract_env_irr _ HX HX'). - - intros hdecl X' Σ Σ' HX HX'. - specialize (hdecl _ HX) as [decls' [hlen hde]]. - destruct decls' => //; cbn in hde. - specialize (IHn (abstract_pop_decls X) decls). - pose proof (abstract_pop_decls_correct X (decls' ++ decls)). - forward H. - { intros ? h. rewrite -(abstract_env_irr _ HX h). now exists p. } - forward IHn. - { intros ? H0. now specialize (H _ _ HX H0). } - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop hpop]]. - specialize (IHn _ _ hpop HX'). - destruct IHn. split => //. - pose proof (abstract_pop_decls_correct X (decls' ++ decls)). - forward H2. - { intros ? hx. pose proof (abstract_env_irr _ hx HX). subst Σ0. now exists p. } - specialize (H2 _ _ HX hpop). destruct H2 as [? []]. - destruct H1. - split; congruence. -Qed. - -Lemma skipn_app_prefix {A} n (l l' : list A) : skipn (#|l| + n) (l ++ l') = skipn n l'. -Proof. - induction l; cbn; auto. -Qed. - -Lemma erase_global_deps_fast_erase_global_deps {deps} {X_type X} {decls normalization_in hprefix hprefix'} : - exists normalization_in', - erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = - erase_global_deps X_type deps X decls normalization_in' hprefix'. -Proof using Type. - unshelve eexists. - intros. - pose proof (abstract_env_exists X) as [[Σ' H']]. - pose proof (abstract_env_wf _ H') as []. - specialize (hprefix _ H') as [[Σ'' ?]]. - pose proof (abstract_env_exists (iter abstract_pop_decls (S n) X)) as [[? ?]]. - pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ a H1). noconf H2. - epose proof (iter_abstract_pop_decls_correct _ X (skipn (S n) (Σ'' ++ decls)) (S n)). - forward H2. { intros ? h. rewrite (abstract_env_irr _ h H'). exists (firstn (S n) (Σ'' ++ decls)). - rewrite firstn_skipn. split => //. rewrite firstn_length_le //. rewrite app_length. lia. } - specialize (H2 _ _ H' a) as [? []]. - eapply normalization_in_extends. exact X1. exact X0. - { eapply extends_decls_extends, strictly_extends_decls_extends_decls. - red. rewrite H2 H3 H4. split => //. exists (firstn (S n) (Σ'' ++ decls)). - now rewrite firstn_skipn. } - specialize (normalization_in n H kn cb). - assert (wf_ext (Σ', cst_universes cb)). - { split => //. cbn. rewrite H3. apply X0. } - assert (forall Σ : global_env, Σ ∼ X -> ∥ wf_ext (Σ, cst_universes cb) ∥). - { intros. pose proof (abstract_env_irr _ H' H5). now subst Σ'. } - unshelve eapply normalization_in; tea. - set (foo := abstract_make_wf_env_ext X (cst_universes cb) H5). - pose proof (abstract_env_ext_exists foo) as [[Σext hext]]. - epose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ H' hext). now subst Σext. - erewrite erase_global_deps_fast_spec; tea. reflexivity. -Qed. - -Definition erase_global_fast X_type deps X decls {normalization_in} (prf:forall Σ : global_env, abstract_env_rel X Σ -> declarations Σ = decls) := - erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) (fun _ H => sq ([] ; prf _ H)). - -Lemma expanded_erase_global_fast (cf := config.extraction_checker_flags) deps - {X_type X decls normalization_in} {normalization_in':NormalizationIn_erase_global_deps X decls} {prf} : - forall Σ : global_env, abstract_env_rel X Σ -> - PCUICEtaExpand.expanded_global_env Σ -> - expanded_global_env (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. -Proof using Type. - unfold erase_global_fast. - erewrite erase_global_deps_fast_spec. - eapply expanded_erase_global. - Unshelve. all: eauto. -Qed. - -Lemma expanded_erase_fast (cf := config.extraction_checker_flags) - {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_deps X decls} univs wfΣ t wtp : - forall Σ : global_env, abstract_env_rel X Σ -> - PCUICEtaExpand.expanded Σ [] t -> - let X' := abstract_make_wf_env_ext X univs wfΣ in - forall (normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ), - let et := (erase X_type X' [] t wtp) in - let deps := EAstUtils.term_global_deps et in - expanded (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1 [] et. -Proof using Type. - intros Σ wf hexp X' normalization_in'. pose proof (abstract_env_wf _ wf) as [?]. - eapply (expanded_erases (Σ := (Σ, univs))); tea. - eapply (erases_erase (X := X')). - pose proof (abstract_env_ext_exists X') as [[? wfmake]]. - now rewrite <- (abstract_make_wf_env_ext_correct X univs _ _ _ wf wfmake). - cbn. unfold erase_global_fast. erewrite erase_global_deps_fast_spec => //. - eapply (erases_deps_erase (X := X) univs wfΣ); eauto. - Unshelve. all: eauto. -Qed. - -Lemma erase_global_fast_wf_glob X_type deps X decls normalization_in (normalization_in':NormalizationIn_erase_global_deps X decls) prf : - @wf_glob all_env_flags (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. -Proof using Type. - unfold erase_global_fast; erewrite erase_global_deps_fast_spec. - eapply erase_global_deps_wf_glob. - Unshelve. all: eauto. -Qed. - -Lemma erase_wellformed_fast (efl := all_env_flags) - {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_deps X decls} univs wfΣ {Γ t} wt - (X' := abstract_make_wf_env_ext X univs wfΣ) - {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} : - let t' := erase X_type X' Γ t wt in - wellformed (erase_global_fast X_type (term_global_deps t') X decls (normalization_in:=normalization_in) prf).1 #|Γ| t'. -Proof using Type. - intros. - cbn. unfold erase_global_fast. erewrite erase_global_deps_fast_spec. - eapply erase_wellformed_deps. - Unshelve. all: eauto. -Qed. - -End EraseGlobalFast. - -Fixpoint compile_value_erase (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := - match t with - | PCUICAst.tApp f a => compile_value_erase f (compile_value_erase a [] :: acc) - | PCUICAst.tConstruct i n _ => EAst.mkApps (EAst.tConstruct i n []) acc - | _ => EAst.tVar "error" - end. - -Lemma compile_value_erase_mkApps i n ui args acc : - compile_value_erase (mkApps (tConstruct i n ui) args) acc = - EAst.mkApps (EAst.tConstruct i n []) (map (flip compile_value_erase []) args ++ acc). -Proof. - revert acc; induction args using rev_ind. - - cbn. auto. - - intros acc. rewrite PCUICAstUtils.mkApps_app /=. cbn. - now rewrite IHargs map_app /= -app_assoc /=. -Qed. - -Lemma erases_firstorder Σ Γ t : - PCUICFirstorder.firstorder_value Σ Γ t -> - erases Σ Γ t (compile_value_erase t []). -Proof. - move: t. - apply: (PCUICFirstorder.firstorder_value_inds Σ Γ). - intros i n ui u args pandi hty hfo ih isp. - assert (Forall2 (erases Σ Γ) args (map (flip compile_value_erase []) args)). - { solve_all. eapply All_All2; tea. - cbn. intros x [fo hx]. exact hx. } - unshelve epose proof (erases_mkApps Σ Γ (tConstruct i n ui) (EAst.tConstruct i n []) args _ _ H). - constructor. - { move: isp. rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. - destruct PCUICEnvironment.lookup_env => //. - destruct g => //. destruct nth_error => //. } - now rewrite compile_value_erase_mkApps app_nil_r. -Qed. - -Lemma erases_firstorder' Σ Γ t : - wf_ext Σ -> - PCUICFirstorder.firstorder_value Σ Γ t -> - forall t', erases Σ Γ t t' -> t' = (compile_value_erase t []). -Proof. - intros wf. move: t. - apply: (PCUICFirstorder.firstorder_value_inds Σ Γ). - intros i n ui u args pandi hty hfo ih isp. - assert (Forall2 (erases Σ Γ) args (map (flip compile_value_erase []) args)). - { solve_all. eapply All_All2; tea. - cbn. intros x [fo hx]. now eapply erases_firstorder. } - unshelve epose proof (erases_mkApps Σ Γ (tConstruct i n ui) (EAst.tConstruct i n []) args _ _ H). - constructor. - { move: isp. rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. - destruct PCUICEnvironment.lookup_env => //. - destruct g => //. destruct nth_error => //. } - rewrite compile_value_erase_mkApps app_nil_r. - intros t' ht'. - eapply erases_mkApps_inv in ht'. - destruct ht'. - { destruct H1 as [? [? [? [? [[] ?]]]]]. - eapply isErasable_Propositional in X => //. - clear -isp X. elimtype False. - move: isp X. - rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. - destruct PCUICEnvironment.lookup_env => //. - destruct g => //. destruct nth_error => //. - rewrite /isPropositionalArity. destruct destArity => //. - destruct p. intros ->. auto. } - destruct H1 as [f' [L' [-> [erc erargs]]]]. - depelim erc. f_equal. - solve_all. clear -erargs. - induction erargs => //. rewrite IHerargs. cbn. f_equal. - destruct r as [[] ?]. eapply e in e0. now unfold flip. - eapply (isErasable_Propositional (args := [])) in X => //. - clear -isp X. elimtype False. - move: isp X. - rewrite /isPropositional /Extract.isPropositional /PCUICAst.lookup_inductive /= /lookup_inductive_gen /lookup_minductive_gen. - destruct PCUICEnvironment.lookup_env => //. - destruct g => //. destruct nth_error => //. - rewrite /isPropositionalArity. destruct destArity => //. - destruct p. intros ->. auto. -Qed. \ No newline at end of file diff --git a/erasure/theories/ErasureFunctionProperties.v b/erasure/theories/ErasureFunctionProperties.v new file mode 100644 index 000000000..b1c0a710e --- /dev/null +++ b/erasure/theories/ErasureFunctionProperties.v @@ -0,0 +1,2877 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Program ssreflect ssrbool. +From Equations Require Import Equations. +Set Equations Transparent. +From MetaCoq.Utils Require Import utils. +From MetaCoq.Common Require Import config Kernames uGraph. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive + PCUICReduction PCUICReflect PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICCasesContexts + PCUICWeakeningConv PCUICWeakeningTyp PCUICContextConversionTyp PCUICTyping PCUICGlobalEnv PCUICInversion PCUICGeneration + PCUICConfluence PCUICConversion PCUICUnivSubstitutionTyp PCUICCumulativity PCUICSR PCUICSafeLemmata PCUICNormalization + PCUICValidity PCUICPrincipality PCUICElimination PCUICOnFreeVars PCUICWellScopedCumulativity PCUICSN PCUICEtaExpand. + +From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICSafeReduce PCUICSafeRetyping PCUICRetypingEnvIrrelevance. +From MetaCoq.Erasure Require Import EAstUtils EArities Extract Prelim EDeps ErasureProperties ErasureCorrectness ErasureFunction. + +Local Open Scope string_scope. +Set Asymmetric Patterns. +Local Set Keyed Unification. +Set Default Proof Using "Type*". +Import MCMonadNotation. + +Implicit Types (cf : checker_flags). + +#[local] Existing Instance extraction_normalizing. +#[local] Existing Instance extraction_checker_flags. + +Notation alpha_eq := (All2 (PCUICEquality.compare_decls eq eq)). + +Definition global_erased_with_deps (Σ : global_env) (Σ' : EAst.global_declarations) kn := + (exists cst, declared_constant Σ kn cst /\ + exists cst' : EAst.constant_body, + EGlobalEnv.declared_constant Σ' kn cst' /\ + erases_constant_body (Σ, cst_universes cst) cst cst' /\ + (forall body : EAst.term, + EAst.cst_body cst' = Some body -> erases_deps Σ Σ' body)) \/ + (exists mib mib', declared_minductive Σ kn mib /\ + EGlobalEnv.declared_minductive Σ' kn mib' /\ + erases_mutual_inductive_body mib mib'). + +Definition includes_deps (Σ : global_env) (Σ' : EAst.global_declarations) deps := + forall kn, + KernameSet.In kn deps -> + global_erased_with_deps Σ Σ' kn. + +Lemma includes_deps_union (Σ : global_env) (Σ' : EAst.global_declarations) deps deps' : + includes_deps Σ Σ' (KernameSet.union deps deps') -> + includes_deps Σ Σ' deps /\ includes_deps Σ Σ' deps'. +Proof. + intros. + split; intros kn knin; eapply H; rewrite KernameSet.union_spec; eauto. +Qed. + +Lemma includes_deps_fold {A} (Σ : global_env) (Σ' : EAst.global_declarations) brs deps (f : A -> EAst.term) : + includes_deps Σ Σ' + (fold_left + (fun (acc : KernameSet.t) (x : A) => + KernameSet.union (term_global_deps (f x)) acc) brs + deps) -> + includes_deps Σ Σ' deps /\ + (forall x, In x brs -> + includes_deps Σ Σ' (term_global_deps (f x))). +Proof. + intros incl; split. + intros kn knin; apply incl. + rewrite knset_in_fold_left. left; auto. + intros br brin. intros kn knin. apply incl. + rewrite knset_in_fold_left. right. + now exists br. +Qed. + +Definition declared_kn Σ kn := + ∥ ∑ decl, lookup_env Σ kn = Some decl ∥. + +Lemma term_global_deps_spec {cf} {Σ : global_env_ext} {Γ t et T} : + wf Σ.1 -> + Σ ;;; Γ |- t : T -> + Σ;;; Γ |- t ⇝ℇ et -> + forall x, KernameSet.In x (term_global_deps et) -> declared_kn Σ x. +Proof. + intros wf wt er. + induction er in T, wt |- * using erases_forall_list_ind; + cbn in *; try solve [constructor]; intros kn' hin; + repeat match goal with + | [ H : KernameSet.In _ KernameSet.empty |- _ ] => + now apply KernameSet.empty_spec in hin + | [ H : KernameSet.In _ (KernameSet.union _ _) |- _ ] => + apply KernameSet.union_spec in hin as [?|?] + end. + - apply inversion_Lambda in wt as (? & ? & ? & ? & ?); eauto. + - apply inversion_LetIn in wt as (? & ? & ? & ? & ? & ?); eauto. + - apply inversion_LetIn in wt as (? & ? & ? & ? & ? & ?); eauto. + - apply inversion_App in wt as (? & ? & ? & ? & ? & ?); eauto. + - apply inversion_App in wt as (? & ? & ? & ? & ? & ?); eauto. + - apply inversion_Const in wt as (? & ? & ? & ? & ?); eauto. + eapply KernameSet.singleton_spec in hin; subst. + unshelve eapply declared_constant_to_gen in d; eauto. + red in d. red. sq. rewrite d. intuition eauto. + - apply inversion_Construct in wt as (? & ? & ? & ? & ? & ? & ?); eauto. + destruct kn. + eapply KernameSet.singleton_spec in hin; subst. + destruct d as [[H' _] _]. + unshelve eapply declared_minductive_to_gen in H'; eauto. + red in H'. simpl in *. + red. sq. rewrite H'. intuition eauto. + - apply inversion_Case in wt as (? & ? & ? & ? & [] & ?); eauto. + destruct ci as [kn i']; simpl in *. + eapply KernameSet.singleton_spec in H1; subst. + destruct x1 as [d _]. + unshelve eapply declared_minductive_to_gen in d; eauto. + red in d. + simpl in *. eexists; intuition eauto. + - apply inversion_Case in wt as (? & ? & ? & ? & [] & ?); eauto. + eapply knset_in_fold_left in H1. + destruct H1. eapply IHer; eauto. + destruct H1 as [br [inbr inkn]]. + eapply Forall2_All2 in H0. + assert (All (fun br => ∑ T, Σ ;;; Γ ,,, inst_case_branch_context p br |- br.(bbody) : T) brs). + eapply All2i_All_right. eapply brs_ty. + simpl. intuition auto. eexists ; eauto. + now rewrite -(PCUICCasesContexts.inst_case_branch_context_eq a). + eapply All2_All_mix_left in H0; eauto. simpl in H0. + eapply All2_In_right in H0; eauto. + destruct H0. + destruct X1 as [br' [[T' HT] ?]]. + eauto. + + - eapply KernameSet.singleton_spec in H0; subst. + apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?&?); eauto. + unshelve eapply declared_projection_to_gen in d; eauto. + destruct d as [[[d _] _] _]. + red in d. eexists; eauto. + + - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?); eauto. + + - apply inversion_Fix in wt as (?&?&?&?&?&?&?); eauto. + eapply knset_in_fold_left in hin as [|]. + now eapply KernameSet.empty_spec in H0. + destruct H0 as [? [ina indeps]]. + eapply Forall2_All2 in H. + eapply All2_All_mix_left in H; eauto. + eapply All2_In_right in H; eauto. + destruct H as [[def [Hty Hdef]]]. + eapply Hdef; eauto. + + - apply inversion_CoFix in wt as (?&?&?&?&?&?&?); eauto. + eapply knset_in_fold_left in hin as [|]. + now eapply KernameSet.empty_spec in H0. + destruct H0 as [? [ina indeps]]. + eapply Forall2_All2 in H. + eapply All2_All_mix_left in H; eauto. + eapply All2_In_right in H; eauto. + destruct H as [[def [Hty Hdef]]]. + eapply Hdef; eauto. +Qed. + +Global Remove Hints erases_deps_eval : core. + +Lemma erase_global_erases_deps {Σ} {Σ' : EAst.global_declarations} {Γ t et T} : + wf_ext Σ -> + Σ;;; Γ |- t : T -> + Σ;;; Γ |- t ⇝ℇ et -> + includes_deps Σ Σ' (term_global_deps et) -> + erases_deps Σ Σ' et. +Proof. + intros wf wt er. + induction er in er, t, T, wf, wt |- * using erases_forall_list_ind; + cbn in *; try solve [constructor]; intros Σer; + repeat match goal with + | [ H : includes_deps _ _ (KernameSet.union _ _ ) |- _ ] => + apply includes_deps_union in H as [? ?] + end. + - now apply inversion_Evar in wt. + - constructor. + now apply inversion_Lambda in wt as (? & ? & ? & ? & ?); eauto. + - apply inversion_LetIn in wt as (? & ? & ? & ? & ? & ?); eauto. + constructor; eauto. + - apply inversion_App in wt as (? & ? & ? & ? & ? & ?); eauto. + now constructor; eauto. + - apply inversion_Const in wt as (? & ? & ? & ? & ?); eauto. + specialize (Σer kn). + forward Σer. rewrite KernameSet.singleton_spec //. + pose proof (wf' := wf.1). + unshelve eapply declared_constant_to_gen in d; eauto. + destruct Σer as [[c' [declc' (? & ? & ? & ?)]]|]. + unshelve eapply declared_constant_to_gen in declc'; eauto. + pose proof (declared_constant_inj _ _ d declc'). subst x. + econstructor; eauto. eapply declared_constant_from_gen; eauto. + destruct H as [mib [mib' [declm declm']]]. + unshelve eapply declared_minductive_to_gen in declm; eauto. + red in declm, d. unfold declared_minductive_gen in declm. + rewrite d in declm. noconf declm. + - apply inversion_Construct in wt as (? & ? & ? & ? & ? & ?); eauto. + red in Σer. destruct kn. + setoid_rewrite KernameSetFact.singleton_iff in Σer. + pose (wf' := wf.1). + destruct (Σer _ eq_refl) as [ (? & ? & ? & ? & ? & ?) | (? & ? & ? & ? & ?) ]. + + destruct d as [[]]. + unshelve eapply declared_constant_to_gen in H0; eauto. + unshelve eapply declared_minductive_to_gen in H4; eauto. + red in H4, H. cbn in *. unfold PCUICEnvironment.fst_ctx in *. congruence. + + pose proof H2 as H2'. destruct d. cbn in *. + destruct H3. cbn in *. red in H3. + unshelve eapply declared_minductive_to_gen in H0, H3; eauto. + red in H0, H3. rewrite H0 in H3. invs H3. + destruct H2. + red in H1. + eapply Forall2_nth_error_Some_l in H2 as (? & ? & ?); eauto. pose proof H6 as H6'. destruct H6 as (? & ? & ? & ? & ?); eauto. + eapply Forall2_nth_error_Some_l in H6 as ([] & ? & ? & ?); subst; eauto. + econstructor. + eapply declared_constructor_from_gen; eauto. repeat eapply conj; eauto. + repeat eapply conj; cbn; eauto. eauto. eauto. + - apply inversion_Case in wt as (? & ? & ? & ? & [] & ?); eauto. + destruct ci as [[kn i'] ? ?]; simpl in *. + apply includes_deps_fold in H2 as [? ?]. + pose proof (wf' := wf.1). + specialize (H1 kn). forward H1. + now rewrite KernameSet.singleton_spec. red in H1. destruct H1. + elimtype False. destruct H1 as [cst [declc _]]. + { destruct x1 as [d _]. + unshelve eapply declared_minductive_to_gen in d; eauto. + unshelve eapply declared_constant_to_gen in declc; eauto. + red in d, declc. + unfold declared_constant_gen in declc. rewrite d in declc. noconf declc. } + destruct H1 as [mib [mib' [declm [declm' em]]]]. + pose proof em as em'. destruct em'. + destruct x1 as [x1 hnth]. + unshelve eapply declared_minductive_to_gen in x1, declm; eauto. + red in x1, declm. unfold declared_minductive_gen in declm. rewrite x1 in declm. noconf declm. + eapply Forall2_nth_error_left in H1; eauto. destruct H1 as [? [? ?]]. + eapply erases_deps_tCase; eauto. + apply declared_inductive_from_gen; auto. + split; eauto. split; eauto. + destruct H1. + eapply In_Forall in H3. + eapply All_Forall. eapply Forall_All in H3. + eapply Forall2_All2 in H0. + eapply All2_All_mix_right in H0; eauto. + assert (All (fun br => ∑ T, Σ ;;; Γ ,,, inst_case_branch_context p br |- br.(bbody) : T) brs). + eapply All2i_All_right. eapply brs_ty. + simpl. intuition auto. eexists ; eauto. + now rewrite -(PCUICCasesContexts.inst_case_branch_context_eq a). + ELiftSubst.solve_all. destruct a0 as [T' HT]. eauto. + + - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?&?); eauto. + destruct (proj1 d). + pose proof (wf' := wf.1). + specialize (H0 (inductive_mind p.(proj_ind))). forward H0. + now rewrite KernameSet.singleton_spec. red in H0. destruct H0. + elimtype False. destruct H0 as [cst [declc _]]. + { + unshelve eapply declared_constant_to_gen in declc; eauto. + red in declc. destruct d as [[[d _] _] _]. + unshelve eapply declared_minductive_to_gen in d; eauto. + red in d. + unfold declared_constant_gen in declc. rewrite d in declc. noconf declc. } + destruct H0 as [mib [mib' [declm [declm' em]]]]. + assert (mib = x0). + { destruct d as [[[]]]. + unshelve eapply declared_minductive_to_gen in declm, H0; eauto. + red in H0, declm. unfold declared_minductive_gen in declm. rewrite H0 in declm. now noconf declm. } + subst x0. + pose proof em as em'. destruct em'. + eapply Forall2_nth_error_left in H0 as (x' & ? & ?); eauto. + 2:{ apply d. } + simpl in *. + destruct (ind_ctors x1) => //. noconf H3. + set (H1' := H5). destruct H1' as []. + set (d' := d). destruct d' as [[[]]]. + eapply Forall2_All2 in H3. eapply All2_nth_error_Some in H3 as [? [? []]]; tea. + destruct H6 as [Hprojs _]. + eapply Forall2_All2 in Hprojs. eapply All2_nth_error_Some in Hprojs as [? []]; tea. + 2:eapply d. + econstructor; tea. all:eauto. + split => //. 2:split; eauto. + split; eauto. split; eauto. + rewrite -H4. symmetry; apply d. + + - constructor. + apply inversion_Fix in wt as (?&?&?&?&?&?&?); eauto. + eapply All_Forall. eapply includes_deps_fold in Σer as [_ Σer]. + eapply In_Forall in Σer. + eapply Forall_All in Σer. + eapply Forall2_All2 in H. + ELiftSubst.solve_all. + - constructor. + apply inversion_CoFix in wt as (?&?&?&?&?&?&?); eauto. + eapply All_Forall. eapply includes_deps_fold in Σer as [_ Σer]. + eapply In_Forall in Σer. + eapply Forall_All in Σer. + eapply Forall2_All2 in H. + ELiftSubst.solve_all. Unshelve. +Qed. + +Lemma erases_deps_weaken kn d (Σ : global_env) (Σ' : EAst.global_declarations) t : + wf (add_global_decl Σ (kn, d)) -> + erases_deps Σ Σ' t -> + erases_deps (add_global_decl Σ (kn, d)) Σ' t. +Proof. + intros wfΣ er. + assert (wfΣ' : wf Σ) + by now eapply strictly_extends_decls_wf; tea; split => //; eexists [_]. + induction er using erases_deps_forall_ind; try solve [now constructor]. + - inv wfΣ. inv X. + assert (wf Σ) by (inversion H4;econstructor; eauto). + pose proof (H_ := H). unshelve eapply declared_constant_to_gen in H; eauto. + assert (kn <> kn0). + { intros <-. + eapply lookup_env_Some_fresh in H. destruct X1. contradiction. } + eapply erases_deps_tConst with cb cb'; eauto. + eapply declared_constant_from_gen. + red. rewrite /declared_constant_gen /lookup_env lookup_env_cons_fresh //. + red. + red in H1. + destruct (cst_body cb) eqn:cbe; + destruct (E.cst_body cb') eqn:cbe'; auto. + specialize (H3 _ eq_refl). + eapply on_declared_constant in H_; auto. + red in H_. rewrite cbe in H_. simpl in H_. + eapply (erases_weakening_env (Σ := (Σ, cst_universes cb)) + (Σ' := (add_global_decl Σ (kn, d), cst_universes cb))); eauto. + simpl. econstructor; eauto. econstructor; eauto. + split => //; eexists [(kn, d)]; intuition eauto. + - econstructor; eauto. eapply weakening_env_declared_constructor; eauto; tc. + eapply extends_decls_extends, strictly_extends_decls_extends_decls. econstructor; try reflexivity. eexists [(_, _)]; reflexivity. + - econstructor; eauto. + eapply declared_inductive_from_gen. + inv wfΣ. inv X. + assert (wf Σ) by (inversion H5;econstructor; eauto). + unshelve eapply declared_inductive_to_gen in H; eauto. + red. destruct H. split; eauto. + red in H. red. + rewrite -H. simpl. unfold lookup_env; simpl. destruct (eqb_spec (inductive_mind p.1) kn); try congruence. + eapply lookup_env_Some_fresh in H. destruct X1. subst kn; contradiction. + - econstructor; eauto. + inv wfΣ. inv X. + assert (wf Σ) by (inversion H3;econstructor; eauto). + eapply declared_projection_from_gen. + unshelve eapply declared_projection_to_gen in H; eauto. + red. destruct H. split; eauto. + destruct H; split; eauto. + destruct H; split; eauto. + red in H |- *. + rewrite -H. simpl. unfold lookup_env; simpl; destruct (eqb_spec (inductive_mind p.(proj_ind)) kn); try congruence. + eapply lookup_env_Some_fresh in H. subst kn. destruct X1. contradiction. +Qed. + +Lemma lookup_env_ext {Σ kn kn' d d'} : + wf (add_global_decl Σ (kn', d')) -> + lookup_env Σ kn = Some d -> + kn <> kn'. +Proof. + intros wf hl. + eapply lookup_env_Some_fresh in hl. + inv wf. inv X. + destruct (eqb_spec kn kn'); subst; destruct X1; congruence. +Qed. + +Lemma lookup_env_cons_disc {Σ kn kn' d} : + kn <> kn' -> + lookup_env (add_global_decl Σ (kn', d)) kn = lookup_env Σ kn. +Proof. + intros Hk. simpl; unfold lookup_env; simpl. + destruct (eqb_spec kn kn'); congruence. +Qed. + +Lemma elookup_env_cons_disc {Σ kn kn' d} : + kn <> kn' -> + EGlobalEnv.lookup_env ((kn', d) :: Σ) kn = EGlobalEnv.lookup_env Σ kn. +Proof. + intros Hk. simpl. + destruct (eqb_spec kn kn'); congruence. +Qed. + +Lemma global_erases_with_deps_cons kn kn' d d' Σ Σ' : + wf (add_global_decl Σ (kn', d)) -> + global_erased_with_deps Σ Σ' kn -> + global_erased_with_deps (add_global_decl Σ (kn', d)) ((kn', d') :: Σ') kn. +Proof. + intros wf [[cst [declc [cst' [declc' [ebody IH]]]]]|]. + red. inv wf. inv X. + assert (wfΣ : PCUICTyping.wf Σ). + { eapply strictly_extends_decls_wf; split; tea ; eauto. econstructor; eauto. + now eexists [_]. + } + left. + exists cst. split. + eapply declared_constant_from_gen. + unshelve eapply declared_constant_to_gen in declc; eauto. + red in declc |- *. unfold declared_constant_gen, lookup_env in *. + rewrite lookup_env_cons_fresh //. + { eapply lookup_env_Some_fresh in declc. destruct X1. + intros <-; contradiction. } + exists cst'. + pose proof (declc_ := declc). + unshelve eapply declared_constant_to_gen in declc; eauto. + unfold EGlobalEnv.declared_constant. rewrite EGlobalEnv.elookup_env_cons_fresh //. + { eapply lookup_env_Some_fresh in declc. destruct X1. + intros <-; contradiction. } + red in ebody. unfold erases_constant_body. + destruct (cst_body cst) eqn:bod; destruct (E.cst_body cst') eqn:bod' => //. + intuition auto. + eapply (erases_weakening_env (Σ := (_, cst_universes cst)) (Σ' := (add_global_decl Σ (kn', d), cst_universes cst))); eauto. + constructor; eauto. constructor; eauto. + split => //. exists [(kn', d)]; intuition eauto. + eapply on_declared_constant in declc_; auto. + red in declc_. rewrite bod in declc_. eapply declc_. + noconf H0. + eapply erases_deps_cons; eauto. + constructor; auto. + + right. + pose proof (wf_ := wf). inv wf. inv X. + assert (wf Σ) by (inversion H0;econstructor; eauto). + destruct H as [mib [mib' [? [? ?]]]]. + unshelve eapply declared_minductive_to_gen in H; eauto. + exists mib, mib'. intuition eauto. + * eapply declared_minductive_from_gen. + red. red in H. pose proof (lookup_env_ext wf_ H). unfold declared_minductive_gen. + now rewrite lookup_env_cons_disc. + * red. pose proof (lookup_env_ext wf_ H). + now rewrite elookup_env_cons_disc. +Qed. + +Lemma global_erases_with_deps_weaken kn kn' d Σ Σ' : + wf (add_global_decl Σ (kn', d)) -> + global_erased_with_deps Σ Σ' kn -> + global_erased_with_deps (add_global_decl Σ (kn', d)) Σ' kn. +Proof. + intros wf [[cst [declc [cst' [declc' [ebody IH]]]]]|]. + red. inv wf. inv X. left. + assert (wfΣ : PCUICTyping.wf Σ). + { eapply strictly_extends_decls_wf; split; tea ; eauto. econstructor; eauto. + now eexists [_]. + } + exists cst. split. + eapply declared_constant_from_gen. + unshelve eapply declared_constant_to_gen in declc; eauto. + red in declc |- *. + unfold declared_constant_gen, lookup_env in *. + rewrite lookup_env_cons_fresh //. + { eapply lookup_env_Some_fresh in declc. + intros <-. destruct X1. contradiction. } + exists cst'. + unfold EGlobalEnv.declared_constant. + red in ebody. unfold erases_constant_body. + destruct (cst_body cst) eqn:bod; destruct (E.cst_body cst') eqn:bod' => //. + intuition auto. + eapply (erases_weakening_env (Σ := (Σ, cst_universes cst)) (Σ' := (add_global_decl Σ (kn', d), cst_universes cst))). 5:eauto. + split; auto. constructor; eauto. constructor; eauto. + split; auto; exists [(kn', d)]; intuition eauto. + eapply on_declared_constant in declc; auto. + red in declc. rewrite bod in declc. eapply declc. + noconf H0. + apply erases_deps_weaken; auto. + constructor; eauto. constructor; eauto. + + right. destruct H as [mib [mib' [Hm [? ?]]]]. + exists mib, mib'; intuition auto. pose proof (wf_ := wf). + inv wf. inv X. + assert (wf Σ) by (inversion H;econstructor; eauto). + eapply declared_minductive_from_gen. + + unshelve eapply declared_minductive_to_gen in Hm; eauto. + red. unfold declared_minductive_gen, lookup_env in *. + rewrite lookup_env_cons_fresh //. + now epose proof (lookup_env_ext wf_ Hm). +Qed. + +Lemma erase_global_includes X_type (X:X_type.π1) deps decls {normalization_in} prf deps' : + (forall d, KernameSet.In d deps' -> + forall Σ : global_env, abstract_env_rel X Σ -> ∥ ∑ decl, lookup_env Σ d = Some decl ∥) -> + KernameSet.subset deps' deps -> + forall Σ : global_env, abstract_env_rel X Σ -> + let Σ' := erase_global_deps deps X decls (normalization_in:=normalization_in) prf in + includes_deps Σ (fst Σ') deps'. +Proof. + intros ? sub Σ wfΣ; cbn. induction decls in X, H, sub, prf, deps, deps', Σ , wfΣ, normalization_in |- *. + - simpl. intros i hin. elimtype False. + specialize (H i hin) as [[decl Hdecl]]; eauto. + rewrite /lookup_env (prf _ wfΣ) in Hdecl. noconf Hdecl. + - intros i hin. + destruct (abstract_env_wf _ wfΣ) as [wf]. + destruct a as [kn d]. + eapply KernameSet.subset_spec in sub. + edestruct (H i hin) as [[decl Hdecl]]; eauto. unfold lookup_env in Hdecl. + pose proof (eqb_spec i kn). + rewrite (prf _ wfΣ) in Hdecl. move: Hdecl. cbn -[erase_global_deps]. + elim: H0. intros -> [= <-]. + * destruct d as [|]; [left|right]. + { cbn. set (Xpop := abstract_pop_decls X). + unfold erase_constant_decl. + set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). + epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]. + epose proof (abstract_env_ext_exists Xmake) as [[Σmake wfmake]]. + exists c. split; auto. + eapply declared_constant_from_gen. + unfold declared_constant_gen, lookup_env; simpl; rewrite (prf _ wfΣ). cbn. + rewrite eq_kername_refl //. + pose proof (sub _ hin) as indeps. + eapply KernameSet.mem_spec in indeps. + unfold EGlobalEnv.declared_constant. + edestruct (H _ hin) as [[decl hd]]; eauto. + eexists; intuition eauto. + rewrite indeps. cbn. + rewrite eq_kername_refl. reflexivity. + cut (strictly_extends_decls Σpop Σ) => [?|]. + eapply (erase_constant_body_correct _ _ _ _ (Σpop , _)); eauto. + rewrite <- (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake); eauto. + { now eapply strictly_extends_decls_wf. } + red. simpl. unshelve epose (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop). + { intros. now eexists. } + split => //. intuition eauto. + exists [(kn, ConstantDecl c)]; intuition eauto. rewrite H0; eauto. + now destruct a. + rewrite indeps. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. + { intros. now eexists. } + pose (prf' := prf _ wfΣ). + destruct Σ. cbn in *. rewrite Hpop' Hpop'' prf'. rewrite <- Hpop at 1. + eapply (erases_deps_cons Σpop). + rewrite <- Hpop'. apply wf. + rewrite Hpop. rewrite prf' in wf. destruct wf. now rewrite Hpop'' Hpop' in o0. + + pose proof (erase_constant_body_correct' H0). specialize_Σ wfmake. + sq. destruct H1 as [bod [bodty [[Hbod Hebod] Heqdeps]]]. + rewrite (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake) in Hbod, Hebod. + eapply (erase_global_erases_deps (Σ := (Σpop, cst_universes c))); simpl; auto. + { constructor; simpl; auto. depelim wf. rewrite Hpop' Hpop'' in o0. + cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. rewrite Hpop' in o. clear -o o0. + now depelim o0. + depelim wf. rewrite Hpop' in o0. + cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. clear -o0. depelim o0. + now destruct o. + } + all: eauto. + apply IHdecls; eauto. + { intros. pose proof (abstract_env_wf _ wfpop) as [wf']. + destruct Σpop. cbn in *. clear prf'. subst. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ H2) as [Hpop Hpop']. + { intros. now eexists. } + destruct Σ. cbn in *. subst. + eapply term_global_deps_spec in Hebod; eauto. } + { eapply KernameSet.subset_spec. + intros x hin'. eapply KernameSet.union_spec. right; auto. + now rewrite -Heqdeps. } } + { eexists m, _; intuition eauto. + eapply declared_minductive_from_gen. + simpl. rewrite /declared_minductive /declared_minductive_gen /lookup_env prf; eauto. + simpl. rewrite eq_kername_refl. reflexivity. + specialize (sub _ hin). + eapply KernameSet.mem_spec in sub. + simpl. rewrite sub. + red. cbn. rewrite eq_kername_refl. + reflexivity. + assert (declared_minductive Σ kn m). + { eapply declared_minductive_from_gen. red. unfold declared_minductive_gen, lookup_env. rewrite prf; eauto. cbn. now rewrite eqb_refl. } + eapply on_declared_minductive in H0; tea. + now eapply erases_mutual. } + + * intros ikn Hi. + destruct d as [|]. + ++ simpl. destruct (KernameSet.mem kn deps) eqn:eqkn. + unfold erase_constant_decl. + set (Xpop := abstract_pop_decls X). + set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + pose proof (abstract_env_wf _ wfpop) as [wfΣp]. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. + { intros. now eexists. } + pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. + eapply global_erases_with_deps_cons; eauto. + eapply (IHdecls Xpop _ _ _ (KernameSet.singleton i)); auto. + 3:{ eapply KernameSet.singleton_spec => //. } + intros. + eapply KernameSet.singleton_spec in H0. + pose proof (abstract_env_irr _ H1 wfpop). subst. + sq; exists decl; eauto. + eapply KernameSet.subset_spec. intros ? ?. + eapply KernameSet.union_spec. left. + eapply KernameSet.singleton_spec in H0; subst. + now eapply sub. + + cbn. set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + pose proof (abstract_env_wf _ wfpop) as [wfΣp]. + unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. + { intros. now eexists. } + pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. + eapply global_erases_with_deps_weaken. eauto. + eapply IHdecls => //. + 3:now eapply KernameSet.singleton_spec. + intros d ind%KernameSet.singleton_spec. + intros. pose proof (abstract_env_irr _ H0 wfpop). subst. + sq; eexists; eauto. + eapply KernameSet.subset_spec. + intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. + + ++ simpl. set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + pose proof (abstract_env_wf _ wfpop) as [wfΣp]. + unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. + { intros. now eexists. } + pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. + destruct (KernameSet.mem kn deps) eqn:eqkn. + { eapply (global_erases_with_deps_cons _ kn (InductiveDecl _) _ Σp); eauto. + eapply (IHdecls Xpop _ _ _ (KernameSet.singleton i)); auto. + 3:{ eapply KernameSet.singleton_spec => //. } + intros. + eapply KernameSet.singleton_spec in H0. subst. + pose proof (abstract_env_irr _ H1 wfpop). subst. + sq; eexists; eauto. + eapply KernameSet.subset_spec. intros ? ?. + eapply KernameSet.singleton_spec in H0; subst. + now eapply sub. } + + { eapply (global_erases_with_deps_weaken _ kn (InductiveDecl _) Σp). eauto. + eapply (IHdecls Xpop _ _ _ (KernameSet.singleton i)) => //. + 3:now eapply KernameSet.singleton_spec. + intros d ind%KernameSet.singleton_spec. + intros. pose proof (abstract_env_irr _ H0 wfpop). subst. + sq; eexists; eauto. + eapply KernameSet.subset_spec. + intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. } +Qed. + +Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) + univs wfext t v Σ' t' deps decls {normalization_in} prf + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} + : + forall wt : forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t, + erase X_type Xext [] t wt = t' -> + KernameSet.subset (term_global_deps t') deps -> + erase_global_deps deps X decls (normalization_in:=normalization_in) prf = Σ' -> + (forall Σ : global_env, abstract_env_rel X Σ -> Σ |-p t ⇓ v) -> + forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> + exists v', Σ ;;; [] |- v ⇝ℇ v' /\ ∥ fst Σ' ⊢ t' ⇓ v' ∥. +Proof. + intros wt. + intros HΣ' Hsub Ht' ev Σext wfΣex. + pose proof (erases_erase (X := Xext) wt). + rewrite HΣ' in H. + destruct (wt _ wfΣex) as [T wt']. + pose proof (abstract_env_ext_wf _ wfΣex) as [wfΣ]. + specialize (H _ wfΣex). + unshelve epose proof (erase_global_erases_deps (Σ' := fst Σ') wfΣ wt' H _); cycle 2. + rewrite <- Ht'. + eapply erase_global_includes; eauto. + intros. eapply term_global_deps_spec in H; eauto. + now rewrite (abstract_make_wf_env_ext_correct X univs wfext Σ _ H1 wfΣex) in H. + + epose proof (abstract_env_exists X) as [[Σ wfΣX]]. + now rewrite (abstract_make_wf_env_ext_correct X univs wfext Σ _ wfΣX wfΣex). + epose proof (abstract_env_exists X) as [[Σ wfΣX]]. + eapply erases_correct; tea. + - eexists; eauto. + - rewrite (abstract_make_wf_env_ext_correct X univs wfext _ _ wfΣX wfΣex); eauto. +Qed. + +Lemma global_env_ind (P : global_env -> Type) + (Pnil : forall univs retro, P {| universes := univs; declarations := []; retroknowledge := retro |}) + (Pcons : forall (Σ : global_env) d, P Σ -> P (add_global_decl Σ d)) + (Σ : global_env) : P Σ. +Proof. + destruct Σ as [univs Σ]. + induction Σ; cbn. apply Pnil. + now apply (Pcons {| universes := univs; declarations := Σ |} a). +Qed. + +Lemma on_global_env_ind (P : forall Σ : global_env, wf Σ -> Type) + (Pnil : forall univs retro (onu : on_global_univs univs), P {| universes := univs; declarations := []; retroknowledge := retro |} + (onu, globenv_nil _ _ _ _)) + (Pcons : forall (Σ : global_env) kn d (wf : wf Σ) + (Hfresh : fresh_global kn Σ.(declarations)) + (udecl := PCUICLookup.universes_decl_of_decl d) + (onud : on_udecl Σ.(universes) udecl) + (pd : on_global_decl cumulSpec0 (lift_typing typing) + ({| universes := Σ.(universes); declarations := Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}, udecl) kn d), + P Σ wf -> P (add_global_decl Σ (kn, d)) + (fst wf, globenv_decl _ _ Σ.(universes) Σ.(retroknowledge) Σ.(declarations) kn d (snd wf) + {| kn_fresh := Hfresh ; on_udecl_udecl := onud ; on_global_decl_d := pd |})) + (Σ : global_env) (wfΣ : wf Σ) : P Σ wfΣ. +Proof. + destruct Σ as [univs Σ]. destruct wfΣ; cbn in *. + induction o0. apply Pnil. destruct o1. + apply (Pcons {| universes := univs; declarations := Σ |} kn d (o, o0)). + exact IHo0. +Qed. + +Ltac inv_eta := + lazymatch goal with + | [ H : PCUICEtaExpand.expanded _ _ |- _ ] => depelim H + end. + +Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : + wf_ext Σ -> + PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> + Σ;;; Γ |- v : tSort u -> + Σ;;; Γ |- v' : tSort u' -> is_propositional u -> + leq_universe (global_ext_constraints Σ) u' u. +Proof. + intros wfΣ leq hv hv' isp. + eapply orb_true_iff in isp as [isp | isp]. + - eapply leq_term_prop_sorted_l; eauto. + - eapply leq_term_sprop_sorted_l; eauto. +Qed. + +Lemma map_erase_irrel X_type X {normalization_in1 normalization_in2 : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t H1 H2 : + erase_terms X_type X Γ t H1 (normalization_in:=normalization_in1) = erase_terms X_type X Γ t H2 (normalization_in:=normalization_in2). +Proof. + eapply erase_irrel. +Qed. + +Lemma erase_mkApps {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t args H2 Ht Hargs : + (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> wf_local Σ Γ) -> + (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ~ ∥ isErasable Σ Γ (mkApps t args) ∥) -> + erase X_type X Γ (mkApps t args) H2 = + E.mkApps (erase X_type X Γ t Ht) (erase_terms X_type X Γ args Hargs). +Proof. + epose proof (abstract_env_ext_exists X) as [[Σ wfΣX]]. + pose proof (abstract_env_ext_wf X wfΣX) as [wf]. + intros Hwflocal Herasable. induction args in t, H2, Ht, Hargs, Herasable |- *. + - cbn. eapply erase_irrel. + - cbn [mkApps]. + rewrite IHargs; clear IHargs. + all: intros; specialize_Σ H; try pose proof (abstract_env_ext_wf _ H) as [wfH]. + 1: inversion Hargs; eauto. depelim X0. now sq. + 2: eauto. + 2:{ destruct H2. cbn in X0. eapply inversion_mkApps in X0 as (? & ? & ?). + econstructor. eauto. } + etransitivity. simp erase. reflexivity. unfold erase_clause_1. + unfold inspect. unfold erase_clause_1_clause_2. + elim: is_erasableP. + + intros. exfalso. + eapply Herasable; eauto. specialize_Σ wfΣX. destruct p. + cbn. destruct H2. eapply Is_type_app; eauto. + + cbn [erase_terms]. + epose proof (fst (erase_irrel _ _)). cbn. + intros he. f_equal => //. f_equal. + eapply erase_irrel. eapply erase_irrel. + eapply map_erase_irrel. +Qed. + +Lemma map_erase_length X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t H1 : length (erase_terms X_type X Γ t H1) = length t. +Proof. + induction t; cbn; f_equal; eauto. +Qed. + +Local Hint Constructors expanded : expanded. + +Local Arguments erase_global_deps _ _ _ _ _ : clear implicits. + +(*Lemma lookup_env_erase X_type X deps decls normalization_in prf kn d : + KernameSet.In kn deps -> + forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some (InductiveDecl d) -> + EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf) kn = Some (EAst.InductiveDecl (erase_mutual_inductive_body d)). +Proof. + intros hin Σ wfΣ. pose proof (prf _ wfΣ). unfold lookup_env. rewrite H. clear H. + rewrite /lookup_env. + induction decls in X, Σ , wfΣ ,prf, deps, hin, normalization_in |- *. + - move=> /= //. + - destruct a as [kn' d']. + cbn -[erase_global_deps]. + case: (eqb_spec kn kn'); intros e'; subst. + intros [= ->]. + unfold erase_global_deps. + eapply KernameSet.mem_spec in hin. rewrite hin /=. + now rewrite eq_kername_refl. + intros hl. destruct d'. simpl. + set (Xpop := abstract_pop_decls X). + set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + destruct KernameSet.mem. cbn. + rewrite (negbTE (proj2 (neqb _ _) e')). + eapply IHdecls => //; eauto. eapply KernameSet.union_spec. left => //. + eapply IHdecls => //; eauto. + simpl. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + destruct KernameSet.mem. cbn. + rewrite (negbTE (proj2 (neqb _ _) e')). + eapply IHdecls => //; eauto. + eapply IHdecls => //; eauto. +Qed. +*) + +Lemma lookup_env_erase_decl_None X_type X deps decls normalization_in prf kn : + forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = None -> + EGlobalEnv.lookup_env (erase_global_deps X_type deps X decls normalization_in prf).1 kn = None. +Proof. + intros Σ wfΣ. + pose proof (prf _ wfΣ). + unfold lookup_env. rewrite H. clear H. + rewrite /lookup_env. + induction decls in X, Σ , wfΣ ,prf, deps, normalization_in |- *. + - move=> /= //. + - destruct a as [kn' d']. + cbn -[erase_global_deps]. + case: (eqb_spec kn kn'); intros e'; subst. + intros [= ->]. + cbn. destruct d'. cbn. + case_eq (KernameSet.mem kn' deps); move => hin'; cbn. + + destruct (eqb_spec kn kn') => //. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. + + intros. set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. + + intros hin. + case_eq (KernameSet.mem kn' deps); move => hin'; cbn. + destruct (eqb_spec kn kn') => //. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. + intros. set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + now eapply IHdecls. +Qed. + +Lemma lookup_env_erase_global_diff X_type X deps decls kn kn' d' normalization_in prf : + kn <> kn' -> + exists deps' nin' prf', + KernameSet.Subset deps deps' /\ + EGlobalEnv.lookup_env (erase_global_deps X_type deps X ((kn', d') :: decls) normalization_in prf).1 kn = + EGlobalEnv.lookup_env (erase_global_deps X_type deps' (abstract_pop_decls X) decls nin' prf').1 kn /\ + (KernameSet.In kn (erase_global_deps X_type deps X ((kn', d') :: decls) normalization_in prf).2 -> + KernameSet.In kn (erase_global_deps X_type deps' (abstract_pop_decls X) decls nin' prf').2). +Proof. + intros hd. + simpl. destruct d'. + + destruct KernameSet.mem. cbn. + destruct (eqb_spec kn kn') => //. + do 3 eexists. split; [|split;[reflexivity|]]. knset. + auto. + do 3 eexists. split; [|split;[reflexivity|]]. knset. + auto. + + destruct KernameSet.mem. cbn. + destruct (eqb_spec kn kn') => //. + do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. + do 3 eexists. split; [|split;[reflexivity|]]. knset. auto. +Qed. + +Lemma lookup_env_In_map_fst Σ kn decl : lookup_global Σ kn = Some decl -> In kn (map fst Σ). +Proof. + induction Σ; cbn => //. + case: eqb_spec. + + intros -> [= <-]. now left. + + intros _ hl. eauto. +Qed. + +Lemma erase_constant_decl_deps {X_type : abstract_env_impl} (X : X_type.π1) (cb : constant_body) normalization_in oncb : + forall Σ : global_env, abstract_env_rel X Σ -> + forall kn, KernameSet.In kn (erase_constant_decl X cb normalization_in oncb).2 -> In kn (map fst (declarations Σ)). +Proof. + intros Σ wfΣ kn. + unfold erase_constant_decl. + set (ec := erase_constant_body _ _ _ _). + destruct cb. destruct cst_body0. + 2:{ subst ec; cbn. knset. } + intros hc. + epose proof (erase_constant_body_correct' (@eq_refl _ (EAst.cst_body ec.1))). + subst ec. + set (ec := erase_constant_body _ _ _ _) in *. + set (X' := abstract_make_wf_env_ext _ _ _) in *. + pose proof (abstract_env_ext_exists X') as [[Σ' H']]. + pose proof (abstract_env_ext_wf _ H') as [wfΣ']. + specialize (H _ H') as [[t0 [T []]]]. + rewrite -e in hc. + destruct p as [hty her]. + epose proof (term_global_deps_spec wfΣ' hty her _ hc). + epose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ wfΣ H'). cbn in H0. subst Σ'. + red in H. destruct H as [[decl hl]]. + now eapply lookup_env_In_map_fst in hl. +Qed. + +Lemma in_erase_global_deps_acc X_type X deps decls kn normalization_in prf : + KernameSet.In kn (erase_global_deps X_type deps X decls normalization_in prf).2 -> + KernameSet.In kn deps \/ In kn (map fst decls). +Proof. + induction decls in X, prf, deps, normalization_in |- *. + cbn; auto. destruct a as [kn' []]. + + cbn. set (ec := erase_constant_decl _ _ _ _). + set (eg := erase_global_deps _ _ _ _ _ _). + set (eg' := erase_global_deps _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + * cbn; intros. specialize (IHdecls _ _ _ _ H0). + destruct IHdecls as [Hu|Hm]; auto. + eapply KernameSet.union_spec in Hu. destruct Hu; auto. + unfold ec in H1; cbn in H1. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + eapply erase_constant_decl_deps in H1; tea. + pose proof (abstract_env_exists X) as [[ΣX HX]]. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ HX wfpop). + intros. rewrite prf => //. now eexists. + now destruct H2 as [<- _]. + * intros hdeps hin. + eapply IHdecls in hin. intuition auto. + + cbn; set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + * cbn; intros. specialize (IHdecls _ _ _ _ H0). + destruct IHdecls as [Hu|Hm]; auto. + * intros hdeps hin. + eapply IHdecls in hin. intuition auto. +Qed. + +Lemma wf_fresh_globals {cf : checker_flags} (Σ : global_env) : wf Σ -> EnvMap.EnvMap.fresh_globals Σ.(declarations). +Proof. + destruct Σ as [univs Σ]; cbn. + move=> [] onu; cbn. induction 1; try destruct o; constructor; auto; constructor; eauto. +Qed. + +Lemma lookup_env_erase_decl X_type X deps decls normalization_in prf kn decl : + forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some decl -> + let er := erase_global_deps X_type deps X decls normalization_in prf in + KernameSet.In kn er.2 -> + match decl with + | ConstantDecl cb => + exists (X' : X_type.π1) nin pf, + (EGlobalEnv.lookup_env er.1 kn = + Some (EAst.ConstantDecl (fst (erase_constant_decl X' cb nin pf)))) /\ + (forall Σ Σ', Σ ∼ X -> Σ' ∼ X' -> ∥ strictly_extends_decls Σ' Σ ∥) + | InductiveDecl mib => + EGlobalEnv.lookup_env er.1 kn = + Some (EAst.InductiveDecl (erase_mutual_inductive_body mib)) + end. +Proof. + intros Σ wfΣ. pose proof (prf _ wfΣ). + unfold lookup_env. rewrite H. clear H. + rewrite /lookup_env. + induction decls in X, Σ , wfΣ ,prf, deps, decl, normalization_in |- *. + - move=> /= //. + - destruct a as [kn' d']. + cbn -[erase_global_deps]. + case: (eqb_spec kn kn'); intros e'; subst. + intros [= ->]. + destruct decl. + + cbn; set (ec := erase_constant_decl _ _ _ _); + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + move/KernameSet.mem_spec => hin'; cbn. + ++ intros hin. cbn; rewrite eqb_refl; + do 3 eexists. split; [reflexivity|]. + intros ? ? hx hpop. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ hx hpop). intros. rewrite prf => //. now eexists. + destruct H as [? []]. unfold strictly_extends_decls. rewrite H. sq; split => //. clear ec eg eg' hin. specialize (prf _ hx). rewrite prf. + now eexists [_]. + ++ intros kn'deps kn'eg'. + eapply in_erase_global_deps_acc in kn'eg'. + destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. + elimtype False. clear -prf wfΣ H. + specialize (prf _ wfΣ). + pose proof (abstract_env_wf _ wfΣ) as []. eapply wf_fresh_globals in X0. + rewrite prf in X0. depelim X0. + apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. + + cbn; + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). + case_eq (KernameSet.mem kn' deps). + move/KernameSet.mem_spec => hin'; cbn. + ++ intros hin. cbn; rewrite eqb_refl; + do 3 eexists. + ++ intros kn'deps kn'eg'. + eapply in_erase_global_deps_acc in kn'eg'. + destruct kn'eg'. eapply KernameSet.mem_spec in H. congruence. + elimtype False. clear -prf wfΣ H. + specialize (prf _ wfΣ). + pose proof (abstract_env_wf _ wfΣ) as []. eapply wf_fresh_globals in X0. + rewrite prf in X0. depelim X0. + apply EnvMap.EnvMap.fresh_global_iff_not_In in H0. contradiction. + + intros hl hin. + epose proof (lookup_env_erase_global_diff X_type X deps decls kn kn' d' _ _ e'). + destruct H as [deps' [nin' [prf' [sub [hl' hin']]]]]. + eapply hin' in hin. + erewrite hl'. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + specialize (IHdecls Xpop deps'). specialize (IHdecls nin' prf' decl _ wfpop hl hin). + destruct decl; intuition auto. + destruct IHdecls as [X' [nin [pf []]]]. exists X', nin, pf. split => //. + intros. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H1 wfpop). intros. rewrite prf => //. now eexists. + specialize (H0 _ _ wfpop H2). destruct H0; sq. move: X0; rewrite /strictly_extends_decls. destruct H3 as [? []]. + rewrite H4 H0 H3. rewrite -(prf' _ wfpop). pose proof (prf _ H1). rewrite -H0 in H5. rewrite H5. + intros []; split => //. destruct s as [Σ'' eq]. eexists ((kn', d') :: Σ''). now rewrite eq. +Qed. + +Lemma fresh_global_app kn Σ Σ' : fresh_global kn (Σ ++ Σ') -> + fresh_global kn Σ /\ fresh_global kn Σ'. +Proof. + induction Σ; cbn; intuition auto. + - constructor. + - depelim H. constructor => //. + now eapply Forall_app in H0. + - depelim H. + now eapply Forall_app in H0. +Qed. + +Lemma lookup_global_app_wf Σ Σ' kn : EnvMap.EnvMap.fresh_globals (Σ ++ Σ') -> + forall decl, lookup_global Σ' kn = Some decl -> lookup_global (Σ ++ Σ') kn = Some decl. +Proof. + induction Σ in kn |- *; cbn; auto. + intros fr; depelim fr. + intros decl hd; cbn. + destruct (eqb_spec kn kn0). + eapply PCUICWeakeningEnv.lookup_global_Some_fresh in hd. + subst. now eapply fresh_global_app in H as [H H']. + now eapply IHΣ. +Qed. + +Lemma strictly_extends_decls_lookup {Σ Σ'} : + wf Σ' -> + strictly_extends_decls Σ Σ' -> + forall kn d, lookup_env Σ kn = Some d -> + lookup_env Σ' kn = Some d. +Proof. + intros. + destruct X0 as [? []]. + rewrite /lookup_env in H *. rewrite e0. + erewrite lookup_global_app_wf. reflexivity. 2:eauto. + eapply wf_fresh_globals in X. now rewrite -e0. +Qed. + +Lemma in_deps_in_erase_global_deps X_type X deps decls normalization_in prf kn : + KernameSet.In kn deps -> + KernameSet.In kn (erase_global_deps X_type deps X decls normalization_in prf).2. +Proof. + induction decls in X, deps, normalization_in, prf |- *. + - intros. now cbn. + - intros. cbn. + pose proof (abstract_env_exists X) as [[Σ H']]. + set (Xpop := abstract_pop_decls X). + epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. + unshelve epose proof (abstract_pop_decls_correct _ decls _ _ _ H' wfpop). intros. rewrite prf => //. now eexists. + destruct H0 as [Hd [Hu Hr]]. + destruct a. destruct g. + + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). + case_eq (KernameSet.mem k deps). + * cbn. intros hm. + destruct (eqb_spec k kn). + ++ subst k. eapply IHdecls. knset. + ++ eapply IHdecls. + knset. + * intros hnin. eapply IHdecls; tea. + + set (eg := erase_global_deps _ _ _ _ _ _); + set (eg' := erase_global_deps _ _ _ _ _ _). + case_eq (KernameSet.mem k deps). + * cbn. intros hm. + destruct (eqb_spec k kn). + ++ subst k. eapply KernameSet.mem_spec in hm. + now eapply IHdecls. + ++ eapply IHdecls. tea. + * intros hnin. eapply IHdecls; tea. +Qed. + +Fixpoint filter_deps deps decls := + match decls with + | [] => [] + | (kn, decl) :: decls => + if KernameSet.mem kn deps then + match decl with + | EAst.ConstantDecl cst => + (kn, decl) :: filter_deps (KernameSet.union deps (constant_decls_deps cst)) decls + | _ => (kn, decl) :: filter_deps deps decls + end + else filter_deps deps decls + end. + +Lemma erase_global_deps_erase_global (X_type : abstract_env_impl) (X:X_type.π1) deps decls {normalization_in} prf : + (@erase_global_deps X_type deps X decls normalization_in prf).1 = + filter_deps deps (@erase_global X_type X decls normalization_in prf). +Proof. + symmetry. + generalize normalization_in at 1. + generalize prf at 1. + intros prf' normalization_in'. + induction decls in normalization_in, normalization_in', prf, prf', X, deps |- *. + - cbn. auto. + - destruct a as [kn []]. + cbn. + + destruct (KernameSet.mem kn deps). + destruct c as [? [] ? ?]. + set (ec := erase_constant_decl _ _ _ _). + set (ec' := erase_constant_decl _ _ _ _). + assert (ec = ec') as <-. + { unfold ec, ec'. eapply erase_constant_decl_irrel. red. cbn. + intros. pose proof (abstract_env_irr _ H H0). subst. red. split; auto. congruence. } + cbn; f_equal. set (d := KernameSet.union _ _). eapply IHdecls. + cbn. f_equal. eapply IHdecls. + eapply IHdecls. + + cbn; destruct (KernameSet.mem kn deps). + cbn. f_equal. eapply IHdecls. + eapply IHdecls. +Qed. + + +Lemma filter_deps_filter {efl : EWellformed.EEnvFlags} deps Σ : + EWellformed.wf_glob Σ -> + (* (forall kn, KernameSet.In kn deps -> In kn (map fst Σ)) -> *) + filter_deps deps Σ = filter (flip KernameSet.mem (global_deps Σ deps) ∘ fst) Σ. +Proof. + induction Σ in deps |- *. + - now cbn. + - destruct a as [kn [[[]]|]]. + + cbn. unfold flip. + destruct (knset_mem_spec kn deps). + * case: (knset_mem_spec kn _). + ** intros hin' hwf. f_equal. depelim hwf. now eapply IHΣ. + ** intros nhin. + elim: nhin. + rewrite global_deps_union. + rewrite KernameSet.union_spec. left. + now eapply in_global_deps. + * intros hwf. + case: (knset_mem_spec kn _); intros hin. + ** elimtype False. + depelim hwf. + eapply in_global_deps_fresh in hin => //. + ** depelim hwf. rewrite -IHΣ => //. + + intros wf; depelim wf. + cbn. unfold flip. + * case: (knset_mem_spec kn _). + ** intros hin'. + case: (knset_mem_spec kn _) => hin''. + ++ f_equal. now eapply IHΣ. + ++ elim: hin''. + rewrite !global_deps_union. + rewrite KernameSet.union_spec. left. + now eapply in_global_deps. + ** intros hwf. + case: (knset_mem_spec kn _); intros hin. + *** elimtype False. + eapply in_global_deps_fresh in hin => //. + *** rewrite -IHΣ => //. + + intros wf; depelim wf. + cbn. unfold flip. + * case: (knset_mem_spec kn _). + ** intros hin'. + case: (knset_mem_spec kn _) => hin''. + ++ f_equal. rewrite IHΣ //. eapply filter_ext. + intros ?. unfold flip. rewrite global_deps_union /=. + rewrite global_deps_empty. + now rewrite KernameSetFact.union_b KernameSetFact.empty_b orb_false_r. + ++ elim: hin''. + rewrite !global_deps_union. + rewrite KernameSet.union_spec. left. + now eapply in_global_deps. + ** intros hwf. + case: (knset_mem_spec kn _); intros hin. + *** elimtype False. + eapply in_global_deps_fresh in hin => //. + *** rewrite -IHΣ => //. +Qed. + +Lemma erase_global_declared_constructor X_type X ind c mind idecl cdecl deps decls normalization_in prf: + forall Σ : global_env, abstract_env_rel X Σ -> declared_constructor Σ (ind, c) mind idecl cdecl -> + KernameSet.In ind.(inductive_mind) deps -> + EGlobalEnv.declared_constructor (erase_global_deps X_type deps X decls normalization_in prf).1 (ind, c) + (erase_mutual_inductive_body mind) (erase_one_inductive_body idecl) + (EAst.mkConstructor cdecl.(cstr_name) cdecl.(cstr_arity)). +Proof. + intros Σ wfΣ [[]] Hin. pose (abstract_env_wf _ wfΣ). sq. + cbn in *. split. split. + - unshelve eapply declared_minductive_to_gen in H; eauto. + red in H |- *. eapply (lookup_env_erase_decl _ _ _ _ _ _ _ (InductiveDecl mind)); eauto. + eapply in_deps_in_erase_global_deps; tea. + + - cbn. now eapply map_nth_error. + - cbn. erewrite map_nth_error; eauto. +Qed. + +Import EGlobalEnv. +Lemma erase_global_deps_fresh X_type kn deps X decls normalization_in heq : + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in + PCUICAst.fresh_global kn decls -> + fresh_global kn Σ'.1. +Proof. + cbn. + revert deps X normalization_in heq. + induction decls; [cbn; auto|]. + - intros. red. constructor. + - destruct a as [kn' d]. intros. depelim H. + cbn in H, H0. + destruct d as []; simpl; destruct KernameSet.mem. + + cbn [EGlobalEnv.closed_env forallb]. cbn. + constructor => //. eapply IHdecls => //. + + eapply IHdecls => //. + + constructor; auto. + eapply IHdecls => //. + + eapply IHdecls => //. +Qed. + +Lemma erase_global_fresh X_type kn X decls normalization_in heq : + let Σ' := @erase_global X_type X decls normalization_in heq in + PCUICAst.fresh_global kn decls -> + fresh_global kn Σ'. +Proof. + cbn. + revert X normalization_in heq. + induction decls; [cbn; auto|]. + - intros. red. constructor. + - destruct a as [kn' d]. intros. depelim H. + cbn in H, H0. cbn. + destruct d as []; simpl. + + cbn [EGlobalEnv.closed_env forallb]. cbn. + constructor => //. eapply IHdecls => //. + + constructor; auto. + eapply IHdecls => //. +Qed. + +From MetaCoq.Erasure Require Import EEtaExpandedFix. + +Lemma erase_brs_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ p ts wt : + erase_brs X_type X Γ p ts wt = + map_All (fun br wt => (erase_context (bcontext br), erase X_type X _ (bbody br) wt)) ts wt. +Proof. + funelim (map_All _ ts wt); cbn; auto. + f_equal => //. f_equal => //. apply erase_irrel. + rewrite -H. eapply erase_irrel. +Qed. + +Lemma erase_fix_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ ts wt : + erase_fix X_type X Γ ts wt = map_All (fun d wt => + let dbody' := erase X_type X _ (dbody d) (fun Σ abs => proj2 (wt Σ abs)) in + let dbody' := if isBox dbody' then + match d.(dbody) with + | tLambda na _ _ => E.tLambda (binder_name na) E.tBox + | _ => dbody' + end else dbody' + in + {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |}) ts wt. +Proof. + funelim (map_All _ ts wt); cbn; auto. + f_equal => //. f_equal => //. + rewrite (fst (erase_irrel _ _) _ _ _ _ (fun (Σ : global_env_ext) (abs : abstract_env_ext_rel X Σ) => + (map_All_obligation_1 x xs h Σ abs).p2)). + destruct erase => //. + rewrite -H. eapply erase_irrel. +Qed. + +Lemma erase_cofix_eq X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ ts wt : + erase_cofix X_type X Γ ts wt = map_All (fun d wt => + let dbody' := erase X_type X _ (dbody d) wt in + {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |}) ts wt. +Proof. + funelim (map_All _ ts wt); cbn; auto. + f_equal => //. f_equal => //. + apply erase_irrel. + rewrite -H. eapply erase_irrel. +Qed. + +Lemma isConstruct_erase X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t wt : + ~ (PCUICEtaExpand.isConstruct t || PCUICEtaExpand.isFix t || PCUICEtaExpand.isRel t) -> + ~ (isConstruct (erase X_type X Γ t wt) || isFix (erase X_type X Γ t wt) || isRel (erase X_type X Γ t wt)). +Proof. + apply (erase_elim X_type X + (fun Γ t wt e => ~ (PCUICEtaExpand.isConstruct t || PCUICEtaExpand.isFix t || PCUICEtaExpand.isRel t) -> ~ (isConstruct e || isFix e || isRel e)) + (fun Γ l awt e => True) + (fun Γ p l awt e => True) + (fun Γ l awt e => True) + (fun Γ l awt e => True)); intros => //. bang. +Qed. + +Lemma apply_expanded Σ Γ Γ' t t' : + expanded Σ Γ t -> Γ = Γ' -> t = t' -> expanded Σ Γ' t'. +Proof. intros; now subst. Qed. + +Lemma isLambda_inv t : isLambda t -> exists na ty bod, t = tLambda na ty bod. +Proof. destruct t => //; eauto. Qed. + +Lemma erases_deps_erase (cf := config.extraction_checker_flags) + {X_type X} univs + (wfΣ : forall Σ, (abstract_env_rel X Σ) -> ∥ wf_ext (Σ, univs) ∥) decls {normalization_in} prf + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + Γ t + (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) : + let et := erase X_type X' Γ t wt in + let deps := EAstUtils.term_global_deps et in + forall Σ, (abstract_env_rel X Σ) -> + erases_deps Σ (erase_global_deps X_type deps X decls normalization_in prf).1 et. +Proof. + intros et deps Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. + pose proof (wt _ wfΣ'). destruct H. pose proof (wfΣ _ wf) as [w]. + rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ') in X0. + eapply (erase_global_erases_deps w); tea. + eapply (erases_erase (X := X') (Γ := Γ)). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply erase_global_includes. + intros. rewrite (abstract_env_irr _ H0 wf). + eapply term_global_deps_spec in H; eauto. + assumption. + eapply (erases_erase (X := X') (Γ := Γ)). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply KernameSet.subset_spec. reflexivity. + now cbn. +Qed. + +Lemma erases_deps_erase_weaken (cf := config.extraction_checker_flags) + {X_type X} univs + (wfΣ : forall Σ, (abstract_env_rel X Σ) -> ∥ wf_ext (Σ, univs) ∥) decls {normalization_in} prf + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + Γ t + (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) + deps : + let et := erase X_type X' Γ t wt in + let tdeps := EAstUtils.term_global_deps et in + forall Σ, (abstract_env_rel X Σ) -> + erases_deps Σ (erase_global_deps X_type (KernameSet.union deps tdeps) X decls normalization_in prf).1 et. +Proof. + intros et tdeps Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. + pose proof (wt _ wfΣ'). destruct H. pose proof (wfΣ _ wf) as [w]. + rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ') in X0. + eapply (erase_global_erases_deps w); tea. + eapply (erases_erase (X := X') (Γ := Γ)). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply erase_global_includes. + intros. rewrite (abstract_env_irr _ H0 wf). + eapply term_global_deps_spec in H; eauto. + assumption. + eapply (erases_erase (X := X') (Γ := Γ)). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply KernameSet.subset_spec. intros x hin. + eapply KernameSet.union_spec. now right. + now cbn. +Qed. + +Lemma eta_expand_erase {X_type X} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Σ' {Γ t} + (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) Γ' : + forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + PCUICEtaExpand.expanded Σ Γ' t -> + erases_global Σ Σ' -> + expanded Σ' Γ' (erase X_type X Γ t wt). +Proof. + intros Σ wfΣ exp deps. + pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. + eapply expanded_erases. apply wf. + eapply erases_erase; eauto. assumption. + pose proof (wt _ wfΣ). destruct H as [T ht]. + eapply erases_global_erases_deps; tea. + eapply erases_erase; eauto. +Qed. + +Lemma erase_global_closed X_type X deps decls {normalization_in} prf : + let X' := erase_global_deps X_type deps X decls normalization_in prf in + EGlobalEnv.closed_env X'.1. +Proof. + revert X normalization_in prf deps. + induction decls; [cbn; auto|]. + intros X normalization_in prf deps. + destruct a as [kn d]. + destruct d as []; simpl; destruct KernameSet.mem; + unfold erase_constant_decl; + set (Xpop := abstract_pop_decls X); + try (set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); + assert (normalization_in_Xmake : forall Σ : global_env_ext, wf_ext Σ -> Σ ∼_ext Xmake -> NormalizationIn Σ) + by (subst Xmake; unshelve eapply (normalization_in 0); revgoals; try reflexivity; cbn; lia)). + + cbn [EGlobalEnv.closed_env forallb]. cbn. + rewrite [forallb _ _](IHdecls) // andb_true_r. + rewrite /test_snd /EGlobalEnv.closed_decl /=. + destruct c as [ty [] univs]; cbn. + unfold erase_constant_decl. + set (obl := ErasureFunction.erase_constant_body_obligation_1 _ _ _ _ _). + unfold erase_constant_body. cbn. clearbody obl. cbn in obl. + 2:auto. + pose proof (abstract_env_ext_exists Xmake) as [[Σmake wfmake]]. + pose proof (abstract_env_ext_wf _ wfmake) as [[?]]. + unshelve epose proof (erases_erase (X := Xmake) (obl eq_refl) _ _) as H; eauto. + eapply erases_closed in H. + 1: edestruct erase_irrel as [-> _]; eassumption. + cbn. destruct (obl eq_refl _ wfmake). clear H. + now eapply PCUICClosedTyp.subject_closed in X0. + + eapply IHdecls => //. + + cbn [EGlobalEnv.closed_env forallb]. + eapply IHdecls => //. + + eapply IHdecls => //. + Unshelve. eauto. +Qed. + +Import EWellformed. + +Section wffix. + Import EAst. + Fixpoint wf_fixpoints (t : term) : bool := + match t with + | tRel i => true + | tEvar ev args => List.forallb (wf_fixpoints) args + | tLambda N M => wf_fixpoints M + | tApp u v => wf_fixpoints u && wf_fixpoints v + | tLetIn na b b' => wf_fixpoints b && wf_fixpoints b' + | tCase ind c brs => + let brs' := forallb (wf_fixpoints ∘ snd) brs in + wf_fixpoints c && brs' + | tProj p c => wf_fixpoints c + | tFix mfix idx => + (idx isLambda d.(dbody) && wf_fixpoints d.(dbody)) mfix + | tCoFix mfix idx => + (idx true + | tConstruct ind c _ => true + | tVar _ => true + | tBox => true + | tPrim _ => true + end. + +End wffix. + +Lemma erases_deps_wellformed (cf := config.extraction_checker_flags) (efl := all_env_flags) {Σ} {Σ'} et : + erases_deps Σ Σ' et -> + forall n, ELiftSubst.closedn n et -> + wf_fixpoints et -> + wellformed Σ' n et. +Proof. + intros ed. + induction ed using erases_deps_forall_ind; intros => //; + try solve [cbn in *; unfold wf_fix in *; rtoProp; intuition eauto; solve_all]. + - cbn. red in H0. rewrite H0 //. + - cbn -[lookup_constructor]. + cbn. now destruct H0 as [[-> ->] ->]. + - cbn in *. move/andP: H5 => [] cld clbrs. + cbn. apply/andP; split. apply/andP; split. + * now destruct H0 as [-> ->]. + * now move/andP: H6. + * move/andP: H6; solve_all. + - cbn -[lookup_projection] in *. apply/andP; split; eauto. + now rewrite (declared_projection_lookup H0). +Qed. + +Lemma erases_wf_fixpoints Σ Γ t t' : Σ;;; Γ |- t ⇝ℇ t' -> + ErasureProperties.wellformed Σ t -> wf_fixpoints t'. +Proof. + induction 1 using erases_forall_list_ind; cbn; auto; try solve [rtoProp; repeat solve_all]. + - move/andP => []. rewrite (All2_length X) => -> /=. unfold test_def in *. + eapply Forall2_All2 in H. + eapply All2_All2_mix in X; tea. solve_all. + destruct b0; eapply erases_isLambda in H1; tea. + - move/andP => []. rewrite (All2_length X) => -> /=. + unfold test_def in *. solve_all. +Qed. + +Lemma erase_wf_fixpoints (efl := all_env_flags) {X_type X} univs wfΣ {Γ t} wt + (X' := abstract_make_wf_env_ext X univs wfΣ) {normalization_in} : + let t' := erase X_type X' (normalization_in:=normalization_in) Γ t wt in + wf_fixpoints t'. +Proof. + cbn. pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. + pose proof (abstract_env_exists X) as [[Σ wf]]. + eapply erases_wf_fixpoints. + eapply erases_erase; eauto. + specialize (wt _ wf'). destruct (wfΣ _ wf). + unshelve eapply welltyped_wellformed in wt; eauto. + now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wf'). +Qed. + +Lemma erases_global_erase_global (efl := all_env_flags) {X_type X} Σ decls {normalization_in} prf : + Σ ∼ X -> + erases_global Σ (@erase_global X_type X decls normalization_in prf). +Proof. + intros h. pose proof (prf _ h). red. rewrite H. clear H. + induction decls in X, Σ, prf, normalization_in, h |- *. + - cbn. constructor. + - cbn. + set (Xpop := abstract_pop_decls X). + destruct (abstract_env_exists Xpop) as [[Σpop hpop]]. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ h hpop). + intros; eexists; now eapply prf. + destruct H as [? []]. + destruct a as [kn []]. + * constructor. cbn. + unfold erase_constant_decl. + set (Σd := {| universes := _ |}). + assert (Σd = Σpop). + { subst Σd. rewrite -H H0 H1. now destruct Σpop. } + subst Σd. + set (ext := abstract_make_wf_env_ext _ _ _). + pose proof (abstract_env_ext_exists ext) as [[Σ' wf']]. + epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ hpop wf'). + subst Σ'. + cbn. pose proof (abstract_env_wf _ hpop) as []. + eapply (erase_constant_body_correct _ _ _ _ (Σpop, cst_universes c)) => //. + now rewrite H2. rewrite H2. split => //. now exists []. + rewrite H0 H1. + now eapply IHdecls. + * pose proof (abstract_env_wf _ h) as [wfΣ]. + destruct wfΣ. rewrite (prf _ h) in o0. + depelim o0. depelim o1. + constructor. + eapply erases_mutual. eapply on_global_decl_d. + rewrite H0 H1. + now eapply IHdecls. +Qed. + +Lemma erase_global_wellformed (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + (t' := erase X_type X' Γ t wt) : + wellformed (@erase_global X_type X decls normalization_in prf) #|Γ| t'. +Proof. + cbn. + epose proof (@erases_erase X_type X' normalization_in' _ _ wt). + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. + pose proof (abstract_env_ext_wf _ wf') as [?]. + eapply (erases_wellformed (wt _ wf')) in H; eauto; tea. + eapply erases_global_all_deps. apply X0. + epose proof (abstract_make_wf_env_ext_correct _ _ wfΣ _ _ wf wf'). subst Σ'. + now eapply erases_global_erase_global. +Qed. + +Lemma erase_wellformed_deps (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + (t' := erase X_type X' Γ t wt) : + wellformed (erase_global_deps X_type (term_global_deps t') X decls normalization_in prf).1 #|Γ| t'. +Proof. + cbn. + epose proof (@erases_deps_erase X_type X univs wfΣ decls normalization_in prf _ Γ t wt). + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. + pose proof (abstract_env_ext_wf _ wf') as [[?]]. + epose proof (erases_deps_wellformed _ H #|Γ|). + apply H0. + eapply (erases_closed _ Γ). + destruct (wt _ wf'). + cbn in X. destruct (wfΣ _ wf). + eapply PCUICClosedTyp.subject_closed in X0. eassumption. + eapply erases_erase; eauto. + eapply erase_wf_fixpoints. Unshelve. eauto. +Qed. + +Lemma erase_wellformed_weaken (efl := all_env_flags) {X_type X} decls {normalization_in} prf univs wfΣ {Γ t} wt +(X' := abstract_make_wf_env_ext X univs wfΣ) +{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} +deps: +let t' := erase X_type X' Γ t wt in + wellformed (erase_global_deps X_type (KernameSet.union deps (term_global_deps t')) X decls normalization_in prf).1 #|Γ| t'. +Proof. + set (t' := erase _ _ _ _ _). cbn. + epose proof (@erases_deps_erase_weaken _ X univs wfΣ decls _ prf _ Γ t wt deps). + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. + pose proof (abstract_env_ext_wf _ wf') as [[?]]. + epose proof (erases_deps_wellformed _ H #|Γ|). + apply H0. + eapply (erases_closed _ Γ). + - destruct (wt _ wf'). + destruct (wfΣ _ wf). + eapply PCUICClosedTyp.subject_closed in X0. eassumption. + - eapply erases_erase; eauto. + - eapply erase_wf_fixpoints. + Unshelve. eauto. +Qed. + +Lemma erase_constant_body_correct'' {X_type X} {cb} {decls normalization_in prf} {univs wfΣ} +(X' := abstract_make_wf_env_ext X univs wfΣ) +{normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} +{onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} deps : + EAst.cst_body (fst (erase_constant_body X_type X' cb onc)) = Some body -> + forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> + ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * + (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * + wellformed (efl:=all_env_flags) (erase_global_deps X_type (KernameSet.union deps (term_global_deps body)) X decls normalization_in prf).1 0 body ∥. +Proof. + intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. + destruct cb as [name [bod|] udecl]; simpl. + simpl in H. noconf H. + set (obl :=(ErasureFunction.erase_constant_body_obligation_1 X_type X' + {| + cst_type := name; + cst_body := Some bod; + cst_universes := udecl |} onc bod eq_refl)). clearbody obl. + destruct (obl _ wfΣ'). sq. + have er : (Σ, univs);;; [] |- bod ⇝ℇ erase X_type X' [] bod obl. + { eapply (erases_erase (X:=X')). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + } + exists bod, A; intuition auto. + now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply erase_wellformed_weaken. + now simpl in H. +Qed. + +Lemma erase_global_cst_decl_wf_glob X_type X deps decls normalization_in heq : + forall cb wfΣ hcb, + let X' := abstract_make_wf_env_ext X (cst_universes cb) wfΣ in + forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, + let ecb := erase_constant_body X_type X' cb hcb in + let Σ' := erase_global_deps X_type (KernameSet.union deps ecb.2) X decls normalization_in heq in + (@wf_global_decl all_env_flags Σ'.1 (EAst.ConstantDecl ecb.1) : Prop). +Proof. + intros cb wfΣ hcb X' normalization_in' ecb Σ'. + unfold wf_global_decl. cbn. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. + destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. + destruct EAst.cst_body eqn:hb => /= //. + eapply (erase_constant_body_correct'') in hb; eauto. + destruct hb as [[t0 [T [[] ?]]]]. rewrite e in i. exact i. +Qed. + +Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls normalization_in kn m} heq : + (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> + let m' := erase_mutual_inductive_body m in + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in + @wf_global_decl all_env_flags Σ'.1 (EAst.InductiveDecl m'). +Proof. + set (m' := erase_mutual_inductive_body m). + set (Σ' := erase_global_deps _ _ _ _ _ _). simpl. + intros oni. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_wf _ wf) as [wfΣ]. + assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). + { eapply (erases_mutual (mdecl:=kn)); tea. } + eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ'.1)) in H; tea. + rewrite -(heq _ wf). now destruct Σ. +Qed. + +Lemma erase_global_deps_wf_glob X_type X deps decls normalization_in heq : + let Σ' := erase_global_deps X_type deps X decls normalization_in heq in + @wf_glob all_env_flags Σ'.1. +Proof. + cbn. + pose proof (abstract_env_exists X) as [[Σ wf]]. + pose proof (abstract_env_wf _ wf) as [wfΣ]. + revert deps X Σ wf wfΣ normalization_in heq. + induction decls; [cbn; auto|]. + { intros. constructor. } + intros. destruct a as [kn []]; simpl; destruct KernameSet.mem; set (Xpop := abstract_pop_decls X); + try set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); + epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; + pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. + + constructor. eapply IHdecls => //; eauto. eapply erase_global_cst_decl_wf_glob; auto. + eapply erase_global_deps_fresh; auto. + destruct wfΣ. destruct wfΣpop. + rewrite (heq _ wf) in o0. depelim o0. now destruct o3. + + cbn. eapply IHdecls; eauto. + + constructor. eapply IHdecls; eauto. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. destruct o0. + eapply (erase_global_ind_decl_wf_glob (kn:=kn)); tea. + intros. rewrite (abstract_env_irr _ H wfpop). + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. + {intros; now eexists. } + destruct Σpop, Σ; cbn in *. now subst. + eapply erase_global_deps_fresh. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. now destruct o0. + + eapply IHdecls; eauto. +Qed. + +Lemma erase_constant_body_correct_glob {X_type X} {cb} {decls normalization_in prf} {univs wfΣ} + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} + {onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} : + EAst.cst_body (fst (erase_constant_body X_type X' cb onc)) = Some body -> + forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> + ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * + (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * + wellformed (efl:=all_env_flags) (@erase_global X_type X decls normalization_in prf) 0 body ∥. +Proof. + intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. + destruct cb as [name [bod|] udecl]; simpl. + simpl in H. noconf H. + set (obl :=(ErasureFunction.erase_constant_body_obligation_1 X_type X' + {| + cst_type := name; + cst_body := Some bod; + cst_universes := udecl |} onc bod eq_refl)). clearbody obl. + destruct (obl _ wfΣ'). sq. + have er : (Σ, univs);;; [] |- bod ⇝ℇ erase X_type X' [] bod obl. + { eapply (erases_erase (X:=X')). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + } + exists bod, A; intuition auto. + now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + eapply (erase_global_wellformed decls _ _ _ (Γ := [])). + now simpl in H. +Qed. + +Lemma erase_global_cst_wf_glob X_type X decls normalization_in heq : + forall cb wfΣ hcb, + let X' := abstract_make_wf_env_ext X (cst_universes cb) wfΣ in + forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, + let ecb := erase_constant_body X_type X' cb hcb in + let Σ' := @erase_global X_type X decls normalization_in heq in + (@wf_global_decl all_env_flags Σ' (EAst.ConstantDecl ecb.1) : Prop). +Proof. + intros cb wfΣ hcb X' normalization_in' ecb Σ'. + unfold wf_global_decl. cbn. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. + destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. + destruct EAst.cst_body eqn:hb => /= //. + eapply (erase_constant_body_correct_glob) in hb; eauto. + destruct hb as [[t0 [T [[] ?]]]]. exact i. +Qed. + +Lemma erase_global_ind_decl_wf_glob' {X_type X} {decls normalization_in kn m} heq : + (forall Σ : global_env, abstract_env_rel X Σ -> on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) kn m) -> + let m' := erase_mutual_inductive_body m in + let Σ' := @erase_global X_type X decls normalization_in heq in + @wf_global_decl all_env_flags Σ' (EAst.InductiveDecl m'). +Proof. + set (m' := erase_mutual_inductive_body m). + set (Σ' := erase_global _ _ _). simpl. + intros oni. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_wf _ wf) as [wfΣ]. + assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). + { eapply (erases_mutual (mdecl:=kn)); tea. } + eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ')) in H; tea. + rewrite -(heq _ wf). now destruct Σ. +Qed. + +Lemma erase_global_wf_glob X_type X decls normalization_in heq : + let Σ' := @erase_global X_type X decls normalization_in heq in + @wf_glob all_env_flags Σ'. +Proof. + cbn. + pose proof (abstract_env_exists X) as [[Σ wf]]. + pose proof (abstract_env_wf _ wf) as [wfΣ]. + revert X Σ wf wfΣ normalization_in heq. + induction decls; [cbn; auto|]. + { intros. constructor. } + intros. destruct a as [kn []]; simpl; set (Xpop := abstract_pop_decls X); + try set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); + epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; + pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. + + constructor. eapply IHdecls => //; eauto. + eapply erase_global_cst_wf_glob; auto. + eapply erase_global_fresh; auto. + destruct wfΣ. destruct wfΣpop. + rewrite (heq _ wf) in o0. depelim o0. now destruct o3. + + constructor. eapply IHdecls; eauto. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. destruct o0. + eapply (erase_global_ind_decl_wf_glob' (kn:=kn)); tea. + intros. rewrite (abstract_env_irr _ H wfpop). + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. + { intros; now eexists. } + destruct Σpop, Σ; cbn in *. now subst. + eapply erase_global_fresh. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. now destruct o0. +Qed. + +Lemma extends_cons d Σ Σ' : extends Σ Σ' -> extends (d :: Σ) (d :: Σ'). +Proof. + intros ext kn decl. + cbn. + case: (eqb_spec kn d.1). + - now intros -> [= <-]. + - intros hin. apply ext. +Qed. + +Lemma extends_fresh Σ Σ' kn d : + fresh_global kn Σ' -> + extends Σ Σ' -> + extends Σ ((kn, d) :: Σ'). +Proof. + intros fr ext. + intros kn' decl hl. + cbn. destruct (eqb_spec kn' kn) => //. subst. + eapply ext in hl. now eapply lookup_env_Some_fresh in hl. + now eapply ext. +Qed. + +Lemma Forall_filter {A} {P} f l : @Forall A P l -> Forall P (filter f l). +Proof. + induction 1; try econstructor; auto. + cbn. case E: (f x) => //. now constructor. +Qed. + +Lemma extends_filter_impl {efl : EEnvFlags} (f f' : kername * EAst.global_decl -> bool) Σ : + (forall x, f x -> f' x) -> + wf_glob Σ -> + extends (filter f Σ) (filter f' Σ). +Proof. + intros hf; induction Σ; cbn; auto. + - red; auto. + - intros wf; depelim wf. + case E: (f _); auto. rewrite (hf _ E). + now eapply extends_cons. + case E': (f' _); auto. + eapply extends_fresh. now eapply Forall_filter. + auto. +Qed. + +Lemma extends_filter {efl : EEnvFlags} (f : kername * EAst.global_decl -> bool) Σ : + wf_glob Σ -> + extends (filter f Σ) Σ. +Proof. + intros wf hf; induction Σ; cbn; auto. + intros decl. depelim wf. cbn in *. + case E: (f _); auto; cbn. + case (eqb_spec hf kn) => //. + - intros hd. now eapply IHΣ. + - intros hl; eapply IHΣ in hl => //. rewrite hl. + case (eqb_spec hf kn) => heq. + subst. now eapply lookup_env_Some_fresh in hl. + reflexivity. +Qed. + +Lemma erase_global_deps_eval {efl : EWcbvEval.WcbvFlags} (X_type : abstract_env_impl) (X X':X_type.π1) ext wfX wfX' {normalization_in} {normalization_in'} decls nin prf Γ t wt v wv : + let Xext := abstract_make_wf_env_ext X ext wfX in + let Xext' := abstract_make_wf_env_ext X' ext wfX' in + let t' := erase X_type Xext (normalization_in := normalization_in) Γ t wt in + let v' := erase X_type Xext' (normalization_in := normalization_in') Γ v wv in + let eg := erase_global_deps X_type (term_global_deps t') X decls nin prf in + let eg' := erase_global_deps X_type (term_global_deps v') X decls nin prf in + eg.1 ⊢ t' ⇓ v' -> EGlobalEnv.extends eg'.1 eg.1. +Proof. + intros. + move: (erase_global_deps_wf_glob X_type X (term_global_deps t') decls nin prf). + subst eg eg'. + rewrite !erase_global_deps_erase_global. + assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls nin prf)). + { eapply erase_global_wf_glob. } + rewrite !(filter_deps_filter (efl := all_env_flags)) //. + cbn. + intros wf. + eapply extends_filter_impl; tea. unfold flip in *. + intros [kn d]; cbn. clear d. + rewrite /is_true !KernameSet.mem_spec. revert kn. + eapply EWcbvEval.weakening_eval_env in H. 2:exact wfer. + now eapply eval_global_deps in H. + rewrite !erase_global_deps_erase_global (filter_deps_filter (efl := all_env_flags)) //. + now eapply extends_filter. +Qed. + +Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {deps deps' decls normalization_in prf} : + KernameSet.Subset deps deps' -> + EExtends.global_subset (erase_global_deps X_type deps X decls normalization_in prf).1 (erase_global_deps X_type deps' X decls normalization_in prf).1. +Proof. + intros sub. + rewrite !erase_global_deps_erase_global. + assert (wfer : wf_glob (efl := all_env_flags) (@erase_global X_type X decls normalization_in prf)). + { eapply erase_global_wf_glob. } + rewrite !(filter_deps_filter (efl := all_env_flags)) //. + eapply extends_filter_impl => //. 2:exact wfer. + unfold flip. + move=> x /KernameSet.mem_spec hin. + apply/KernameSet.mem_spec. + eapply global_deps_subset; tea. +Qed. + +Lemma expanded_weakening_global X_type X deps deps' decls normalization_in prf Γ t : + KernameSet.Subset deps deps' -> + expanded (erase_global_deps X_type deps X decls normalization_in prf).1 Γ t -> + expanded (erase_global_deps X_type deps' X decls normalization_in prf).1 Γ t. +Proof. + intros hs. + eapply expanded_ind; intros; try solve [econstructor; eauto]. + - eapply expanded_tFix; tea. solve_all. + - eapply expanded_tConstruct_app; tea. + destruct H. split; tea. + destruct d; split => //. + cbn in *. red in H. + eapply lookup_erase_global in H; tea. +Qed. + +Lemma expanded_erase (cf := config.extraction_checker_flags) + {X_type X decls normalization_in prf} univs wfΣ t wtp : + forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded Σ [] t -> + let X' := abstract_make_wf_env_ext X univs wfΣ in + forall normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ, + let et := (erase X_type X' [] t wtp) in + let deps := EAstUtils.term_global_deps et in + expanded (erase_global_deps X_type deps X decls normalization_in prf).1 [] et. +Proof. + intros Σ wf hexp X' normalization_in'. + pose proof (abstract_env_wf _ wf) as [wf']. + pose proof (abstract_env_ext_exists X') as [[? wfmake]]. + eapply (expanded_erases (Σ := (Σ, univs))); tea. + eapply (erases_erase (X := X')); eauto. + now erewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ). + cbn. + eapply (erases_deps_erase (X := X) univs wfΣ); eauto. +Qed. + +Lemma expanded_erase_global (cf := config.extraction_checker_flags) + deps {X_type X decls normalization_in prf} : + forall Σ : global_env, abstract_env_rel X Σ -> + PCUICEtaExpand.expanded_global_env Σ -> + expanded_global_env (erase_global_deps X_type deps X decls normalization_in prf).1. +Proof. + intros Σ wf etaΣ. pose proof (prf _ wf). + destruct Σ as [univ decls']. + red. revert wf. red in etaΣ. cbn in *. subst. + revert deps X normalization_in prf. + induction etaΣ; intros deps. intros. constructor. intros. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop wfpop]]. + unshelve epose proof (abstract_pop_decls_correct X Σ _ _ _ wf wfpop) as [? [? ?]]. + { now eexists. } + destruct Σpop. cbn in H0, H1, H2. subst. + destruct decl as [kn []]; + destruct (KernameSet.mem kn deps) eqn:eqkn; simpl; rewrite eqkn. + constructor; [eapply IHetaΣ; auto|]. + red. cbn. red. cbn in *. + unfold erase_constant_decl. + set (deps' := KernameSet.union _ _). hidebody deps'. + set (wfext := abstract_make_wf_env_ext _ _ _). hidebody wfext. + destruct H. + destruct c as [cst_na [cst_body|] cst_type cst_rel]. + cbn in *. + eapply expanded_weakening_global. + 2:{ eapply expanded_erase; tea. } + set (et := erase _ _ _ _) in *. + unfold deps'. unfold hidebody. intros x hin. + eapply KernameSet.union_spec. right => //. + now cbn. + eapply IHetaΣ; eauto. + constructor. eapply IHetaΣ; eauto. + red. cbn => //. + eapply IHetaΣ; eauto. +Qed. + +(* Sanity checks: the [erase] function maximally erases terms *) +Lemma erasable_tBox_value (wfl := Ee.default_wcbv_flags) (Σ : global_env_ext) (wfΣ : wf_ext Σ) t T v : + forall wt : Σ ;;; [] |- t : T, + Σ |-p t ⇓ v -> erases Σ [] v E.tBox -> ∥ isErasable Σ [] t ∥. +Proof. + intros. + depind H. + eapply Is_type_eval_inv; eauto. eexists; eauto. +Qed. + +Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) + {X_type X} {univs wfext t v Σ' t' deps decls normalization_in prf} + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} + : + forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, + erase X_type Xext [] t wt = t' -> + KernameSet.subset (term_global_deps t') deps -> + erase_global_deps X_type deps X decls normalization_in prf = Σ' -> + forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> + (forall Σ : global_env, abstract_env_rel X Σ -> + PCUICWcbvEval.eval Σ t v) -> + @Ee.eval Ee.default_wcbv_flags Σ'.1 t' E.tBox -> ∥ isErasable Σext [] t ∥. +Proof. + intros wt. + intros. + destruct (erase_correct X_type X univs wfext _ _ Σ' _ _ decls prf wt H H0 H1 X0 _ H2) as [ev [eg [eg']]]. + pose proof (Ee.eval_deterministic H3 eg'). subst. + pose proof (abstract_env_exists X) as [[? wf]]. + destruct (wfext _ wf). destruct (wt _ H2) as [T wt']. + pose proof (abstract_env_ext_wf _ H2) as [?]. + eapply erasable_tBox_value; eauto. + pose proof (abstract_make_wf_env_ext_correct X univs wfext _ _ wf H2). subst. + apply X0; eauto. +Qed. + +Lemma erase_eval_to_box_eager (wfl := Ee.default_wcbv_flags) + {X_type X} {univs wfext t v Σ' t' deps decls normalization_in prf} + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} + : + forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, + erase X_type Xext [] t wt = t' -> + KernameSet.subset (term_global_deps t') deps -> + erase_global_deps X_type deps X decls normalization_in prf = Σ' -> + forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> + (forall Σ : global_env, abstract_env_rel X Σ -> + PCUICWcbvEval.eval Σ t v) -> + @Ee.eval Ee.default_wcbv_flags Σ'.1 t' E.tBox -> t' = E.tBox. +Proof. + intros wt. + intros. + destruct (erase_eval_to_box wt H H0 H1 _ H2 X0 H3). + subst t'. + destruct (inspect_bool (is_erasableb X_type Xext [] t wt)) eqn:heq. + - simp erase. rewrite heq. + simp erase => //. + - elimtype False. + pose proof (abstract_env_exists X) as [[? wf]]. + destruct (@is_erasableP X_type Xext _ [] t wt) => //. apply n. + intros. sq. now rewrite (abstract_env_ext_irr _ H H2). +Qed. + +From MetaCoq.PCUIC Require Import PCUICFirstorder. + +From Equations Require Import Equations. + +Inductive firstorder_evalue Σ : EAst.term -> Prop := + | is_fo i n args npars : + EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + Forall (firstorder_evalue Σ) (skipn npars args) -> + firstorder_evalue Σ (EAst.mkApps (EAst.tConstruct i n []) args). + +Lemma list_size_skipn {A} (l : list A) size n : + list_size size (skipn n l) <= list_size size l. +Proof. + induction n in l |- *. + - rewrite skipn_0 //. + - destruct l. rewrite skipn_nil. now cbn. + rewrite skipn_S. cbn. specialize (IHn l); lia. +Qed. + +Section elim. + Context (Σ : E.global_context). + Context (P : EAst.term -> Prop). + Context (ih : (forall i n args npars, + EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + Forall (firstorder_evalue Σ) (skipn npars args) -> + Forall P (skipn npars args) -> + P (EAst.mkApps (EAst.tConstruct i n []) args))). + + Equations? firstorder_evalue_elim (t : EAst.term) (fo : firstorder_evalue Σ t) : P t by wf t (MR lt EInduction.size) := + { | _, is_fo i n args npars hl hf => _ }. + Proof. + eapply ih; tea. + eapply In_Forall. intros x hin. + eapply PCUICWfUniverses.Forall_In in hf; tea. + apply firstorder_evalue_elim => //. red. + rewrite EInduction.size_mkApps. + eapply (In_size id EInduction.size) in hin. + unfold id in *. pose proof (list_size_skipn args EInduction.size npars). + change (fun x => EInduction.size x) with EInduction.size in hin. clear -hin H. + eapply Nat.lt_le_trans; tea. cbn. lia. + Qed. +End elim. + + +Lemma welltyped_mkApps_inv {cf} {Σ : global_env_ext} Γ f args : ∥ wf Σ ∥ -> + welltyped Σ Γ (mkApps f args) -> welltyped Σ Γ f /\ Forall (welltyped Σ Γ) args. +Proof. + intros wf (A & HA). sq. eapply inversion_mkApps in HA as (? & ? & ?). + split. eexists; eauto. + induction t0 in f |- *; econstructor; eauto; econstructor; eauto. +Qed. + +From MetaCoq.PCUIC Require Import PCUICProgress. + +Lemma firstorder_erases_deterministic X_type (X : X_type.π1) + univs wfext {v t' i u args} + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} + : + forall wv : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] v), + forall Σ, Σ ∼_ext Xext -> + Σ ;;; [] |- v : mkApps (tInd i u) args -> + Σ |-p v ⇓ v -> + @firstorder_ind Σ (firstorder_env Σ) i -> + erases Σ [] v t' -> + t' = erase X_type Xext (normalization_in:=normalization_in) [] v wv. +Proof. + intros wv Σ Hrel Hty Hvalue Hfo Herase. + destruct (firstorder_lookup_inv Hfo) as [mind Hdecl]. + assert (Hext : ∥ wf_ext Σ∥) by now eapply ErasureFunction.heΣ. + sq. eapply firstorder_value_spec in Hty as Hfov; eauto. + clear - Hrel Hext Hfov Herase. + revert t' wv Herase. + pattern v. + revert v Hfov. + eapply firstorder_value_inds. intros. + rewrite erase_mkApps. + - intros Σ0 HΣ0. pose proof (abstract_env_ext_irr _ HΣ0 Hrel). subst. + eapply PCUICValidity.inversion_mkApps in X0 as (? & XX & Happ). + clear XX. revert Happ. clear. generalize (mkApps (tInd i u) pandi). induction 1. + + do 2 econstructor. + + destruct IHHapp. do 2 econstructor. econstructor; eauto. eauto. + - intros. eapply erases_mkApps_inv in Herase as [(? & ? & ? & -> & [Herasable] & ? & ? & ->)|(? & ? & -> & ? & ?)]. all:eauto. + + exfalso. eapply isErasable_Propositional in Herasable; eauto. now rewrite Herasable in H1. + + inv H2. + * cbn. unfold erase_clause_1. destruct (inspect_bool (is_erasableb X_type Xext [] (tConstruct i n ui) Hyp0)). + -- exfalso. sq. destruct (@is_erasableP _ _ _ [] (tConstruct i n ui) Hyp0) => //. + specialize_Σ Hrel. sq. + eapply (isErasable_Propositional (args := [])) in s; eauto. + now rewrite s in H1. + -- f_equal. eapply Forall2_eq. clear X0 H wv. induction H3. + ++ cbn. econstructor. + ++ cbn. econstructor. + ** inv H0. eapply H5. eauto. + ** inv H0. eapply IHForall2. eauto. + * exfalso. eapply (isErasable_Propositional (args := [])) in X1; eauto. + now rewrite X1 in H1. + - eauto. + - intros ? ? H3. assert (Hext_ : ∥ wf_ext Σ0∥) by now eapply ErasureFunction.heΣ. + sq. + specialize_Σ H2. + eapply (isErasable_Propositional) in H3; eauto. + pose proof (abstract_env_ext_irr _ H2 Hrel). subst. + now rewrite H3 in H1. + - intros. assert (Hext__ : ∥ wf_ext Σ0∥) by now eapply ErasureFunction.heΣ. + specialize_Σ H2. eapply welltyped_mkApps_inv in wv; eauto. eapply wv. + now sq. + Unshelve. all: try exact False. + - eapply PCUICWcbvEval.eval_to_value; eauto. +Qed. + +Lemma firstorder_evalue_extends Σ Σ' t : + extends Σ Σ' -> + firstorder_evalue Σ t -> + firstorder_evalue Σ' t. +Proof. + intros ext; move: t. + apply: firstorder_evalue_elim => i n args npars hl hf ih. + econstructor; tea. + red in ext. + move: hl; rewrite /lookup_inductive_pars /lookup_minductive. + move: (ext (inductive_mind i)). + now case: lookup_env => // a; move/(_ _ eq_refl) ->. +Qed. + +Lemma In_map_All {A B C : Type} {Q : C -> Type} {P : C -> A -> Prop} + (fn : forall x : A, (forall y : C, Q y -> P y x) -> B) (l : list A) (Hl : forall y : C, Q y -> ∥ All (P y) l ∥) : + forall x, In x l -> + exists D : forall y : C, Q y -> P y x, + In (fn x D) (map_All fn l Hl). +Proof. + induction l; cbn => //. + intros x []. + - subst. eexists; left; reflexivity. + - destruct (IHl (map_All_obligation_2 a l Hl) _ H). + eexists; now right. +Qed. + +Lemma In_term_global_deps t l : + In t l -> + forall kn, KernameSet.In kn (term_global_deps t) -> KernameSet.In kn (terms_global_deps l). +Proof. + induction l; cbn => //. + intros []. + - subst; intros kn hin; rewrite knset_in_fold_left. + left. eapply KernameSet.union_spec. now left. + - intros kn hin. specialize (IHl H). + rewrite knset_in_fold_left. right. now exists t. +Qed. + +Lemma erase_correct_strong' (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) + univs wfext {t v Σ' t' i u args} decls normalization_in prf + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} + : + forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), + forall Σ, abstract_env_ext_rel Xext Σ -> + axiom_free Σ -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> + @firstorder_ind Σ (firstorder_env Σ) i -> + erase X_type Xext [] t wt = t' -> + erase_global_deps X_type (term_global_deps t') X decls normalization_in prf = Σ' -> + red Σ [] t v -> + ¬ { t' & Σ ;;; [] |- v ⇝ t'} -> + forall wt', let ev := erase X_type Xext [] v wt' in ∥ Σ'.1 ⊢ t' ⇓ ev ∥ + /\ firstorder_evalue Σ'.1 ev. +Proof. + intros wt Σ Hrel Hax Hty Hfo <- <- Hred Hirred wt'. + destruct (firstorder_lookup_inv Hfo) as [mind Hdecl]. + destruct (abstract_env_exists X) as [[Σg Hg]]. + pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ Hg Hrel). subst Σ. + pose proof (ErasureFunction.heΣ _ _ _ Hrel) as [Hwf]. eapply wcbv_standardization_fst in Hty as Heval; eauto. + edestruct (erase_correct X_type X univs wfext t v) as [v' [H1 H2]]; eauto. + { eapply KernameSet.subset_spec; reflexivity. } + 1:{ intros ? H_. sq. enough (Σ = Σg) as -> by eauto. + pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ H_ Hrel). now subst. } + eapply firstorder_erases_deterministic in H1; eauto. + simpl. + destruct H2. split; [sq; tea|]. rewrite -> H1 in e. exact e. + assert (PCUICFirstorder.firstorder_value (Σg, univs) [] v). + { destruct (wfext Σg Hg). eapply PCUICFirstorder.firstorder_value_spec; tea. apply X0. constructor. + eapply PCUICClassification.subject_reduction_eval; tea. + eapply PCUICWcbvEval.eval_to_value; tea. } + { rewrite H1 in e. eapply erase_global_deps_eval in e. + eapply firstorder_evalue_extends; tea. clear e. + clear -Hrel H Hg Hwf. move: v H wt'. + apply: PCUICFirstorder.firstorder_value_inds. + intros i n ui u args pandi hty hf ih isp wt'. + rewrite erase_mkApps //. + { intros ? h; specialize (wt' _ h). eapply welltyped_mkApps_inv in wt' as [? ?] => //. destruct (abstract_env_ext_wf _ h). + now sq; eapply Forall_All. pose proof (abstract_env_ext_wf _ h). now sq. } + 2:{ intros Σ hΣ [ise]. pose proof (abstract_env_ext_irr _ Hrel hΣ). subst Σ. + eapply isErasable_Propositional in ise => //. + cbn in isp, ise. now rewrite ise in isp. } + 2:{ intros Σ hΣ. pose proof (abstract_env_ext_irr _ Hrel hΣ). subst Σ. + pose proof (iswelltyped hty). + now eapply welltyped_mkApps_inv in H. } + intros. simp erase. + destruct inspect_bool; simp erase. + move/is_erasableP: i0. intros hc. + destruct (hc _ Hrel). eapply (isErasable_Propositional (args:=[])) in X0 => //. cbn in X0, isp => //. + rewrite X0 in isp => //. + eapply PCUICInductiveInversion.Construct_Ind_ind_eq' in hty as [mdecl [idecl [cdecl [declc _]]]] => //=. + set (v := E.mkApps _ _). + eapply (erase_global_declared_constructor _ _ _ _ _ _ _ (term_global_deps v) decls normalization_in prf) in declc; tea. + destruct declc as [[hm hi] hc]. + 2:{ rewrite /v /= term_global_deps_mkApps. destruct i => /=. eapply KernameSet.union_spec; left. now eapply KernameSet.singleton_spec. } + 2:{ eapply Hwf. } + econstructor. + { rewrite /lookup_inductive_pars /lookup_minductive hm /= //. } + eapply Forall_skipn. + clear -ih Hrel isp. + { revert v. rewrite erase_terms_eq => v. + eapply Forall_All in ih. + assert (All + (fun t : term => + forall wt' : forall Σ : global_env_ext, Σ ∼_ext Xext -> welltyped Σ [] t, + firstorder_evalue + (erase_global_deps X_type (term_global_deps v) X decls + normalization_in prf).1 (erase X_type Xext [] t wt')) args). + { eapply In_All. intros x hin wt. + eapply All_In in ih; tea. destruct ih as [ih]. + specialize (ih wt). + eapply firstorder_evalue_extends; tea. + subst v. eapply lookup_erase_global. + rewrite term_global_deps_mkApps. + intros kn hin'. eapply KernameSet.union_spec; right. + destruct (In_map_All (erase X_type (abstract_make_wf_env_ext X univs wfext) []) _ Hyp1 _ hin). + eapply In_term_global_deps; tea. + erewrite (erase_irrel _ _).1; tea. } + eapply All_Forall, All_map_All. + { intros. exact X0. } + cbn. intros x y rx h. apply h. exact Hrel. } } + { eapply subject_reduction; eauto. } + { eapply PCUICWcbvEval.value_final. eapply PCUICWcbvEval.eval_to_value. eauto. } + all: eauto. + Unshelve. eauto. +Qed. + +Lemma erase_correct_strong (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) + univs wfext {t v i u args} decls normalization_in prf + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ} + : forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), + forall Σ, abstract_env_ext_rel Xext Σ -> + axiom_free Σ -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> + let t' := erase X_type Xext [] t wt in + let Σ' := erase_global_deps X_type (term_global_deps t') X decls normalization_in prf in + @firstorder_ind Σ (firstorder_env Σ) i -> + red Σ [] t v -> + ¬ { v' & Σ ;;; [] |- v ⇝ v'} -> + exists wt', let et' := erase X_type Xext [] v wt' in + ∥ Σ'.1 ⊢ t' ⇓ erase X_type Xext [] v wt' ∥ /\ firstorder_evalue Σ'.1 et'. +Proof. + intros wt Σ Hrel Hax Hty Hdecl Hfo Hsub Hred Hirred. + unshelve eexists. + - abstract (intros Σ_ H_; pose proof (ErasureFunction.heΣ _ _ _ H_); sq; + pose proof (abstract_env_ext_irr _ H_ Hrel); subst; eapply red_welltyped; eauto; econstructor; eauto). + - eapply erase_correct_strong'; eauto. + all:reflexivity. +Qed. + +Lemma unique_decls {X_type} {X : X_type.π1} univs wfext +(Xext := abstract_make_wf_env_ext X univs wfext) {Σ'} (wfΣ' : Σ' ∼_ext Xext) : + forall Σ, Σ ∼ X -> declarations Σ = declarations Σ'. +Proof. + intros Σ wfΣ. pose (abstract_make_wf_env_ext_correct X univs wfext Σ Σ' wfΣ wfΣ'). + rewrite e. reflexivity. +Qed. + +Lemma unique_type {X_type : abstract_env_impl} {X : X_type.π2.π1} + {Σ:global_env_ext} + (wfΣ : Σ ∼_ext X) {t T}: + Σ ;;; [] |- t : T -> forall Σ, Σ ∼_ext X -> welltyped Σ [] t. +Proof. + intros wt Σ' wfΣ'. erewrite (abstract_env_ext_irr X wfΣ' wfΣ). + now exists T. +Qed. + +Definition erase_correct_firstorder (wfl := Ee.default_wcbv_flags) + X_type (X : X_type.π1) univs wfext {t v i u args} + (Xext := abstract_make_wf_env_ext X univs wfext) + {normalization_in : forall X Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} : + forall Σ (wfΣ : abstract_env_ext_rel Xext Σ) + (wt : Σ ;;; [] |- t : mkApps (tInd i u) args), + axiom_free Σ -> + let t' := erase X_type Xext [] t (unique_type wfΣ wt) in + let decls := declarations (fst Σ) in + let Σ' := erase_global_deps X_type (term_global_deps t') X decls + (fun _ _ _ _ _ _ _ => normalization_in _ _) (unique_decls univs wfext wfΣ) in + @firstorder_ind Σ (firstorder_env Σ) i -> + red Σ [] t v -> + ¬ { v' & Σ ;;; [] |- v ⇝ v'} -> + exists wt', let et' := erase X_type Xext [] v wt' in ∥ Σ'.1 ⊢ t' ⇓ et' ∥ /\ + firstorder_evalue Σ'.1 et'. +Proof. + intros. + eapply erase_correct_strong; eauto. +Qed. + +(* we use the [match] trick to get typeclass resolution to pick up the right instances without leaving any evidence in the resulting term, and without having to pass them manually everywhere *) +Notation NormalizationIn_erase_global_deps_fast X decls + := (match extraction_checker_flags, extraction_normalizing return _ with + | cf, no + => forall n, + n < List.length decls -> + forall kn cb pf, + List.hd_error (List.skipn n decls) = Some (kn, ConstantDecl cb) -> + let Xext := abstract_make_wf_env_ext X (cst_universes cb) pf in + forall Σ, wf_ext Σ -> Σ ∼_ext Xext -> NormalizationIn Σ + end) + (only parsing). + + +Section EraseGlobalFast. + + Import PCUICEnvironment. + +Definition decls_prefix decls (Σ' : global_env) := + ∑ Σ'', declarations Σ' = Σ'' ++ decls. + +Lemma on_global_decls_prefix {cf} Pcmp P univs retro decls decls' : + PCUICAst.on_global_decls Pcmp P univs retro (decls ++ decls') -> + PCUICAst.on_global_decls Pcmp P univs retro decls'. +Proof using Type. + induction decls => //. + intros ha; depelim ha. + now apply IHdecls. +Qed. + +Lemma decls_prefix_wf {decls Σ} : + decls_prefix decls Σ -> wf Σ -> wf {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |}. +Proof using Type. + intros [Σ' hd] wfΣ. + split. apply wfΣ. + cbn. destruct wfΣ as [_ ond]. rewrite hd in ond. + now eapply on_global_decls_prefix in ond. +Qed. + +Lemma incl_cs_refl cs : cs ⊂_cs cs. +Proof using Type. + split; [lsets|csets]. +Qed. + +Lemma weaken_prefix {decls Σ kn decl} : + decls_prefix decls Σ -> + wf Σ -> + lookup_env {| universes := Σ; declarations := decls; retroknowledge := Σ.(retroknowledge) |} kn = Some decl -> + on_global_decl cumulSpec0 (lift_typing typing) (Σ, universes_decl_of_decl decl) kn decl. +Proof using Type. + intros prefix wfΣ. + have wfdecls := decls_prefix_wf prefix wfΣ. + epose proof (weakening_env_lookup_on_global_env (lift_typing typing) _ Σ kn decl + weaken_env_prop_typing wfΣ wfdecls). + forward X. apply extends_strictly_on_decls_extends, strictly_extends_decls_extends_strictly_on_decls. red; split => //. + now apply (X wfdecls). +Qed. + + +(* This version of global environment erasure keeps the same global environment throughout the whole + erasure, while folding over the list of declarations. *) + +Local Obligation Tactic := program_simpl. + +Program Fixpoint erase_global_deps_fast (deps : KernameSet.t) + X_type (X:X_type.π1) (decls : global_declarations) + {normalization_in : NormalizationIn_erase_global_deps_fast X decls} + (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations * KernameSet.t := + match decls with + | [] => ([],deps) + | (kn, ConstantDecl cb) :: decls => + if KernameSet.mem kn deps then + let Xext' := abstract_make_wf_env_ext X (cst_universes cb) _ in + let normalization_in' : @id Prop _ := _ in (* hack to avoid program erroring out on unresolved tc *) + let cb' := @erase_constant_body X_type Xext' normalization_in' cb _ in + let deps := KernameSet.union deps (snd cb') in + let Σ' := erase_global_deps_fast deps X_type X decls _ in + (((kn, E.ConstantDecl (fst cb')) :: Σ'.1), Σ'.2) + else + erase_global_deps_fast deps X_type X decls _ + + | (kn, InductiveDecl mib) :: decls => + if KernameSet.mem kn deps then + let mib' := erase_mutual_inductive_body mib in + let Σ' := erase_global_deps_fast deps X_type X decls _ in + (((kn, E.InductiveDecl mib') :: Σ'.1), Σ'.2) + else erase_global_deps_fast deps X_type X decls _ + end. +Next Obligation. + pose proof (abstract_env_wf _ H) as [?]. + specialize_Σ H. sq. split. cbn. apply X3. cbn. + eapply decls_prefix_wf in X3; tea. + destruct X3 as [onu ond]. cbn in ond. + depelim ond. now destruct o. +Qed. +Next Obligation. + cbv [id]. + unshelve eapply (normalization_in 0); cbn; try reflexivity; try lia. +Defined. +Next Obligation. + pose proof (abstract_env_ext_wf _ H) as [?]. + pose proof (abstract_env_exists X) as [[? wf]]. + pose proof (abstract_env_wf _ wf) as [?]. + pose proof (prop' := prop _ wf). + sq. eapply (weaken_prefix (kn := kn)) in prop'; tea. + 2:{ cbn. rewrite eqb_refl //. } + epose proof (abstract_make_wf_env_ext_correct X (cst_universes cb) _ _ _ wf H). subst. + apply prop'. +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + specialize_Σ H. sq; red. destruct prop as [Σ' ->]. + eexists (Σ' ++ [(kn, ConstantDecl cb)]); rewrite -app_assoc //. +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + specialize_Σ H. sq; red. destruct prop as [Σ' ->]. + eexists (Σ' ++ [(kn, ConstantDecl cb)]); rewrite -app_assoc //. +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + specialize_Σ H. sq; red. destruct prop as [Σ' ->]. + eexists (Σ' ++ [(kn, _)]); rewrite -app_assoc //. +Qed. +Next Obligation. + unshelve eapply (normalization_in (S _)); cbn in *; revgoals; try eassumption; lia. +Defined. +Next Obligation. + specialize_Σ H. sq; red. destruct prop as [Σ' ->]. + eexists (Σ' ++ [(kn, _)]); rewrite -app_assoc //. +Qed. + +Import PCUICAst PCUICEnvironment. + +Lemma wf_lookup Σ kn d suffix g : + wf Σ -> + declarations Σ = suffix ++ (kn, d) :: g -> + lookup_env Σ kn = Some d. +Proof using Type. + unfold lookup_env. + intros [_ ond] eq. rewrite eq in ond |- *. + move: ond; clear. + induction suffix. + - cbn. rewrite eqb_refl //. + - cbn. intros ond. + depelim ond. destruct o as [f ? ? ? ]. cbn. red in f. + eapply Forall_app in f as []. depelim H0. cbn in H0. + destruct (eqb_spec kn kn0); [contradiction|]. + now apply IHsuffix. +Qed. + +Definition add_suffix suffix Σ := set_declarations Σ (suffix ++ Σ.(declarations)). + +Lemma add_suffix_cons d suffix Σ : add_suffix (d :: suffix) Σ = add_global_decl (add_suffix suffix Σ) d. +Proof using Type. reflexivity. Qed. + +Lemma global_erased_with_deps_weaken_prefix suffix Σ Σ' kn : + wf (add_suffix suffix Σ) -> + global_erased_with_deps Σ Σ' kn -> + global_erased_with_deps (add_suffix suffix Σ) Σ' kn. +Proof using Type. + induction suffix. + - unfold add_suffix; cbn. intros wf hg. + now rewrite /set_declarations /= -eta_global_env. + - rewrite add_suffix_cons. intros wf H. + destruct a as [kn' d]. eapply global_erases_with_deps_weaken => //. + apply IHsuffix => //. + destruct wf as [onu ond]. now depelim ond. +Qed. + + +(* Using weakening it is trivial to show that a term found to be erasable in Σ + will be found erasable in any well-formed extension. The converse is not so trivial: + some valid types in the extension are not valid in the restricted global context. + So, we will rather show that the erasure function is invariant under extension. *) + +Lemma isErasable_irrel_global_env {Σ Σ' : global_env_ext} {Γ t} : + wf Σ -> + wf Σ' -> + extends Σ' Σ -> + Σ.2 = Σ'.2 -> + isErasable Σ' Γ t -> isErasable Σ Γ t. +Proof using Type. + unfold isErasable. + intros wfΣ wfΣ' ext eqext [T [ht isar]]. + destruct Σ as [Σ decl], Σ' as [Σ' decl']. cbn in eqext; subst decl'. + exists T; split. + eapply (env_prop_typing weakening_env (Σ', decl)) => //=. + destruct isar as [|s]; [left|right] => //. + destruct s as [u [Hu isp]]. + exists u; split => //. + eapply (env_prop_typing weakening_env (Σ', decl)) => //=. +Qed. + +Definition reduce_stack_eq {cf} {fl} {no:normalizing_flags} {X_type : abstract_env_impl} {X : X_type.π2.π1} {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t π wi : reduce_stack fl X_type X Γ t π wi = ` (reduce_stack_full fl X_type X Γ t π wi). +Proof using Type. + unfold reduce_stack. destruct reduce_stack_full => //. +Qed. + +Definition same_principal_type {cf} + {X_type : abstract_env_impl} {X : X_type.π2.π1} + {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} + {Γ : context} {t} (p : PCUICSafeRetyping.principal_type X_type X Γ t) (p' : PCUICSafeRetyping.principal_type X_type' X' Γ t) := + p.π1 = p'.π1. + +(*Lemma erase_global_deps_suffix {deps} {Σ Σ' : wf_env} {decls hprefix hprefix'} : + wf Σ -> wf Σ' -> + universes Σ = universes Σ' -> + erase_global_deps_fast deps Σ decls hprefix = + erase_global_deps_fast deps Σ' decls hprefix'. +Proof using Type. + intros wfΣ wfΣ' equ. + induction decls in deps, hprefix, hprefix' |- *; cbn => //. + destruct a as [kn []]. + set (obl := (erase_global_deps_fast_obligation_1 Σ ((kn, ConstantDecl c) :: decls) + hprefix kn c decls eq_refl)). clearbody obl. + destruct obl. + set (eb := erase_constant_body _ _ _). + set (eb' := erase_constant_body _ _ _). + assert (eb = eb') as <-. + { subst eb eb'. + set (wfΣx := abstract_make_wf_env_ext _ _ _). + set (wfΣ'x := abstract_make_wf_env_ext _ _ _). + set (obl' := erase_global_deps_fast_obligation_2 _ _ _ _ _ _ _). + clearbody obl'. + set (Σd := {| universes := Σ.(universes); declarations := decls |}). + assert (wfΣd : wf Σd). + { eapply decls_prefix_wf; tea. + clear -hprefix. move: hprefix. unfold decls_prefix. + intros [Σ'' eq]. exists (Σ'' ++ [(kn, ConstantDecl c)]). + rewrite -app_assoc //. } + set (wfΣdwfe := build_wf_env_from_env _ (sq wfΣd)). + assert (wfextΣd : wf_ext (Σd, cst_universes c)). + { split => //. cbn. apply w. } + set (wfΣdw := abstract_make_wf_env_ext wfΣdwfe (cst_universes c) (sq wfextΣd)). + assert (ond' : ∥ on_constant_decl (lift_typing typing) (Σd, cst_universes c) c ∥ ). + { pose proof (decls_prefix_wf hprefix wfΣ). + destruct X as [onu ond]. depelim ond. sq. apply o0. } + assert (extd' : extends_decls Σd Σ). + { clear -hprefix. move: hprefix. + intros [? ?]. split => //. eexists (x ++ [(kn, ConstantDecl c)]). cbn. + now rewrite -app_assoc. } + assert (extd'' : extends_decls Σd Σ'). + { clear -equ hprefix'. move: hprefix'. + intros [? ?]. split => //. eexists (x ++ [(kn, ConstantDecl c)]). cbn. + now rewrite -app_assoc. } + rewrite (erase_constant_suffix (Σ := wfΣx) (Σ' := wfΣdw) (ondecl' := ond') wfΣ extd') //. + rewrite (erase_constant_body_irrel (Σ := wfΣ'x) (Σ' := wfΣdw) (ondecl' := ond') wfΣ' extd'') //. } + destruct KernameSet.mem => //. f_equal. + eapply IHdecls. + destruct KernameSet.mem => //. f_equal. + eapply IHdecls. +Qed.*) + +Lemma strictly_extends_decls_extends_global_env Σ Σ' : + wf Σ' -> + strictly_extends_decls Σ Σ' -> + extends_global_env Σ Σ'. +Proof. + intros wfΣ' [uni [Σ'' de] retr]. red. + cbn. unfold lookup_env. rewrite de /primitive_constant retr. + split => //. intros kn decl. + intros hl. + apply lookup_global_Some_iff_In_NoDup. + apply EnvMap.EnvMap.fresh_globals_iff_NoDup. + rewrite -de. now apply wf_fresh_globals. + apply lookup_global_Some_iff_In_NoDup in hl. + apply in_app_iff. now right. + apply EnvMap.EnvMap.fresh_globals_iff_NoDup. + apply wf_fresh_globals in wfΣ'. rewrite de in wfΣ'. + clear -wfΣ'. induction Σ''; auto. apply IHΣ''. + now depelim wfΣ'. +Qed. + +Lemma extends_global_env_equiv_env Σ Σ' : + extends_global_env Σ Σ' -> equiv_env_inter Σ Σ'. +Proof. + intros ext. split. intros kn decl decl' hl hl'. + destruct ext. apply H in hl. congruence. + now destruct ext. +Qed. + +Lemma erase_global_deps_fast_spec_gen {deps} + {X_type X X'} {decls normalization_in normalization_in' hprefix hprefix'} : + (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = + erase_global_deps X_type deps X' decls normalization_in' hprefix'. +Proof using Type. + intros equ. + induction decls in X, X', equ, deps, normalization_in, normalization_in', hprefix, hprefix' |- * => //. + pose proof (abstract_env_exists X) as [[Σ wfΣ]]. + pose proof (abstract_env_exists X') as [[Σ' wfΣ']]. + pose proof (abstract_env_wf _ wfΣ) as [wf]. + pose proof (abstract_env_exists (abstract_pop_decls X')) as [[? wfpop]]. + unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' wfpop) as [? [? ?]]. + { now eexists. } + + destruct a as [kn []]. + - cbn. unfold erase_constant_decl. + set (obl := (erase_global_deps_fast_obligation_1 X_type X ((kn, ConstantDecl c) :: decls) + _ hprefix kn c decls eq_refl)). + set (eb := erase_constant_body _ _ _ _). + set (eb' := erase_constant_body _ _ _ _). + set (eg := erase_global_deps _ _ _ _ _ _). + set (eg' := erase_global_deps _ _ _ _ _ _). + + assert (eb = eb') as <-. + { subst eb eb'. + destruct (hprefix _ wfΣ) as [[Σ'' eq]]. + eapply erase_constant_body_irrel; cbn => //. + eapply equiv_env_inter_hlookup. + intros ? ? H2 H3. + epose proof (abstract_make_wf_env_ext_correct X (cst_universes c) _ _ _ wfΣ H2). + epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wfpop H3). + subst. eapply equiv_env_inter_sym. + eapply extends_global_env_equiv_env. + pose proof (abstract_env_wf _ wfΣ) as []. + apply strictly_extends_decls_extends_global_env. + apply X0. red. + rewrite eq. rewrite <- H0, <- H1. split. cbn. symmetry; apply equ; eauto. + cbn. + eexists (Σ'' ++ [(kn, ConstantDecl c)]). cbn. subst. now rewrite -app_assoc. subst. + symmetry. now apply equ. } + destruct KernameSet.mem => //; f_equal; try eapply IHdecls. + f_equal. f_equal. eapply IHdecls. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + f_equal. eapply IHdecls. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + + - cbn. + destruct KernameSet.mem => //; f_equal; try eapply IHdecls. + f_equal; f_equal; eapply IHdecls. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } + intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros. + f_equal; eapply IHdecls. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } + intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros; unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } + intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. +Qed. + +Lemma erase_global_deps_fast_spec {deps} {X_type X} {decls normalization_in normalization_in' hprefix hprefix'} : + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = + erase_global_deps X_type deps X decls normalization_in' hprefix'. +Proof using Type. + eapply erase_global_deps_fast_spec_gen; intros. + rewrite (abstract_env_irr _ H H0); eauto. +Qed. + +Lemma cored_extends (Σ Σ' : global_env_ext) Γ x y : + wf Σ' -> + extends Σ Σ' -> + cored Σ Γ x y -> cored Σ' Γ x y. +Proof. + intros wf ext. + induction 1. + - constructor. + eapply PCUICWeakeningEnvConv.weakening_env_red1. apply wf. exact ext. + exact X. + - econstructor 2; tea. + eapply PCUICWeakeningEnvConv.weakening_env_red1. apply wf. + exact ext. + exact X. +Qed. + +Lemma normalization_in_extends (Σ Σ' : global_env) ext : + wf Σ -> wf Σ' -> + extends Σ' Σ -> + NormalizationIn (Σ, ext) -> NormalizationIn (Σ', ext). +Proof. + intros wfΣ wfΣ' extH nin. + red in nin. intros Γ t wt. + assert (welltyped (Σ, ext) Γ t). + { destruct wt. exists A. eapply (env_prop_typing weakening_env) in X; tea; cbn. } + specialize (nin _ _ H). clear H. + induction nin. + constructor. intros y r. + eapply H0. eapply cored_extends in r; tea. + eapply cored_welltyped; tea. +Qed. + +Lemma iter_abstract_pop_decls_correct {cf} {abstract_env_impl abstract_env_ext_impl : Type} + {abstract_env_struct0 : abstract_env_struct abstract_env_impl + abstract_env_ext_impl} : + abstract_env_prop abstract_env_impl abstract_env_ext_impl -> + forall (X : abstract_env_impl) (decls : list (kername × global_decl)) n, + (forall Σ : global_env, + Σ ∼ X -> exists decls', #|decls'| = n /\ declarations Σ = decls' ++ decls) -> + let X' := iter abstract_pop_decls n X in + forall Σ Σ' : global_env, + Σ ∼ X -> + Σ' ∼ X' -> + declarations Σ' = decls /\ universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ'. +Proof. + intros ap X decls. + induction n in X, decls |- *. cbn. + - intros hdecl Σ Σ' HX HX'. + specialize (hdecl _ HX) as [decls' [hlen hde]]. + destruct decls' => //. cbn in hde. + now rewrite -hde (abstract_env_irr _ HX HX'). + - intros hdecl X' Σ Σ' HX HX'. + specialize (hdecl _ HX) as [decls' [hlen hde]]. + destruct decls' => //; cbn in hde. + specialize (IHn (abstract_pop_decls X) decls). + pose proof (abstract_pop_decls_correct X (decls' ++ decls)). + forward H. + { intros ? h. rewrite -(abstract_env_irr _ HX h). now exists p. } + forward IHn. + { intros ? H0. now specialize (H _ _ HX H0). } + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop hpop]]. + specialize (IHn _ _ hpop HX'). + destruct IHn. split => //. + pose proof (abstract_pop_decls_correct X (decls' ++ decls)). + forward H2. + { intros ? hx. pose proof (abstract_env_irr _ hx HX). subst Σ0. now exists p. } + specialize (H2 _ _ HX hpop). destruct H2 as [? []]. + destruct H1. + split; congruence. +Qed. + +Lemma skipn_app_prefix {A} n (l l' : list A) : skipn (#|l| + n) (l ++ l') = skipn n l'. +Proof. + induction l; cbn; auto. +Qed. + +Lemma erase_global_deps_fast_erase_global_deps {deps} {X_type X} {decls normalization_in hprefix hprefix'} : + exists normalization_in', + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) hprefix = + erase_global_deps X_type deps X decls normalization_in' hprefix'. +Proof using Type. + unshelve eexists. + intros. + pose proof (abstract_env_exists X) as [[Σ' H']]. + pose proof (abstract_env_wf _ H') as []. + specialize (hprefix _ H') as [[Σ'' ?]]. + pose proof (abstract_env_exists (iter abstract_pop_decls (S n) X)) as [[? ?]]. + pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ a H1). noconf H2. + epose proof (iter_abstract_pop_decls_correct _ X (skipn (S n) (Σ'' ++ decls)) (S n)). + forward H2. { intros ? h. rewrite (abstract_env_irr _ h H'). exists (firstn (S n) (Σ'' ++ decls)). + rewrite firstn_skipn. split => //. rewrite firstn_length_le //. rewrite app_length. lia. } + specialize (H2 _ _ H' a) as [? []]. + eapply normalization_in_extends. exact X1. exact X0. + { eapply extends_decls_extends, strictly_extends_decls_extends_decls. + red. rewrite H2 H3 H4. split => //. exists (firstn (S n) (Σ'' ++ decls)). + now rewrite firstn_skipn. } + specialize (normalization_in n H kn cb). + assert (wf_ext (Σ', cst_universes cb)). + { split => //. cbn. rewrite H3. apply X0. } + assert (forall Σ : global_env, Σ ∼ X -> ∥ wf_ext (Σ, cst_universes cb) ∥). + { intros. pose proof (abstract_env_irr _ H' H5). now subst Σ'. } + unshelve eapply normalization_in; tea. + set (foo := abstract_make_wf_env_ext X (cst_universes cb) H5). + pose proof (abstract_env_ext_exists foo) as [[Σext hext]]. + epose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ H' hext). now subst Σext. + erewrite erase_global_deps_fast_spec; tea. reflexivity. +Qed. + +Definition erase_global_fast X_type deps X decls {normalization_in} (prf:forall Σ : global_env, abstract_env_rel X Σ -> declarations Σ = decls) := + erase_global_deps_fast deps X_type X decls (normalization_in:=normalization_in) (fun _ H => sq ([] ; prf _ H)). + +Lemma expanded_erase_global_fast (cf := config.extraction_checker_flags) deps + {X_type X decls normalization_in} {normalization_in':NormalizationIn_erase_global_deps X decls} {prf} : + forall Σ : global_env, abstract_env_rel X Σ -> + PCUICEtaExpand.expanded_global_env Σ -> + expanded_global_env (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. +Proof using Type. + unfold erase_global_fast. + erewrite erase_global_deps_fast_spec. + eapply expanded_erase_global. + Unshelve. all: eauto. +Qed. + +Lemma expanded_erase_fast (cf := config.extraction_checker_flags) + {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_deps X decls} univs wfΣ t wtp : + forall Σ : global_env, abstract_env_rel X Σ -> + PCUICEtaExpand.expanded Σ [] t -> + let X' := abstract_make_wf_env_ext X univs wfΣ in + forall (normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ), + let et := (erase X_type X' [] t wtp) in + let deps := EAstUtils.term_global_deps et in + expanded (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1 [] et. +Proof using Type. + intros Σ wf hexp X' normalization_in'. pose proof (abstract_env_wf _ wf) as [?]. + eapply (expanded_erases (Σ := (Σ, univs))); tea. + eapply (erases_erase (X := X')). + pose proof (abstract_env_ext_exists X') as [[? wfmake]]. + now rewrite <- (abstract_make_wf_env_ext_correct X univs _ _ _ wf wfmake). + cbn. unfold erase_global_fast. erewrite erase_global_deps_fast_spec => //. + eapply (erases_deps_erase (X := X) univs wfΣ); eauto. + Unshelve. all: eauto. +Qed. + +Lemma erase_global_fast_wf_glob X_type deps X decls normalization_in (normalization_in':NormalizationIn_erase_global_deps X decls) prf : + @wf_glob all_env_flags (erase_global_fast X_type deps X decls (normalization_in:=normalization_in) prf).1. +Proof using Type. + unfold erase_global_fast; erewrite erase_global_deps_fast_spec. + eapply erase_global_deps_wf_glob. + Unshelve. all: eauto. +Qed. + +Lemma erase_wellformed_fast (efl := all_env_flags) + {X_type X decls normalization_in prf} {normalization_in'':NormalizationIn_erase_global_deps X decls} univs wfΣ {Γ t} wt + (X' := abstract_make_wf_env_ext X univs wfΣ) + {normalization_in' : forall Σ, wf_ext Σ -> Σ ∼_ext X' -> NormalizationIn Σ} : + let t' := erase X_type X' Γ t wt in + wellformed (erase_global_fast X_type (term_global_deps t') X decls (normalization_in:=normalization_in) prf).1 #|Γ| t'. +Proof using Type. + intros. + cbn. unfold erase_global_fast. erewrite erase_global_deps_fast_spec. + eapply erase_wellformed_deps. + Unshelve. all: eauto. +Qed. + +End EraseGlobalFast. + +Fixpoint compile_value_erase (t : PCUICAst.term) (acc : list EAst.term) : EAst.term := + match t with + | PCUICAst.tApp f a => compile_value_erase f (compile_value_erase a [] :: acc) + | PCUICAst.tConstruct i n _ => EAst.mkApps (EAst.tConstruct i n []) acc + | _ => EAst.tVar "error" + end. + +Lemma compile_value_erase_mkApps i n ui args acc : + compile_value_erase (mkApps (tConstruct i n ui) args) acc = + EAst.mkApps (EAst.tConstruct i n []) (map (flip compile_value_erase []) args ++ acc). +Proof. + revert acc; induction args using rev_ind. + - cbn. auto. + - intros acc. rewrite PCUICAstUtils.mkApps_app /=. cbn. + now rewrite IHargs map_app /= -app_assoc /=. +Qed. + + +Lemma erases_firstorder Σ Γ t : + PCUICFirstorder.firstorder_value Σ Γ t -> + erases Σ Γ t (compile_value_erase t []). +Proof. + move: t. + apply: (PCUICFirstorder.firstorder_value_inds Σ Γ). + intros i n ui u args pandi hty hfo ih isp. + assert (Forall2 (erases Σ Γ) args (map (flip compile_value_erase []) args)). + { solve_all. eapply All_All2; tea. + cbn. intros x [fo hx]. exact hx. } + unshelve epose proof (erases_mkApps Σ Γ (tConstruct i n ui) (EAst.tConstruct i n []) args _ _ H). + now constructor. + now rewrite compile_value_erase_mkApps app_nil_r. +Qed. + +Lemma erases_firstorder' Σ Γ t : + wf_ext Σ -> + PCUICFirstorder.firstorder_value Σ Γ t -> + forall t', erases Σ Γ t t' -> t' = (compile_value_erase t []). +Proof. + intros wf. move: t. + apply: (PCUICFirstorder.firstorder_value_inds Σ Γ). + intros i n ui u args pandi hty hfo ih isp. + assert (Forall2 (erases Σ Γ) args (map (flip compile_value_erase []) args)). + { solve_all. eapply All_All2; tea. + cbn. intros x [fo hx]. now eapply erases_firstorder. } + unshelve epose proof (erases_mkApps Σ Γ (tConstruct i n ui) (EAst.tConstruct i n []) args _ _ H). + constructor => //. + rewrite compile_value_erase_mkApps app_nil_r. + intros t' ht'. + eapply erases_mkApps_inv in ht'. + destruct ht'. + { destruct H1 as [? [? [? [? [[] ?]]]]]. + eapply isErasable_Propositional in X => //. + now rewrite X in isp. } + destruct H1 as [f' [L' [-> [erc erargs]]]]. + depelim erc. f_equal. + solve_all. clear -erargs. + induction erargs => //. rewrite IHerargs. cbn. f_equal. + destruct r as [[] ?]. eapply e in e0. now unfold flip. + eapply (isErasable_Propositional (args := [])) in X => //. + now rewrite X in isp. +Qed. diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v index 39c2ddbac..0d304219a 100644 --- a/erasure/theories/Extract.v +++ b/erasure/theories/Extract.v @@ -1,9 +1,9 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import Program. +From Coq Require Import Program ssrbool. From MetaCoq.Utils Require Import utils. From MetaCoq.Common Require Import config Primitive. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive PCUICTyping - PCUICElimination PCUICWcbvEval. + PCUICElimination PCUICWcbvEval PCUICFirstorder. From MetaCoq.Erasure Require EAst EGlobalEnv. Module E := EAst. @@ -13,18 +13,6 @@ Local Existing Instance extraction_checker_flags. Definition isErasable Σ Γ t := ∑ T, Σ ;;; Γ |- t : T × (isArity T + (∑ u, (Σ ;;; Γ |- T : tSort u) * is_propositional u))%type. -Definition isPropositionalArity ar b := - match destArity [] ar with - | Some (_, s) => is_propositional s = b - | None => False - end. - -Definition isPropositional Σ ind b := - match lookup_inductive Σ ind with - | Some (mdecl, idecl) => isPropositionalArity idecl.(ind_type) b - | _ => False - end. - Fixpoint mkAppBox c n := match n with | 0 => c @@ -64,7 +52,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : | erases_tConst : forall (kn : kername) (u : Instance.t), Σ;;; Γ |- tConst kn u ⇝ℇ E.tConst kn | erases_tConstruct : forall (kn : inductive) (k : nat) (n : Instance.t), - isPropositional Σ kn false -> + ~~ isPropositional Σ kn -> Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k [] | erases_tCase (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) (c' : E.term) @@ -124,7 +112,7 @@ Lemma erases_forall_list_ind (Hconst : forall Γ kn u, P Γ (tConst kn u) (E.tConst kn)) (Hconstruct : forall Γ kn k n, - isPropositional Σ kn false -> + ~~ isPropositional Σ kn -> P Γ (tConstruct kn k n) (E.tConstruct kn k [])) (Hcase : forall Γ ci p c brs c' brs', PCUICElimination.Subsingleton Σ ci.(ci_ind) -> @@ -220,7 +208,7 @@ Definition erases_one_inductive_body (oib : one_inductive_body) (oib' : E.one_in Forall2 (fun 'i i' => i.(PCUICEnvironment.proj_name) = i'.(E.proj_name)) oib.(ind_projs) oib'.(E.ind_projs) /\ oib'.(E.ind_name) = oib.(ind_name) /\ oib'.(E.ind_kelim) = oib.(ind_kelim) /\ - isPropositionalArity oib.(ind_type) oib'.(E.ind_propositional). + isPropositionalArity oib.(ind_type) = oib'.(E.ind_propositional). Definition erases_mutual_inductive_body (mib : mutual_inductive_body) (mib' : E.mutual_inductive_body) := let bds := mib.(ind_bodies) in diff --git a/erasure/theories/Typed/ErasureCorrectness.v b/erasure/theories/Typed/ErasureCorrectness.v index 70272cbf9..45d392b0e 100644 --- a/erasure/theories/Typed/ErasureCorrectness.v +++ b/erasure/theories/Typed/ErasureCorrectness.v @@ -5,7 +5,7 @@ From Equations Require Import Equations. From MetaCoq.Erasure Require Import EDeps. From MetaCoq.Erasure Require Import ESubstitution. From MetaCoq.Erasure Require Import Extract. -From MetaCoq.Erasure Require Import ErasureFunction. +From MetaCoq.Erasure Require Import ErasureFunction ErasureFunctionProperties. From MetaCoq.PCUIC Require Import PCUICAstUtils. From MetaCoq.PCUIC Require Import PCUICSR. From MetaCoq.PCUIC Require Import PCUICTyping. @@ -76,10 +76,6 @@ Proof. cbn. constructor; [easy|]. apply IHl. - - destruct wf as [(i & [])]. - unfold isPropositionalArity. - rewrite ind_arity_eq. - now rewrite !destArity_it_mkProd_or_LetIn. Qed. Lemma erase_ind_correct Σ wfΣ kn mib wf : @@ -100,6 +96,7 @@ Qed. End ECorrect. Opaque erase_type flag_of_type ErasureFunction.wf_reduction. + Lemma erase_global_decls_deps_recursive_correct decls univs retro wfΣ include ignore_deps : let Σ := mk_global_env univs decls retro in (forall k, ignore_deps k = false) -> diff --git a/erasure/theories/Typed/ExtractionCorrectness.v b/erasure/theories/Typed/ExtractionCorrectness.v index c4ffc361c..6eb8525f8 100644 --- a/erasure/theories/Typed/ExtractionCorrectness.v +++ b/erasure/theories/Typed/ExtractionCorrectness.v @@ -9,6 +9,7 @@ From MetaCoq.Erasure.Typed Require Import WcbvEvalAux. From Equations Require Import Equations. From MetaCoq.Erasure Require Import ErasureCorrectness. From MetaCoq.Erasure Require Import ErasureFunction. +From MetaCoq.Erasure Require Import ErasureFunctionProperties. From MetaCoq.Erasure Require Import EWcbvEval. From MetaCoq.Erasure Require Import Extract. From MetaCoq.PCUIC Require Import PCUICAstUtils. diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index 758a4a2cc..a72c8362e 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -98,18 +98,16 @@ Section cf. Context {cf : config.checker_flags}. -Definition isPropositional Σ ind b := - match lookup_env Σ (inductive_mind ind) with - | Some (InductiveDecl mdecl) => - match nth_error mdecl.(ind_bodies) (inductive_ind ind) with - | Some idecl => - match destArity [] idecl.(ind_type) with - | Some (_, s) => is_propositional s = b - | None => False - end - | None => False - end - | _ => False +Definition isPropositionalArity ar := + match destArity [] ar with + | Some (_, s) => is_propositional s + | None => false + end. + +Definition isPropositional Σ ind := + match lookup_inductive Σ ind with + | Some (mdecl, idecl) => isPropositionalArity idecl.(ind_type) + | _ => false end. Inductive firstorder_value Σ Γ : term -> Prop := @@ -117,7 +115,7 @@ Inductive firstorder_value Σ Γ : term -> Prop := Σ ;;; Γ |- mkApps (tConstruct i n ui) args : mkApps (tInd i u) pandi -> Forall (firstorder_value Σ Γ) args -> - isPropositional Σ i false -> + ~~ isPropositional Σ i -> firstorder_value Σ Γ (mkApps (tConstruct i n ui) args). Lemma firstorder_value_inds : @@ -127,7 +125,7 @@ Lemma firstorder_value_inds : Σ;;; Γ |- mkApps (tConstruct i n ui) args : mkApps (tInd i u) pandi -> Forall (firstorder_value Σ Γ) args -> Forall P args -> - isPropositional (PCUICEnvironment.fst_ctx Σ) i false -> + ~~ isPropositional (PCUICEnvironment.fst_ctx Σ) i -> P (mkApps (tConstruct i n ui) args)) -> forall t : term, firstorder_value Σ Γ t -> P t. Proof using Type. @@ -139,21 +137,21 @@ Qed. Lemma firstorder_ind_propositional {Σ : global_env_ext} {wfΣ:wf Σ} i mind oind : declared_inductive Σ i mind oind -> @firstorder_ind Σ (firstorder_env Σ) i -> - isPropositional Σ i false. + ~~ isPropositional Σ i. Proof using Type. intros d. unshelve epose proof (d_ := declared_inductive_to_gen d); eauto. pose proof d_ as [d1 d2]. intros H. red in d1. unfold firstorder_ind in H. - red. sq. + unfold isPropositional. unfold PCUICEnvironment.fst_ctx in *. rewrite d1 in H |- *. - solve_all. unfold firstorder_mutind in H. - rewrite d2. move/andP: H => [ind H0]. + rewrite /lookup_inductive /lookup_inductive_gen /lookup_minductive_gen /= d1 d2. + move/andP: H => [ind H0]. eapply forallb_nth_error in H0; tea. erewrite d2 in H0. cbn in H0. unfold firstorder_oneind in H0. solve_all. destruct (ind_sort oind) eqn:E2; inv H0. eapply PCUICInductives.declared_inductive_type in d. - rewrite d. rewrite E2. + rewrite d. rewrite E2. unfold isPropositionalArity. now rewrite destArity_it_mkProd_or_LetIn. Qed. From 915ce93fb1641e227e1318fba70f33e20bbb41ed Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 8 Sep 2023 17:29:53 +0200 Subject: [PATCH 50/65] We're missing preservation of eta-expandedness by reduction in PCUIC... --- erasure-plugin/theories/ErasureCorrectness.v | 23 +++- pcuic/theories/PCUICEtaExpand.v | 11 +- pcuic/theories/PCUICWcbvEval.v | 130 ++++++++++++++++++- 3 files changed, 157 insertions(+), 7 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 5b32b75a6..87e8f948f 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -870,6 +870,19 @@ Admitted. Arguments PCUICFirstorder.firstorder_ind _ _ : clear implicits. +Section PCUICExpandLets. + Import PCUICExpandLets PCUICExpandLetsCorrectness. + + Lemma trans_axiom_free Σ : axiom_free Σ -> axiom_free (trans_global_env Σ). + Proof. + intros ax kn decl. + rewrite /trans_global_env /= /PCUICAst.declared_constant /= /trans_global_decls. + intros h; apply PCUICElimination.In_map in h as [[kn' decl'] [hin heq]]. + noconf heq. destruct decl'; noconf H. + apply ax in hin. + destruct c as [? [] ? ?] => //. + Qed. + Section pipeline_theorem. Instance cf : checker_flags := extraction_checker_flags. @@ -910,7 +923,7 @@ Section pipeline_theorem. - red. cbn. split; eauto. eexists. eapply PCUICClassification.subject_reduction_eval; eauto. - - todo "preservation of eta expandedness". + - todo "preservation of eta expandedness". - cbn. todo "normalization". - todo "normalization". Qed. @@ -1052,8 +1065,12 @@ Section pipeline_theorem. unfold erase_pcuic_program. cbn [fst snd]. exact obs. clear obs b0 ev e w. eapply extends_erase_pcuic_program. cbn. - eapply (PCUICExpandLetsCorrectness.trans_wcbveval (Σ := (Σ.1, Σ.2))). admit. exact X0. - cbn. 2:cbn. 3:cbn. + eapply (PCUICExpandLetsCorrectness.trans_wcbveval (Σ := (Σ.1, Σ.2))). + { clear -HΣ typing. now eapply PCUICClosedTyp.subject_closed in typing. } + cbn. 2:cbn. 3:cbn. exact X0. + + + Admitted. Lemma verified_erasure_pipeline_lambda : diff --git a/pcuic/theories/PCUICEtaExpand.v b/pcuic/theories/PCUICEtaExpand.v index f6c9f6cab..b4db67093 100644 --- a/pcuic/theories/PCUICEtaExpand.v +++ b/pcuic/theories/PCUICEtaExpand.v @@ -1,7 +1,7 @@ From Coq Require Import ssreflect. From Equations Require Import Equations. From MetaCoq.Utils Require Import utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICProgram. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICProgram PCUICCSubst. Definition isConstruct t := match t with tConstruct _ _ _ => true | _ => false end. @@ -341,6 +341,14 @@ Proof. solve_all. Qed. +Lemma csubst_mkApps a k f l : + csubst a k (mkApps f l) = mkApps (csubst a k f) (map (csubst a k) l). +Proof. + induction l in f |- *; cbn; [auto|]. + rewrite IHl. + now cbn. +Qed. + Lemma All_fold_tip {A : Type} (P : list A -> A -> Type) {x} : All_fold P [x] -> P [] x. Proof. intros a; now depelim a. @@ -425,3 +433,4 @@ Proof. solve_all. } all:intros; try solve [econstructor; eauto 1; solve_all; try now rewrite app_assoc]. Qed. + diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index bb3481dd7..93adfe7fd 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -4,7 +4,7 @@ From MetaCoq.Common Require Import config. From MetaCoq.Utils Require Import utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICGlobalEnv PCUICReduction PCUICClosed PCUICCSubst - PCUICClosedTyp. (* Due to reliance on wf Σ instead of closed_env Σ *) + PCUICClosedTyp PCUICEtaExpand. (* Due to reliance on wf Σ instead of closed_env Σ *) Require Import ssreflect ssrbool. From Equations Require Import Equations. @@ -24,14 +24,23 @@ From Equations Require Import Equations. Local Ltac inv H := inversion H; subst. +Lemma nApp_mkApps t f args : + t = mkApps f args -> ~~ isApp t -> t = f /\ args = []. +Proof. + intros -> napp. + destruct args using rev_case; cbn in *; solve_discr; try discriminate => //. split => //. + now rewrite mkApps_app /= in napp. +Qed. + Ltac solve_discr := try progress (prepare_discr; finish_discr; cbn[mkApps] in * ); try match goal with H : mkApps _ _ = mkApps ?f ?l |- _ => eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H | H : ?t = mkApps ?f ?l |- _ => - change t with (mkApps t []) in H ; - eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H + (change t with (mkApps t []) in H ; + eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H) || + (eapply nApp_mkApps in H as [? ?]; [|easy]; subst) | H : mkApps ?f ?l = ?t |- _ => change t with (mkApps t []) in H ; eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H @@ -1212,3 +1221,118 @@ Proof. - eapply eval_cofix_case; tea. eapply value_final, value_app. now constructor. auto. Qed. + +Lemma expanded_tApp Σ Γ f a : + ~ isConstructApp f || isFixApp f || isRel (head f) -> + expanded Σ Γ (tApp f a) -> + expanded Σ Γ f /\ expanded Σ Γ a. +Proof. + rewrite /isConstructApp /isFixApp. + intros hf exp; depind exp. + - destruct args using rev_case; solve_discr; try discriminate. + rewrite mkApps_app in H3; noconf H3. + eapply Forall_app in H1 as [? ha]. depelim ha. + destruct args using rev_case; cbn in hf => //. + now rewrite !head_mkApps /= in hf. + - destruct args using rev_case; solve_discr. subst f6. + eapply IHexp => //. + rewrite mkApps_app in H2; noconf H2. + eapply Forall_app in H0 as [? H0]. depelim H0. split => //. + rewrite !head_mkApps in hf. + eapply expanded_mkApps => //. + - destruct args using rev_case; solve_discr. discriminate. + rewrite mkApps_app in H6; noconf H6. + eapply Forall_app in H1 as [? h]. depelim h. split => //. + now rewrite !head_mkApps /= in hf. + - destruct args using rev_case; solve_discr. discriminate. + rewrite mkApps_app in H3; noconf H3. + now rewrite !head_mkApps /= in hf. +Qed. + +Lemma expanded_tLambda_inv Σ Γ na t b : + expanded Σ Γ (tLambda na t b) -> + expanded Σ (0 :: Γ) b. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tLetIn_inv Σ Γ na t t' b : + expanded Σ Γ (tLetIn na t t' b) -> + expanded Σ Γ t /\ expanded Σ (0 :: Γ) b. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tCase_inv Σ Γ ci p c brs : + expanded Σ Γ (tCase ci p c brs) -> + Forall (expanded Σ Γ) (pparams p) /\ + Forall + (fun br : branch term => + ∥ All_fold + (fun (Δ : list context_decl) (d : context_decl) + => + ForOption + (fun b : term => + expanded Σ + (repeat 0 #|Δ| ++ + repeat 0 #|pparams p|) b) + (decl_body d)) (bcontext br) ∥ /\ + expanded Σ (repeat 0 #|bcontext br| ++ Γ) (bbody br)) + brs /\ + expanded Σ Γ c. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tProj_inv Σ Γ p c : + expanded Σ Γ (tProj p c) -> + expanded Σ Γ c. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_red {cf : checker_flags} {Σ : global_env_ext} Γ Γ' t v : wf Σ -> + red1 Σ Γ t v -> + expanded Σ Γ' t -> + expanded Σ Γ' v. +Proof. + intros wf red; induction red using red1_ind_all in Γ' |- *; intros exp. + - eapply expanded_tApp in exp as [] => //. + eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. + now eapply expanded_tLambda_inv in H. + - eapply expanded_tLetIn_inv in exp as []. + eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. + - admit. + - eapply expanded_tCase_inv in exp as [? []]. + unfold iota_red. admit. + - admit. + - admit. + - eapply expanded_tProj_inv in exp. econstructor. admit. + - admit. + - admit. + - constructor. now eapply expanded_tLambda_inv in exp. + - constructor. eapply IHred. now eapply expanded_tLambda_inv in exp. + - eapply expanded_tLetIn_inv in exp; now constructor. + - eapply expanded_tLetIn_inv in exp. now constructor. + - eapply expanded_tLetIn_inv in exp. now constructor. + - eapply expanded_tCase_inv in exp as [? []]. + constructor; eauto. cbn. + solve_all. eapply OnOne2_impl_All_r; tea. intuition eauto. now apply X0. + now rewrite /PCUICOnOne.set_pparams /= -(OnOne2_length X). + - eapply expanded_tCase_inv in exp as [? []]. + constructor; eauto. + - eapply expanded_tCase_inv in exp as [? []]. + econstructor; eauto. + - eapply expanded_tCase_inv in exp as [? []]. + econstructor; eauto. solve_all. + eapply OnOne2_impl_All_r; tea. + intros x y [? ?]. intros [[] ?]. rewrite -e0. + solve_all. + - eapply expanded_tProj_inv in exp. now econstructor. + - case_eq (isConstructApp (tApp M1 M2) || isFixApp (tApp M1 M2) || isRel (head (tApp M1 M2))). + intros h. + clear red. specialize (IHred Γ'). + depelim exp. + { destruct args using rev_case; cbn in *; noconf H1. rewrite mkApps_app in H1; noconf H1. +(* not the right way to go about this, we need some mkApps induction hypothesis *) +Abort. From f1699162d543998dfafd35a4562b66c2af50db97 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 11 Sep 2023 18:08:45 +0200 Subject: [PATCH 51/65] Prove preservation of expansion by reduction using a custom reduction relation --- erasure/theories/EEtaExpandedFix.v | 2 +- pcuic/theories/PCUICWcbvEval.v | 575 ++++++++++++++++++++++++++++- 2 files changed, 562 insertions(+), 15 deletions(-) diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v index 8c14b356c..92a783a73 100644 --- a/erasure/theories/EEtaExpandedFix.v +++ b/erasure/theories/EEtaExpandedFix.v @@ -1408,7 +1408,7 @@ Proof. split. eapply All2_app => //. rewrite -H3. eauto. destruct s. * destruct p; solve_discr. noconf H2. - left. split. + left. split.w unfold isStuckFix'; rewrite e1. len. eapply Nat.leb_le. lia. now rewrite -[tApp _ _](mkApps_app _ _ [av]). * right. len. eapply isEtaExp_fixapp_mon; tea. lia. diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index 93adfe7fd..ddd600473 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -1222,7 +1222,28 @@ Proof. eapply value_final, value_app. now constructor. auto. Qed. -Lemma expanded_tApp Σ Γ f a : +Lemma expanded_tApp (Σ : global_env) (Γ : list nat) (f : term) a : + expanded Σ Γ f -> expanded Σ Γ a -> + expanded Σ Γ (tApp f a). +Proof. + induction 1 using expanded_ind; intros expa. + all:rewrite -?[tApp _ a](mkApps_app _ _ [a]). + all:try (eapply (expanded_mkApps _ _ _ [a]) => //; econstructor; eauto). + + - econstructor; tea. rewrite app_length. lia. eapply app_Forall;eauto. + - econstructor; tea. eapply app_Forall; eauto. + - eapply expanded_tFix; tea. eapply app_Forall; eauto. eauto. rewrite app_length; cbn; eauto. lia. + - eapply expanded_tConstruct_app; tea. rewrite app_length ; lia. eapply app_Forall; eauto. +Qed. + +Lemma expanded_mkApps (Σ : global_env) (Γ : list nat) (f : term) (args : list term) : + expanded Σ Γ f -> Forall (expanded Σ Γ) args -> expanded Σ Γ (mkApps f args). +Proof. + intros expf expa; induction expa in f, expf |- *; eauto. + cbn. eapply IHexpa. now eapply expanded_tApp. +Qed. + +Lemma expanded_tApp_inv Σ Γ f a : ~ isConstructApp f || isFixApp f || isRel (head f) -> expanded Σ Γ (tApp f a) -> expanded Σ Γ f /\ expanded Σ Γ a. @@ -1263,6 +1284,13 @@ Proof. intros exp; depind exp; solve_discr => //; eauto. Qed. +Lemma expanded_tEvar_inv Σ Γ ev l: + expanded Σ Γ (tEvar ev l) -> + Forall (expanded Σ Γ) l. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + Lemma expanded_tCase_inv Σ Γ ci p c brs : expanded Σ Γ (tCase ci p c brs) -> Forall (expanded Σ Γ) (pparams p) /\ @@ -1291,15 +1319,469 @@ Proof. intros exp; depind exp; solve_discr => //; eauto. Qed. +Lemma expanded_tCoFix_inv Σ Γ mfix idx : + expanded Σ Γ (tCoFix mfix idx) -> + Forall (fun d : def term => expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Import PCUICOnOne. + +Module Red1Apps. + + + Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := + (** Reductions *) + (** Beta *) + | red_beta na t b a ts : + Σ ;;; Γ |- mkApps (tLambda na t b) (a :: ts) ⇝ mkApps (b {0 := a}) ts + + (** Let *) + | red_zeta na b t b' : + Σ ;;; Γ |- tLetIn na b t b' ⇝ b' {0 := b} + + | red_rel i body : + option_map decl_body (nth_error Γ i) = Some (Some body) -> + Σ ;;; Γ |- tRel i ⇝ lift0 (S i) body + + (** Case *) + | red_iota ci c u args p brs br : + nth_error brs c = Some br -> + #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> + Σ ;;; Γ |- tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs + ⇝ iota_red ci.(ci_npar) p args br + + (** Fix unfolding, with guard *) + | red_fix mfix idx args narg fn : + unfold_fix mfix idx = Some (narg, fn) -> + is_constructor narg args = true -> + Σ ;;; Γ |- mkApps (tFix mfix idx) args ⇝ mkApps fn args + + (** CoFix-case unfolding *) + | red_cofix_case ip p mfix idx args narg fn brs : + unfold_cofix mfix idx = Some (narg, fn) -> + Σ ;;; Γ |- tCase ip p (mkApps (tCoFix mfix idx) args) brs ⇝ + tCase ip p (mkApps fn args) brs + + (** CoFix-proj unfolding *) + | red_cofix_proj p mfix idx args narg fn : + unfold_cofix mfix idx = Some (narg, fn) -> + Σ ;;; Γ |- tProj p (mkApps (tCoFix mfix idx) args) ⇝ tProj p (mkApps fn args) + + (** Constant unfolding *) + | red_delta c decl body (isdecl : declared_constant Σ c decl) u : + decl.(cst_body) = Some body -> + Σ ;;; Γ |- tConst c u ⇝ subst_instance u body + + (** Proj *) + | red_proj p args u arg: + nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg -> + Σ ;;; Γ |- tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args) ⇝ arg + + + | abs_red_l na M M' N : Σ ;;; Γ |- M ⇝ M' -> Σ ;;; Γ |- tLambda na M N ⇝ tLambda na M' N + | abs_red_r na M M' N : Σ ;;; Γ ,, vass na N |- M ⇝ M' -> Σ ;;; Γ |- tLambda na N M ⇝ tLambda na N M' + + | letin_red_def na b t b' r : Σ ;;; Γ |- b ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na r t b' + | letin_red_ty na b t b' r : Σ ;;; Γ |- t ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na b r b' + | letin_red_body na b t b' r : Σ ;;; Γ ,, vdef na b t |- b' ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na b t r + + | case_red_param ci p params' c brs : + OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) p.(pparams) params' -> + Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_pparams p params') c brs + + | case_red_return ci p preturn' c brs : + Σ ;;; Γ ,,, inst_case_predicate_context p |- p.(preturn) ⇝ preturn' -> + Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_preturn p preturn') c brs + + | case_red_discr ci p c c' brs : + Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c' brs + + | case_red_brs ci p c brs brs' : + OnOne2 (fun br br' => + on_Trel_eq (fun t u => Σ ;;; Γ ,,, inst_case_branch_context p br |- t ⇝ u) bbody bcontext br br') + brs brs' -> + Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c brs' + + | proj_red p c c' : Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tProj p c ⇝ tProj p c' + + | app_red_l M1 N1 M2 : Σ ;;; Γ |- M1 ⇝ N1 -> ~~ isApp M1 -> ~~ isFix M1 -> M2 <> nil -> + Σ ;;; Γ |- mkApps M1 M2 ⇝ mkApps N1 M2 + + | app_red_r M2 N2 M1 : ~~ isApp M1 -> OnOne2 (fun M2 N2 => Σ ;;; Γ |- M2 ⇝ N2) M2 N2 -> Σ ;;; Γ |- mkApps M1 M2 ⇝ mkApps M1 N2 + + | app_fix_red_ty mfix0 mfix1 idx M2 : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- mkApps (tFix mfix0 idx) M2 ⇝ mkApps (tFix mfix1 idx) M2 + + | app_fix_red_body mfix0 mfix1 idx M2 : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- mkApps (tFix mfix0 idx) M2 ⇝ mkApps (tFix mfix1 idx) M2 + + | prod_red_l na M1 M2 N1 : Σ ;;; Γ |- M1 ⇝ N1 -> Σ ;;; Γ |- tProd na M1 M2 ⇝ tProd na N1 M2 + | prod_red_r na M2 N2 M1 : Σ ;;; Γ ,, vass na M1 |- M2 ⇝ N2 -> + Σ ;;; Γ |- tProd na M1 M2 ⇝ tProd na M1 N2 + + | evar_red ev l l' : OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) l l' -> Σ ;;; Γ |- tEvar ev l ⇝ tEvar ev l' + + | fix_red_ty mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- tFix mfix0 idx ⇝ tFix mfix1 idx + + | fix_red_body mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) + mfix0 mfix1 -> + Σ ;;; Γ |- tFix mfix0 idx ⇝ tFix mfix1 idx + + | cofix_red_ty mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- tCoFix mfix0 idx ⇝ tCoFix mfix1 idx + + | cofix_red_body mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- tCoFix mfix0 idx ⇝ tCoFix mfix1 idx + where " Σ ;;; Γ |- t ⇝ u " := (red1 Σ Γ t u). + +Lemma red1_ind_all : + forall (Σ : global_env) (P : context -> term -> term -> Type), + + (forall (Γ : context) (na : aname) (t b a : term) ts, + P Γ (mkApps (tLambda na t b) (a :: ts)) (mkApps (b {0 := a}) ts)) -> + + (forall (Γ : context) (na : aname) (b t b' : term), P Γ (tLetIn na b t b') (b' {0 := b})) -> + + (forall (Γ : context) (i : nat) (body : term), + option_map decl_body (nth_error Γ i) = Some (Some body) -> P Γ (tRel i) ((lift0 (S i)) body)) -> + + (forall (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term) + (p : predicate term) (brs : list (branch term)) br, + nth_error brs c = Some br -> + #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> + P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) p args br)) -> + + (forall (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), + unfold_fix mfix idx = Some (narg, fn) -> + is_constructor narg args = true -> P Γ (mkApps (tFix mfix idx) args) (mkApps fn args)) -> + + (forall (Γ : context) ci (p : predicate term) (mfix : mfixpoint term) (idx : nat) + (args : list term) (narg : nat) (fn : term) (brs : list (branch term)), + unfold_cofix mfix idx = Some (narg, fn) -> + P Γ (tCase ci p (mkApps (tCoFix mfix idx) args) brs) (tCase ci p (mkApps fn args) brs)) -> + + (forall (Γ : context) (p : projection) (mfix : mfixpoint term) (idx : nat) (args : list term) + (narg : nat) (fn : term), + unfold_cofix mfix idx = Some (narg, fn) -> P Γ (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args))) -> + + (forall (Γ : context) c (decl : constant_body) (body : term), + declared_constant Σ c decl -> + forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance u body)) -> + + (forall (Γ : context) p (args : list term) (u : Instance.t) + (arg : term), + nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg -> + P Γ (tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args)) arg) -> + + (forall (Γ : context) (na : aname) (M M' N : term), + red1 Σ Γ M M' -> P Γ M M' -> P Γ (tLambda na M N) (tLambda na M' N)) -> + + (forall (Γ : context) (na : aname) (M M' N : term), + red1 Σ (Γ,, vass na N) M M' -> P (Γ,, vass na N) M M' -> P Γ (tLambda na N M) (tLambda na N M')) -> + + (forall (Γ : context) (na : aname) (b t b' r : term), + red1 Σ Γ b r -> P Γ b r -> P Γ (tLetIn na b t b') (tLetIn na r t b')) -> + + (forall (Γ : context) (na : aname) (b t b' r : term), + red1 Σ Γ t r -> P Γ t r -> P Γ (tLetIn na b t b') (tLetIn na b r b')) -> + + (forall (Γ : context) (na : aname) (b t b' r : term), + red1 Σ (Γ,, vdef na b t) b' r -> P (Γ,, vdef na b t) b' r -> P Γ (tLetIn na b t b') (tLetIn na b t r)) -> + + (forall (Γ : context) (ci : case_info) p params' c brs, + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) p.(pparams) params' -> + P Γ (tCase ci p c brs) + (tCase ci (set_pparams p params') c brs)) -> + + (forall (Γ : context) (ci : case_info) p preturn' c brs, + red1 Σ (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> + P (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> + P Γ (tCase ci p c brs) + (tCase ci (set_preturn p preturn') c brs)) -> + + (forall (Γ : context) (ind : case_info) (p : predicate term) (c c' : term) (brs : list (branch term)), + red1 Σ Γ c c' -> P Γ c c' -> P Γ (tCase ind p c brs) (tCase ind p c' brs)) -> + + (forall (Γ : context) ci p c brs brs', + OnOne2 (fun br br' => + (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, inst_case_branch_context p br)) + (P (Γ ,,, inst_case_branch_context p br))) + bbody bcontext br br')) brs brs' -> + P Γ (tCase ci p c brs) (tCase ci p c brs')) -> + + (forall (Γ : context) (p : projection) (c c' : term), red1 Σ Γ c c' -> P Γ c c' -> + P Γ (tProj p c) (tProj p c')) -> + + (forall (Γ : context) M1 N1 M2, red1 Σ Γ M1 N1 -> P Γ M1 N1 -> ~~ isApp M1 -> ~~ isFix M1 -> M2 <> [] -> + P Γ (mkApps M1 M2) (mkApps N1 M2)) -> + + (forall (Γ : context) M1 N2 M2, ~~ isApp M1 -> + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) M2 N2 -> + P Γ (mkApps M1 M2) (mkApps M1 N2)) -> + + (forall (Γ : context) mfix0 mfix1 idx M2, + OnOne2 (on_Trel_eq (Trel_conj (fun t u => Σ ;;; Γ |- t ⇝ u) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + P Γ (mkApps (tFix mfix0 idx) M2) (mkApps (tFix mfix1 idx) M2)) -> + + (forall (Γ : context) mfix0 mfix1 idx M2, + OnOne2 (on_Trel_eq (Trel_conj (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) (P (Γ ,,, fix_context mfix0))) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + P Γ (mkApps (tFix mfix0 idx) M2) (mkApps (tFix mfix1 idx) M2)) -> + + (forall (Γ : context) (na : aname) (M1 M2 N1 : term), + red1 Σ Γ M1 N1 -> P Γ M1 N1 -> P Γ (tProd na M1 M2) (tProd na N1 M2)) -> + + (forall (Γ : context) (na : aname) (M2 N2 M1 : term), + red1 Σ (Γ,, vass na M1) M2 N2 -> P (Γ,, vass na M1) M2 N2 -> P Γ (tProd na M1 M2) (tProd na M1 N2)) -> + + (forall (Γ : context) (ev : nat) (l l' : list term), + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) l l' -> P Γ (tEvar ev l) (tEvar ev l')) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + P Γ (tFix mfix0 idx) (tFix mfix1 idx)) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, fix_context mfix0)) + (P (Γ ,,, fix_context mfix0))) dbody + (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + P Γ (tFix mfix0 idx) (tFix mfix1 idx)) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, fix_context mfix0)) + (P (Γ ,,, fix_context mfix0))) dbody + (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> + + forall (Γ : context) (t t0 : term), red1 Σ Γ t t0 -> P Γ t t0. +Proof. + intros. rename X29 into Xlast. revert Γ t t0 Xlast. + fix aux 4. intros Γ t T. + move aux at top. + destruct 1; match goal with + | |- P _ (tFix _ _) (tFix _ _) => idtac + | |- P _ (tCoFix _ _) (tCoFix _ _) => idtac + | |- P _ (mkApps (tFix _ _) _) _ => idtac + | |- P _ (tCase _ _ (mkApps (tCoFix _ _) _) _) _ => idtac + | |- P _ (tProj _ (mkApps (tCoFix _ _) _)) _ => idtac + | H : _ |- _ => eapply H; eauto + end. + - eapply X3; eauto. + - eapply X4; eauto. + - eapply X5; eauto. + + - revert params' o. + generalize (pparams p). + fix auxl 3. + intros params params' []. + + constructor. split; auto. + + constructor. auto. + + - revert brs' o. + revert brs. + fix auxl 3. + intros l l' Hl. destruct Hl. + + simpl in *. constructor; intros; intuition auto. + + constructor. eapply auxl. apply Hl. + + - revert M2 N2 o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor. split; auto. + + constructor. auto. + + - eapply X20. + revert mfix0 mfix1 o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor; split; auto; intuition. + + constructor; try split; auto; intuition. + + - eapply X21. revert o. + generalize (fix_context mfix0). + intros c o. revert mfix0 mfix1 o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor. split; auto; intuition. + + constructor; try split; auto; intuition. + + - revert l l' o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor. split; auto. + + constructor. auto. + + - eapply X25. + revert mfix0 mfix1 o; fix auxl 3. + intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. + + - eapply X26. + revert o. generalize (fix_context mfix0). intros c Xnew. + revert mfix0 mfix1 Xnew; fix auxl 3; intros l l' Hl; + destruct Hl; constructor; try split; auto; intuition. + + - eapply X27. + revert mfix0 mfix1 o. + fix auxl 3; intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. + + - eapply X28. + revert o. generalize (fix_context mfix0). intros c new. + revert mfix0 mfix1 new; fix auxl 3; intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. +Defined. + +Lemma red_tApp Σ Γ t v u : + red1 Σ Γ t v -> + red1 Σ Γ (tApp t u) (tApp v u). +Proof. + induction 1. + all:try solve [eapply (app_red_l _ _ _ _ [u]) => //; econstructor; eauto]. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). + eapply red_beta. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. + now apply is_constructor_app_ge. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. + now eapply OnOne2_app_r. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). now eapply app_fix_red_ty. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). now eapply app_fix_red_body. + - now eapply (app_fix_red_ty _ _ _ _ _ [_]). + - now eapply (app_fix_red_body _ _ _ _ _ [_]). +Qed. + +Lemma isLambda_red1 Σ Γ b b' : isLambda b -> red1 Σ Γ b b' -> isLambda b'. +Proof. + destruct b; simpl; try discriminate. + intros _ red. + depelim red; solve_discr; eauto. depelim o. +Qed. + +End Red1Apps. + +Lemma red1_red1apps Σ Γ t v : + red1 Σ Γ t v -> Red1Apps.red1 Σ Γ t v. +Proof. + intros red; induction red using red1_ind_all in |- *. + all:try solve [econstructor; eauto; solve_all; eauto]. + - eapply (Red1Apps.red_beta _ _ _ _ _ _ []). + - now eapply Red1Apps.red_tApp. + - remember (decompose_app (tApp M1 M2)). + destruct p as [hd args]. + edestruct (decompose_app_rec_inv' M1 [M2]). rewrite /decompose_app in Heqp. + cbn in Heqp. rewrite -Heqp. reflexivity. + destruct a as [napp [hm2 hm1]]. + symmetry in Heqp; eapply decompose_app_inv in Heqp. rewrite Heqp. + assert (tApp M1 N2 = mkApps hd (firstn x args ++ [N2])) as ->. + { now rewrite mkApps_app -hm1. } + rewrite -{1}(firstn_skipn x args) -hm2. eapply Red1Apps.app_red_r => //. + eapply OnOne2_app. now constructor. +Qed. + +Lemma head_nApp f : + ~~ isApp f -> head f = f. +Proof. + induction f => //. +Qed. + +Lemma expanded_mkApps_inv Σ Γ f v : + ~~ isApp f -> + ~~ (isConstruct f || isFix f || isRel f) -> + expanded Σ Γ (mkApps f v) -> + expanded Σ Γ f /\ Forall (expanded Σ Γ) v. +Proof. + intros happ hc. + induction v using rev_ind; cbn. + - intros exp; split => //. + - rewrite mkApps_app /=. + move/expanded_tApp_inv => e. + forward e. rewrite /isConstructApp /isFixApp head_mkApps. + rewrite head_nApp //. now move/negbTE: hc ->. + intuition auto. eapply app_Forall; eauto. +Qed. + + +Lemma arguments_mkApps f args : + ~~ isApp f -> + arguments (mkApps f args) = args. +Proof. + rewrite /arguments => isa. + rewrite decompose_app_mkApps //. +Qed. + +Lemma arguments_mkApps' f args : + arguments (mkApps f args) = arguments f ++ args. +Proof. + rewrite /arguments. + rewrite /decompose_app decompose_app_rec_mkApps //. + rewrite app_nil_r. + induction f in args |- * => //=. + rewrite IHf1. now rewrite (IHf1 [f2]) -app_assoc. +Qed. + +Lemma expanded_mkApps_inv' Σ Γ f : + expanded Σ Γ f -> + let args := arguments f in + Forall (expanded Σ Γ) args /\ + match head f with + | tRel n => exists m, nth_error Γ n = Some m /\ m <= #|args| + | tConstruct ind c u => exists mind idecl cdecl, + declared_constructor Σ (ind, c) mind idecl cdecl /\ #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) + | tFix mfix idx => exists d, + Forall + (fun d0 : def term => + isLambda (dbody d0) /\ + (let ctx := + rev_map (fun d1 : def term => (1 + rarg d1)%nat) + mfix in + expanded Σ (ctx ++ Γ) (dbody d0))) mfix /\ + args <> [] /\ + nth_error mfix idx = Some d /\ #|args| > rarg d + | _ => expanded Σ Γ (head f) + end. +Proof. + induction 1 using expanded_ind; cbn. + all: try solve [split; econstructor; eauto]. + all:rewrite head_mkApps /=. + - rewrite arguments_mkApps //. split => //. now exists m. + - destruct IHexpanded. rewrite arguments_mkApps'. split. + eapply app_Forall => //. + rewrite app_length. + destruct (head f6) => //; firstorder (eauto; try lia). + exists x. split => //. firstorder (eauto; try lia). + intros heq; apply H5. now eapply app_eq_nil in heq. + - rewrite arguments_mkApps //. split => //. now exists d. + - rewrite arguments_mkApps //. split => //. + firstorder. +Qed. + Lemma expanded_red {cf : checker_flags} {Σ : global_env_ext} Γ Γ' t v : wf Σ -> + (forall n body, option_map decl_body (nth_error Γ n) = Some (Some body) -> expanded Σ (skipn (S n) Γ') body) -> red1 Σ Γ t v -> expanded Σ Γ' t -> expanded Σ Γ' v. Proof. - intros wf red; induction red using red1_ind_all in Γ' |- *; intros exp. - - eapply expanded_tApp in exp as [] => //. + move=> wf wfΓ /red1_red1apps red. + induction red using Red1Apps.red1_ind_all in wfΓ, Γ' |- *; intros exp. + - eapply expanded_mkApps_inv in exp as [] => //. + eapply expanded_tLambda_inv in H. + depelim H0. + eapply expanded_mkApps => //. eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. - now eapply expanded_tLambda_inv in H. - eapply expanded_tLetIn_inv in exp as []. eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. - admit. @@ -1311,10 +1793,15 @@ Proof. - admit. - admit. - constructor. now eapply expanded_tLambda_inv in exp. - - constructor. eapply IHred. now eapply expanded_tLambda_inv in exp. + - constructor. eapply expanded_tLambda_inv in exp. + eapply IHred => //. + { intros [] body; cbn => //. rewrite skipn_S. eapply wfΓ. } - eapply expanded_tLetIn_inv in exp; now constructor. - eapply expanded_tLetIn_inv in exp. now constructor. - - eapply expanded_tLetIn_inv in exp. now constructor. + - eapply expanded_tLetIn_inv in exp. constructor; intuition eauto. + eapply IHred => //. + { intros [] ? => //=. intros [=]. subst b. now rewrite skipn_S skipn_0. + rewrite skipn_S. eapply wfΓ. } - eapply expanded_tCase_inv in exp as [? []]. constructor; eauto. cbn. solve_all. eapply OnOne2_impl_All_r; tea. intuition eauto. now apply X0. @@ -1327,12 +1814,72 @@ Proof. econstructor; eauto. solve_all. eapply OnOne2_impl_All_r; tea. intros x y [? ?]. intros [[] ?]. rewrite -e0. - solve_all. + solve_all. eapply e => //. admit. - eapply expanded_tProj_inv in exp. now econstructor. - - case_eq (isConstructApp (tApp M1 M2) || isFixApp (tApp M1 M2) || isRel (head (tApp M1 M2))). - intros h. - clear red. specialize (IHred Γ'). - depelim exp. - { destruct args using rev_case; cbn in *; noconf H1. rewrite mkApps_app in H1; noconf H1. -(* not the right way to go about this, we need some mkApps induction hypothesis *) -Abort. + - eapply expanded_mkApps_inv' in exp. + rewrite head_mkApps head_nApp in exp => //. + rewrite arguments_mkApps // in exp. destruct exp as []. + specialize (IHred Γ' wfΓ). + destruct M1; try solve [eapply expanded_mkApps => //; eauto]. + * depelim red; solve_discr. eapply wfΓ in e. + eapply expanded_mkApps => //. + rewrite -(firstn_skipn (S n) Γ'). eapply (expanded_lift _ _ _ _ []) => //. + destruct H3 as [m [hn ha]]. + rewrite firstn_length_le //. now eapply nth_error_Some_length in hn. + depelim o. + * depelim red; solve_discr. depelim o. + + - eapply expanded_mkApps_inv' in exp. + move: exp. + rewrite head_mkApps head_nApp // arguments_mkApps //. + intros []. + assert(Forall (expanded Σ Γ') N2). + { clear H1. solve_all. eapply OnOne2_impl_All_r; tea. cbn. intuition auto. } + destruct M1; try solve [eapply expanded_mkApps => //; eauto]. + + rewrite (OnOne2_length X) in H1. destruct H1 as [m []]; eapply expanded_tRel; tea. + + rewrite (OnOne2_length X) in H1. destruct H1 as [m [? [? []]]]; eapply expanded_tConstruct_app; tea. + + rewrite (OnOne2_length X) in H1. + destruct H1 as [d [? [? []]]]; eapply expanded_tFix; tea. + destruct N2; cbn in *; eauto. lia. intros eq; discriminate. + + - move/expanded_mkApps_inv': exp. + rewrite head_mkApps head_nApp // arguments_mkApps // => [] [] hargs [d [hf [hm2 [hnth harg]]]]. + eapply OnOne2_nth_error in hnth as [t' [hnth hor]]; tea. + eapply expanded_tFix; tea. + { clear hor. solve_all. eapply OnOne2_impl_All_r; tea. + intros ? ? [] []. noconf e. rewrite -H2. split => //. solve_all. + clear -X H1. + enough (rev_map (fun d1 : def term => S (rarg d1)) mfix0 = (rev_map (fun d1 : def term => S (rarg d1)) mfix1)) as <- => //. + clear -X. rewrite !rev_map_spec. f_equal. induction X. destruct p as []. cbn in *. congruence. cbn. congruence. } + { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } + + - move/expanded_mkApps_inv': exp. + rewrite head_mkApps head_nApp // arguments_mkApps // => [] [] hargs [d [hf [hm2 [hnth harg]]]]. + eapply OnOne2_nth_error in hnth as [t' [hnth hor]]; tea. + eapply expanded_tFix; tea. + { clear hor. solve_all. + assert (rev_map (fun d1 : def term => S (rarg d1)) mfix0 = (rev_map (fun d1 : def term => S (rarg d1)) mfix1)). + { clear -X. rewrite !rev_map_spec. f_equal. induction X. destruct p as []. cbn in *. congruence. cbn. congruence. } + rewrite -H. + eapply OnOne2_impl_All_r; tea. + intros ? ? [] []. noconf e. destruct p. + eapply Red1Apps.isLambda_red1 in r; tea. split => //. + set(Γ'' := rev_map (fun d1 : def term => S (rarg d1)) mfix0). + eapply e => //. + { intros n b hnth'. admit. } } + { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } + - eapply expanded_tProd. + - constructor. + - constructor. + eapply expanded_tEvar_inv in exp. + solve_all; eapply OnOne2_impl_All_r; tea. intuition eauto. + now eapply X0. + - depelim exp; solve_discr. now cbn in H. + - depelim exp; solve_discr. now cbn in H. + - eapply expanded_tCoFix_inv in exp. econstructor. + rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. + destruct X0. noconf e. now rewrite -H1. + - eapply expanded_tCoFix_inv in exp. econstructor. + rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. + destruct X0. destruct p. noconf e. eapply e0 => //. admit. +Qed. \ No newline at end of file From 2f5fed3109aaa1f7d8d76328cf2fb2f1084cce2d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Sep 2023 12:52:42 +0200 Subject: [PATCH 52/65] Finished preservation of expansion proof --- pcuic/theories/PCUICWcbvEval.v | 295 +++++++++++++++++++++++++++++++-- 1 file changed, 284 insertions(+), 11 deletions(-) diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index ddd600473..6fdc13e16 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -1769,13 +1769,203 @@ Proof. firstorder. Qed. +Lemma All_fold_map_context (P : context -> context_decl -> Type) (f : term -> term) ctx : + All_fold P (map_context f ctx) <~> All_fold (fun Γ d => P (map_context f Γ) (map_decl f d)) ctx. +Proof. + induction ctx. + - split; constructor. + - cbn. split; intros H; depelim H; constructor; auto; now apply IHctx. +Qed. + +Lemma expanded_fix_subst Σ a k b Γ Γs Δ : + #|Γ| = k -> + Forall2 (fun n arg => forall args Γ' k', + Forall (expanded Σ (Γ' ++ Δ)) args -> + n <= #|args| -> + #|Γ'| = k' -> + expanded Σ (Γ' ++ Δ) (mkApps (lift0 k' arg) args)) Γs a -> + expanded Σ (Γ ++ Γs ++ Δ) b -> + expanded Σ (Γ ++ Δ) (subst a k b). +Proof. + intros Hk Hs. + remember (Γ ++ _ ++ Δ)%list as Γ_. + intros exp; revert Γ k Hk HeqΓ_. + induction exp using expanded_ind; intros Γ' k Hk ->. + all:try solve[ cbn; econstructor => // ]. + 2,7:solve[ cbn; econstructor => //; solve_all ]. + - rewrite subst_mkApps /=. + destruct (Nat.leb_spec k n). + destruct (nth_error a _) eqn:hnth. + * pose proof (Forall2_length Hs). + pose proof (Forall2_nth_error_Some_r _ _ _ _ _ _ _ hnth Hs) as [t' [hnth' hargs]]. + eapply hargs => //. + eapply Forall_map. + 2:{ len. rewrite nth_error_app_ge in H. lia. subst k. + rewrite nth_error_app_lt in H. + eapply nth_error_Some_length in hnth'. lia. rewrite hnth' in H. noconf H. exact H0. } + solve_all. + * rewrite nth_error_app_ge in H. lia. + eapply nth_error_None in hnth. + pose proof (Forall2_length Hs). + rewrite nth_error_app_ge in H. lia. + eapply expanded_tRel. rewrite nth_error_app_ge. lia. erewrite <- H. + lia_f_equal. len. solve_all. + * rewrite nth_error_app_lt in H. lia. + eapply expanded_tRel. rewrite nth_error_app_lt. lia. tea. now len. + solve_all. + - cbn. econstructor. + eapply (IHexp (0 :: Γ') (S k)); cbn; auto; try lia. + - cbn. econstructor. apply IHexp1; auto. + eapply (IHexp2 (0 :: Γ') (S k)); cbn; auto; lia. + - rewrite subst_mkApps. + destruct (isConstruct (subst a k f6) || isFix (subst a k f6) || isRel (subst a k f6)) eqn:eqc. + specialize (IHexp _ _ Hk eq_refl). + eapply expanded_mkApps_expanded => //. solve_all. + eapply expanded_mkApps => //. now eapply IHexp. solve_all. + - cbn. econstructor. eauto. cbn. solve_all. solve_all. + specialize (H1 (repeat 0 #|bcontext x| ++ Γ') (#|bcontext x| + k)%nat). + forward H1 by len. + forward H1. now rewrite app_assoc. + rewrite /id. rewrite app_assoc. apply H1. + - rewrite subst_mkApps. cbn. + eapply expanded_tFix. + + solve_all. now eapply isLambda_subst. + specialize (a0 + (rev_map (fun d0 : def term => S (rarg d0)) + (map (map_def (subst a k) (subst a (#|mfix| + k))) mfix) ++ Γ') (#|mfix| + k)%nat). + forward a0 by len. + forward a0. { rewrite app_assoc. f_equal. f_equal. + rewrite !rev_map_spec. f_equal. now rewrite map_map_compose /=. } + rewrite app_assoc. eapply a0. + + solve_all. + + now destruct args. + + rewrite nth_error_map /= H4 //. + + len. + - cbn. constructor. + solve_all. + specialize (a0 (repeat 0 #|mfix| ++ Γ') (#|mfix| + k)%nat). + forward a0 by len. + forward a0. { rewrite app_assoc //. } + rewrite app_assoc. eapply a0. + - rewrite subst_mkApps. cbn. + eapply expanded_tConstruct_app; tea. now len. + solve_all. +Qed. + +Lemma expanded_unfold_fix Σ Γ' mfix idx narg fn : + unfold_fix mfix idx = Some (narg, fn) -> + All (fun d0 : def term => isLambda (dbody d0) /\ expanded Σ (rev_map (fun d1 : def term => S (rarg d1)) mfix ++ Γ') (dbody d0)) mfix -> + expanded Σ Γ' fn. +Proof. + unfold unfold_fix. + destruct nth_error eqn:e => //. + intros [= <- <-] hf. + pose proof (nth_error_all e hf) as [hl hf']. + eapply (expanded_fix_subst _ _ _ _ []) => //; tea. + rewrite rev_map_spec. + eapply Forall2_from_nth_error. len. + intros n rarg f. len. intros hn hrarg hnthf args Γ'' k' hargs hrarg' <-. + eapply PCUICParallelReductionConfluence.nth_error_fix_subst in hnthf. subst f. + move: hrarg. + rewrite nth_error_rev; len. rewrite List.rev_involutive nth_error_map. + intros hrarg. + destruct (nth_error mfix (_ - _)) eqn:e'. cbn in hrarg. noconf hrarg. + eapply expanded_tFix => //. solve_all. + eapply expanded_lift; len. rewrite !rev_map_spec in H1 *. + rewrite map_map => //. destruct args => //. cbn in hrarg'. lia. + rewrite nth_error_map /= e' /= //. cbn. lia. + eapply nth_error_None in e'. lia. +Qed. + +Lemma expanded_unfold_cofix Σ Γ' mfix idx narg fn : + unfold_cofix mfix idx = Some (narg, fn) -> + All (fun d0 : def term => expanded Σ (repeat 0 #|mfix| ++ Γ') (dbody d0)) mfix -> + expanded Σ Γ' fn. +Proof. + unfold unfold_cofix. + destruct nth_error eqn:e => //. + intros [= <- <-] hf. + pose proof (nth_error_all e hf) as hf'. + eapply (expanded_subst _ _ _ _ []) => //; tea. + rewrite /cofix_subst. + generalize #|mfix|. + induction n; repeat constructor; eauto. solve_all. + len. +Qed. + +Lemma expanded_weakening_env {cf : checker_flags} Σ Σ' Γ t : + wf Σ' -> + extends Σ Σ' -> + expanded Σ Γ t -> expanded Σ' Γ t. +Proof. + intros w s. + eapply expanded_ind; intros. + all:try solve [econstructor; eauto]. + - econstructor; eauto. solve_all. sq. eapply All_fold_impl; tea. cbn. + intros. now rewrite repeat_app in H6. + - eapply expanded_tFix; eauto. solve_all. + - eapply expanded_tConstruct_app; eauto. + eapply PCUICWeakeningEnv.weakening_env_declared_constructor; tea. +Qed. + +Lemma expanded_global_env_constant {cf : checker_flags} Σ c decl : + wf Σ -> + expanded_global_env Σ -> + declared_constant Σ c decl -> + ForOption (expanded Σ []) (cst_body decl). +Proof. + intros wf; destruct Σ as [Σ univs] => /=. cbn. + unfold expanded_global_env. cbn. + induction 1; cbn => //. + intros [->|H']. + - depelim H0. + destruct decl as [? [] ?]; cbn in *. + constructor. cbn. + eapply expanded_weakening_env; tea. + eapply extends_strictly_on_decls_extends. + split => //=. eapply incl_cs_refl. 2:eapply Retroknowledge.extends_refl. + set (cb := ConstantDecl _). now exists [(c, cb)]. + constructor. + - forward IHexpanded_global_declarations. + destruct wf. cbn in *. split => //. + cbn. now depelim o0. + eapply IHexpanded_global_declarations in H'. + destruct decl as [? [] ?]; cbn in * => //. 2:constructor. + depelim H'. constructor. + eapply expanded_weakening_env; tea. + eapply extends_strictly_on_decls_extends. + split => //=. eapply incl_cs_refl. 2:eapply Retroknowledge.extends_refl. + now exists [decl0]. +Qed. + +Lemma All_fold_nth_error P (ctx : context) n b : + All_fold P ctx -> nth_error ctx n = Some b -> + P (skipn (S n) ctx) b. +Proof. + induction 1 in n, b |- *. + - rewrite nth_error_nil //. + - destruct n => //=. + * intros [= <-]. now rewrite skipn_S skipn_0. + * intros hnth. now rewrite skipn_S. +Qed. + +Lemma skipn_repeat {A} k n (a : A) : + skipn n (repeat a k) = repeat a (k - n). +Proof. + induction n in k |- *. + - rewrite skipn_0. lia_f_equal. + - destruct k => //=. + rewrite skipn_S IHn. lia_f_equal. +Qed. + Lemma expanded_red {cf : checker_flags} {Σ : global_env_ext} Γ Γ' t v : wf Σ -> + expanded_global_env Σ -> (forall n body, option_map decl_body (nth_error Γ n) = Some (Some body) -> expanded Σ (skipn (S n) Γ') body) -> red1 Σ Γ t v -> expanded Σ Γ' t -> expanded Σ Γ' v. Proof. - move=> wf wfΓ /red1_red1apps red. + move=> wf expΣ wfΓ /red1_red1apps red. induction red using Red1Apps.red1_ind_all in wfΓ, Γ' |- *; intros exp. - eapply expanded_mkApps_inv in exp as [] => //. eapply expanded_tLambda_inv in H. @@ -1784,14 +1974,53 @@ Proof. eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. - eapply expanded_tLetIn_inv in exp as []. eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. - - admit. + - rewrite -(firstn_skipn (S i) Γ'). + eapply expanded_mkApps_inv' in exp; cbn in exp. + destruct exp as [_ [m []]]. eapply nth_error_Some_length in H0. + eapply (expanded_lift _ _ _ _ []) => //. + rewrite firstn_length_le; try lia. + now eapply wfΓ. + - eapply expanded_tCase_inv in exp as [? []]. + unfold iota_red. + move/expanded_mkApps_inv': H3 => /=. + rewrite arguments_mkApps // head_mkApps //=. + intros [hargs [mind [idecl [cdecl [declc hargs']]]]]. + eapply nth_error_forall in H2; tea. + destruct H2 as [[hbctx] hbod]. + eapply (expanded_subst _ _ _ _ [] _) => //. + + eapply Forall_rev, Forall_skipn => //. + + len. replace #|skipn (ci_npar ci) args| with (context_assumptions (inst_case_branch_context p br)). + eapply expanded_let_expansion; len. red. + sq. rewrite /inst_case_branch_context /inst_case_context /subst_context. + eapply PCUICParallelReduction.All_fold_fold_context_k. + eapply All_fold_map_context, All_fold_impl; tea; cbn. + intros ? ? fo. len. destruct x as [? [] ?] => //; constructor. + cbn in fo. depelim fo. eapply (expanded_subst _ _ _ _ (repeat 0 #|Γ0|) _); len. + eapply Forall_rev; eauto. + eapply expanded_subst_instance. rewrite app_assoc. now eapply expanded_weakening. + rewrite skipn_length. len. + - move/expanded_mkApps_inv': exp. cbn. + rewrite arguments_mkApps // head_mkApps //=. + move=> [hargs [d [hf [hargs' []]]]] hnth hrarg. + eapply expanded_mkApps_expanded => //; solve_all. + eapply expanded_unfold_fix in H; tea. - eapply expanded_tCase_inv in exp as [? []]. - unfold iota_red. admit. - - admit. - - admit. - - eapply expanded_tProj_inv in exp. econstructor. admit. - - admit. - - admit. + constructor => //. + eapply expanded_mkApps_inv' in H2. move: H2; rewrite arguments_mkApps // head_mkApps //=. + intros [hargs' hcof]. cbn in hcof. eapply expanded_tCoFix_inv in hcof. + eapply expanded_unfold_cofix in H; tea. eapply expanded_mkApps; tea => //. solve_all. + - eapply expanded_tProj_inv in exp. econstructor. + eapply expanded_mkApps_inv' in exp. move: exp; rewrite arguments_mkApps // head_mkApps //=. + intros [hargs' hcof]. cbn in hcof. eapply expanded_tCoFix_inv in hcof. + eapply expanded_mkApps => //. + eapply expanded_unfold_cofix in H; tea. solve_all. + - eapply expanded_subst_instance. + eapply expanded_global_env_constant in expΣ; tea. + eapply (expanded_weakening _ []). rewrite H0 in expΣ. now depelim expΣ. + - eapply expanded_tProj_inv in exp. + move/expanded_mkApps_inv': exp. rewrite arguments_mkApps // head_mkApps //=. + intros []. + eapply nth_error_forall in H0; tea. - constructor. now eapply expanded_tLambda_inv in exp. - constructor. eapply expanded_tLambda_inv in exp. eapply IHred => //. @@ -1814,7 +2043,30 @@ Proof. econstructor; eauto. solve_all. eapply OnOne2_impl_All_r; tea. intros x y [? ?]. intros [[] ?]. rewrite -e0. - solve_all. eapply e => //. admit. + solve_all. eapply e => //. + intros n b. + clear -H H2 wfΓ. + destruct nth_error eqn:e' => //. + cbn. intros [=]. destruct c as [? [] ?]. cbn in *. noconf H1. + eapply nth_error_app_inv in e' as [[]|[]]. + { rewrite inst_case_branch_context_length in H0. destruct H2. + rewrite /inst_case_branch_context /inst_case_context in H1. + destruct (nth_error (bcontext x) n) eqn:e. + 2:{ eapply nth_error_None in e. rewrite skipn_app skipn_all2. len. cbn. len. } + rewrite /subst_context in H1. + erewrite nth_error_fold_context_k in H1. 4:{ rewrite nth_error_map e //. } 3:len. 2:exact []. + len in H1. noconf H1. destruct c as [? [] ?]; noconf H1. + rewrite skipn_app. len. eapply All_fold_nth_error in X; tea. cbn in X. depelim X. + rewrite skipn_length in H1. + eapply expanded_subst. rewrite skipn_length. len. + replace (S n - #|bcontext x|) with 0. 2:{ lia. } rewrite skipn_0. eapply Forall_rev. solve_all. + len. rewrite app_assoc. eapply expanded_weakening. eapply expanded_subst_instance. + now rewrite skipn_repeat. } + { rewrite inst_case_branch_context_length in H0, H1. + rewrite skipn_app skipn_all2 /=; len. + replace (S n - #|bcontext x|) with (S (n - #|bcontext x|)). 2:lia. + eapply wfΓ. rewrite H1 //. } + noconf H1. - eapply expanded_tProj_inv in exp. now econstructor. - eapply expanded_mkApps_inv' in exp. rewrite head_mkApps head_nApp in exp => //. @@ -1866,7 +2118,18 @@ Proof. eapply Red1Apps.isLambda_red1 in r; tea. split => //. set(Γ'' := rev_map (fun d1 : def term => S (rarg d1)) mfix0). eapply e => //. - { intros n b hnth'. admit. } } + { intros n b hnth'. + destruct (nth_error (fix_context mfix0) n) eqn:e'. + rewrite nth_error_app_lt in hnth'. now eapply nth_error_Some_length in e'. + rewrite e' in hnth'. noconf hnth'. + pose proof (PCUICParallelReductionConfluence.fix_context_assumption_context mfix0). + eapply PCUICParallelReductionConfluence.nth_error_assumption_context in H6; tea. congruence. + rewrite /Γ''. + eapply nth_error_None in e'. len in e'. + rewrite nth_error_app_ge in hnth' => //. now len. + rewrite skipn_app skipn_all2. len. + cbn. len. replace (S n - #|mfix0|) with (S (n - #|mfix0|)). 2:{ lia. } + eapply wfΓ. now len in hnth'. } } { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } - eapply expanded_tProd. - constructor. @@ -1881,5 +2144,15 @@ Proof. destruct X0. noconf e. now rewrite -H1. - eapply expanded_tCoFix_inv in exp. econstructor. rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. - destruct X0. destruct p. noconf e. eapply e0 => //. admit. + destruct X0. destruct p. noconf e. eapply e0 => //. + intros n b. + destruct nth_error eqn:e' => //. + cbn. intros [=]. destruct c as [? [] ?]. cbn in *. noconf H4. + eapply nth_error_app_inv in e' as [[]|[]]. + { pose proof (PCUICParallelReductionConfluence.fix_context_assumption_context mfix0). + eapply PCUICParallelReductionConfluence.nth_error_assumption_context in H5; tea. cbn in H5. congruence. } + len in H3. len in H4. + rewrite skipn_app skipn_all2; len. + replace (S n - #|mfix0|) with (S (n - #|mfix0|)) by lia. eapply wfΓ. rewrite H4 /= //. + noconf H4. Qed. \ No newline at end of file From 681a3827e5371dacb705aa594ee1145d39e71fc9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Sep 2023 17:29:43 +0200 Subject: [PATCH 53/65] Refactor a bit, work on side conditions for let expansion --- erasure-plugin/theories/ErasureCorrectness.v | 88 +- erasure/theories/EEtaExpandedFix.v | 2 +- pcuic/theories/PCUICClassification.v | 6 - pcuic/theories/PCUICConfluence.v | 2 + pcuic/theories/PCUICConversion.v | 4 +- pcuic/theories/PCUICEtaExpand.v | 990 +++++++++++++++++- pcuic/theories/PCUICWcbvEval.v | 937 ----------------- pcuic/theories/PCUICWellScopedCumulativity.v | 2 + .../Typing/PCUICContextConversionTyp.v | 2 + pcuic/theories/utils/PCUICAstUtils.v | 24 + template-coq/theories/TypingWf.v | 1 - template-coq/theories/WcbvEval.v | 4 +- template-coq/theories/WfAst.v | 2 +- utils/theories/MCList.v | 1 + 14 files changed, 1077 insertions(+), 988 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 87e8f948f..dbbaacecf 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -866,11 +866,22 @@ Lemma compile_evalue_strip (Σer : EEnvMap.GlobalContextMap.t) p : firstorder_evalue Σer p -> compile_evalue_box (ERemoveParams.strip Σer p) [] = compile_evalue_box_strip Σer p []. Proof. -Admitted. + move: p. + apply: firstorder_evalue_elim; intros. + rewrite ERemoveParams.strip_mkApps //=. rewrite H. + rewrite compile_evalue_box_mkApps. + rewrite (compile_evalue_box_strip_mkApps (npars:=npars)). + rewrite lookup_inductive_pars_spec //. + rewrite !app_nil_r !skipn_map. f_equal. + rewrite map_map. + ELiftSubst.solve_all. +Qed. Arguments PCUICFirstorder.firstorder_ind _ _ : clear implicits. Section PCUICExpandLets. + Import PCUICAst. + Import PCUICEnvironment. Import PCUICExpandLets PCUICExpandLetsCorrectness. Lemma trans_axiom_free Σ : axiom_free Σ -> axiom_free (trans_global_env Σ). @@ -883,6 +894,29 @@ Section PCUICExpandLets. destruct c as [? [] ? ?] => //. Qed. + Lemma expand_lets_preserves_fo (Σ : global_env_ext) Γ v : + wf Σ -> + PCUICFirstorder.firstorder_value Σ Γ v -> + PCUICFirstorder.firstorder_value (trans_global Σ) (trans_local Γ) (trans v). + Proof. + intros wfΣ; move: v; apply: PCUICFirstorder.firstorder_value_inds. + intros i n ui u args pandi hty hargs ihargs isp. + rewrite trans_mkApps. econstructor. + apply expand_lets_sound in hty. + rewrite !trans_mkApps in hty. cbn in hty. exact hty. + ELiftSubst.solve_all. + move/negbTE: isp. + rewrite /PCUICFirstorder.isPropositional. + rewrite /lookup_inductive /lookup_inductive_gen /lookup_minductive_gen trans_lookup. + destruct lookup_env => //. destruct g => //. cbn. rewrite nth_error_mapi. + destruct nth_error => //=. + rewrite /PCUICFirstorder.isPropositionalArity. + rewrite (trans_destArity []). destruct destArity => //. + destruct p => //. now intros ->. + Qed. +End PCUICExpandLets. + + Section pipeline_theorem. Instance cf : checker_flags := extraction_checker_flags. @@ -894,7 +928,7 @@ Section pipeline_theorem. Variable t : PCUICAst.term. Variable expt : PCUICEtaExpand.expanded Σ.1 [] t. - + Variable axfree : axiom_free Σ. Variable v : PCUICAst.term. Variable i : Kernames.inductive. @@ -923,7 +957,9 @@ Section pipeline_theorem. - red. cbn. split; eauto. eexists. eapply PCUICClassification.subject_reduction_eval; eauto. - - todo "preservation of eta expandedness". + - eapply (PCUICClassification.wcbveval_red (Σ := Σ)) in X; tea. + eapply PCUICEtaExpand.expanded_red in X; tea. apply HΣ. + intros ? ?; rewrite nth_error_nil => //. - cbn. todo "normalization". - todo "normalization". Qed. @@ -952,19 +988,51 @@ Section pipeline_theorem. cbn [fst snd]. intros h. destruct_compose. + destruct Heval. + assert (eqtr : PCUICExpandLets.trans v = v). + { clear -hv. + move: v hv. + eapply PCUICFirstorder.firstorder_value_inds. + intros. + rewrite PCUICExpandLetsCorrectness.trans_mkApps /=. + f_equal. ELiftSubst.solve_all. } assert (PCUICFirstorder.firstorder_value (PCUICExpandLets.trans_global_env Σ.1, Σ.2) [] v). - { todo "expand lets preserves fo values". } + { eapply expand_lets_preserves_fo in hv; eauto. now rewrite eqtr in hv. } + assert (Normalisation': PCUICSN.NormalizationIn (PCUICExpandLets.trans_global Σ)). - { destruct h as [[] ?]. apply H0. cbn. apply X. } + { destruct h as [[] ?]. apply H0. cbn. apply X0. } set (Σ' := build_global_env_map _). set (p := transform erase_transform _ _). - pose proof (@erase_tranform_firstorder _ h v i u args Normalisation'). - forward H0. - { todo "preserves typing of fo values". } + pose proof (@erase_tranform_firstorder _ h v i u (List.map PCUICExpandLets.trans args) Normalisation'). forward H0. - { cbn. todo "preserves axiom freeness". } + { cbn. rewrite -eqtr. + eapply (PCUICClassification.subject_reduction_eval (Σ := Σ)) in X; tea. + eapply PCUICExpandLetsCorrectness.expand_lets_sound in X. + now rewrite PCUICExpandLetsCorrectness.trans_mkApps /= in X. } + forward H0. { cbn. now eapply trans_axiom_free. } forward H0. - { cbn. todo "preserves fo ind". } + { cbn. clear -HΣ fo. + move: fo. + rewrite /PCUICFirstorder.firstorder_ind /= PCUICExpandLetsCorrectness.trans_lookup /=. + destruct PCUICAst.PCUICEnvironment.lookup_env => //. destruct g => //=. + unfold PCUICFirstorder.firstorder_mutind. cbn. + move/andP => [] -> /=. ELiftSubst.solve_all. + eapply forallb_Forall in b. apply forallb_Forall. + ELiftSubst.solve_all. eapply All_mapi. + eapply All_Alli; tea. cbn. + intros n []. rewrite /PCUICFirstorder.firstorder_oneind /=. + move/andP => [] hf ->; rewrite andb_true_r. + eapply forallb_Forall in hf. apply forallb_Forall. + ELiftSubst.solve_all. + rewrite /PCUICFirstorder.firstorder_con in H *. + eapply alli_Alli. eapply alli_Alli in H. + destruct x; cbn in *. + eapply Alli_rev. + ELiftSubst.solve_all. + + re + destruct m; cbn in *. + forward H0. { cbn. todo "preserves values". } specialize (H0 _ eq_refl). diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v index 92a783a73..8c14b356c 100644 --- a/erasure/theories/EEtaExpandedFix.v +++ b/erasure/theories/EEtaExpandedFix.v @@ -1408,7 +1408,7 @@ Proof. split. eapply All2_app => //. rewrite -H3. eauto. destruct s. * destruct p; solve_discr. noconf H2. - left. split.w + left. split. unfold isStuckFix'; rewrite e1. len. eapply Nat.leb_le. lia. now rewrite -[tApp _ _](mkApps_app _ _ [av]). * right. len. eapply isEtaExp_fixapp_mon; tea. lia. diff --git a/pcuic/theories/PCUICClassification.v b/pcuic/theories/PCUICClassification.v index 47cbe786d..55908fed7 100644 --- a/pcuic/theories/PCUICClassification.v +++ b/pcuic/theories/PCUICClassification.v @@ -126,12 +126,6 @@ Lemma All2_map_left' {A B C} (P : A -> B -> Type) l l' (f : C -> A) : All2 P (map f l) l' -> All2 (fun x y => P (f x) y) l l'. Proof. intros. rewrite - (map_id l') in X. eapply All2_map_inv; eauto. Qed. -Lemma head_mkApps t args : head (mkApps t args) = head t. -Proof. - induction args using rev_ind; simpl; auto. - now rewrite mkApps_app /= head_tapp. -Qed. - Section Spines. Context {cf : checker_flags}. Context {Σ : global_env_ext}. diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index 8f7795231..5427cdec7 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -24,6 +24,8 @@ Require Import CRelationClasses CMorphisms. Require Import Equations.Prop.DepElim. Require Import Equations.Type.Relation Equations.Type.Relation_Properties. +Local Ltac intuition_solver ::= auto with *. + #[global] Instance red_Refl Σ Γ : Reflexive (red Σ Γ) := refl_red Σ Γ. diff --git a/pcuic/theories/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index 79c797d99..6e7c65626 100644 --- a/pcuic/theories/PCUICConversion.v +++ b/pcuic/theories/PCUICConversion.v @@ -3268,8 +3268,8 @@ Proof. unfold R_global_instance, R_global_instance_gen. destruct global_variance_gen. { induction i in l, i' |- *; destruct l, i'; simpl; auto; try lia; try easy. - * specialize (IHi i' []). simpl in IHi. intuition. - * intros []. intuition. + * specialize (IHi i' []). simpl in IHi. intuition auto with all. + * intros []. intuition eauto with all. } { unfold R_universe_instance. intros H % Forall2_length. now rewrite !map_length in H. } diff --git a/pcuic/theories/PCUICEtaExpand.v b/pcuic/theories/PCUICEtaExpand.v index b4db67093..2b097e2e1 100644 --- a/pcuic/theories/PCUICEtaExpand.v +++ b/pcuic/theories/PCUICEtaExpand.v @@ -1,7 +1,42 @@ -From Coq Require Import ssreflect. +From Coq Require Import ssreflect ssrbool. From Equations Require Import Equations. From MetaCoq.Utils Require Import utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICProgram PCUICCSubst. +From MetaCoq.Common Require Import config. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping + PCUICReduction PCUICProgram PCUICLiftSubst PCUICCSubst PCUICUnivSubst. + +(* todo move *) +Lemma All_fold_tip {A : Type} (P : list A -> A -> Type) {x} : All_fold P [x] -> P [] x. +Proof. + intros a; now depelim a. +Qed. + +Lemma All_tip {A} {P : A -> Type} {a : A} : P a <~> All P [a]. +Proof. split; intros. repeat constructor; auto. now depelim X. Qed. + +Lemma nApp_mkApps t f args : + t = mkApps f args -> ~~ isApp t -> t = f /\ args = []. +Proof. + intros -> napp. + destruct args using rev_case; cbn in *; solve_discr; try discriminate => //. split => //. + now rewrite mkApps_app /= in napp. +Qed. + +Ltac solve_discr := + try progress (prepare_discr; finish_discr; cbn[mkApps] in * ); + try match goal with + H : mkApps _ _ = mkApps ?f ?l |- _ => + eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H + | H : ?t = mkApps ?f ?l |- _ => + (change t with (mkApps t []) in H ; + eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H) || + (eapply nApp_mkApps in H as [? ?]; [|easy]; subst) + | H : mkApps ?f ?l = ?t |- _ => + change t with (mkApps t []) in H ; + eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence; try noconf H + end. + +(* end move *) Definition isConstruct t := match t with tConstruct _ _ _ => true | _ => false end. @@ -188,10 +223,6 @@ Definition expanded_global_env (g : global_env) := Definition expanded_pcuic_program (p : pcuic_program) := expanded_global_env p.1 /\ expanded p.1 [] p.2. - -Lemma All_tip {A} {P : A -> Type} {a : A} : P a <~> All P [a]. -Proof. split; intros. repeat constructor; auto. now depelim X. Qed. - Lemma expanded_mkApps_expanded {Σ Γ f args} : expanded Σ Γ f -> All (expanded Σ Γ) args -> expanded Σ Γ (mkApps f args). @@ -200,15 +231,11 @@ Proof. destruct (isConstruct f || isFix f || isRel f) eqn:eqc. destruct f => //. - depelim H; solve_discr. eapply expanded_tRel; tea. cbn in Hle. lia. solve_all. - destruct args0 using rev_case; cbn in *; subst. cbn in H. congruence. - rewrite mkApps_app in H2; noconf H2. + now rewrite eqc in H. - depelim H; solve_discr. - destruct args0 using rev_case; cbn in *; subst. cbn in H. congruence. - rewrite mkApps_app in H2; noconf H2. + now rewrite eqc in H. eapply expanded_tConstruct_app; tea. cbn in H0. lia. solve_all. - - depelim H; solve_discr. - destruct args0 using rev_case; cbn in *; subst. cbn in H. congruence. - rewrite mkApps_app in H2; noconf H2. + - depelim H; solve_discr. now rewrite eqc in H. - eapply expanded_mkApps. now rewrite eqc. auto. solve_all. Qed. @@ -341,19 +368,6 @@ Proof. solve_all. Qed. -Lemma csubst_mkApps a k f l : - csubst a k (mkApps f l) = mkApps (csubst a k f) (map (csubst a k) l). -Proof. - induction l in f |- *; cbn; [auto|]. - rewrite IHl. - now cbn. -Qed. - -Lemma All_fold_tip {A : Type} (P : list A -> A -> Type) {x} : All_fold P [x] -> P [] x. -Proof. - intros a; now depelim a. -Qed. - Lemma expanded_let_expansion Σ (Δ : context) Γ t : expanded_context Σ Γ Δ -> expanded Σ (repeat 0 #|Δ| ++ Γ) t -> @@ -394,8 +408,6 @@ Proof. exact exp. lia. Qed. -Require Import PCUICUnivSubst. - Lemma subst_instance_isConstruct t u : isConstruct t@[u] = isConstruct t. Proof. destruct t => //. Qed. Lemma subst_instance_isRel t u : isRel t@[u] = isRel t. @@ -434,3 +446,925 @@ Proof. all:intros; try solve [econstructor; eauto 1; solve_all; try now rewrite app_assoc]. Qed. + +Lemma expanded_tApp (Σ : global_env) (Γ : list nat) (f : term) a : + expanded Σ Γ f -> expanded Σ Γ a -> + expanded Σ Γ (tApp f a). +Proof. + induction 1 using expanded_ind; intros expa. + all:rewrite -?[tApp _ a](mkApps_app _ _ [a]). + all:try (eapply (expanded_mkApps _ _ _ [a]) => //; econstructor; eauto). + + - econstructor; tea. rewrite app_length. lia. eapply app_Forall;eauto. + - econstructor; tea. eapply app_Forall; eauto. + - eapply expanded_tFix; tea. eapply app_Forall; eauto. eauto. rewrite app_length; cbn; eauto. lia. + - eapply expanded_tConstruct_app; tea. rewrite app_length ; lia. eapply app_Forall; eauto. +Qed. + +Lemma expanded_tApp_inv Σ Γ f a : + ~ isConstruct (head f) || isFix (head f) || isRel (head f) -> + expanded Σ Γ (tApp f a) -> + expanded Σ Γ f /\ expanded Σ Γ a. +Proof. + intros hf exp; depind exp. + - destruct args using rev_case; solve_discr; try discriminate. + rewrite mkApps_app in H3; noconf H3. + eapply Forall_app in H1 as [? ha]. depelim ha. + destruct args using rev_case; cbn in hf => //. + now rewrite !head_mkApps /= in hf. + - destruct args using rev_case; solve_discr. subst f6. + eapply IHexp => //. + rewrite mkApps_app in H2; noconf H2. + eapply Forall_app in H0 as [? H0]. depelim H0. split => //. + rewrite !head_mkApps in hf. + eapply expanded_mkApps => //. + - destruct args using rev_case; solve_discr. discriminate. + rewrite mkApps_app in H6; noconf H6. + eapply Forall_app in H1 as [? h]. depelim h. split => //. + now rewrite !head_mkApps /= in hf. + - destruct args using rev_case; solve_discr. discriminate. + rewrite mkApps_app in H3; noconf H3. + now rewrite !head_mkApps /= in hf. +Qed. + +Lemma expanded_tLambda_inv Σ Γ na t b : + expanded Σ Γ (tLambda na t b) -> + expanded Σ (0 :: Γ) b. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tLetIn_inv Σ Γ na t t' b : + expanded Σ Γ (tLetIn na t t' b) -> + expanded Σ Γ t /\ expanded Σ (0 :: Γ) b. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tEvar_inv Σ Γ ev l: + expanded Σ Γ (tEvar ev l) -> + Forall (expanded Σ Γ) l. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tCase_inv Σ Γ ci p c brs : + expanded Σ Γ (tCase ci p c brs) -> + Forall (expanded Σ Γ) (pparams p) /\ + Forall + (fun br : branch term => + ∥ All_fold + (fun (Δ : list context_decl) (d : context_decl) + => + ForOption + (fun b : term => + expanded Σ + (repeat 0 #|Δ| ++ + repeat 0 #|pparams p|) b) + (decl_body d)) (bcontext br) ∥ /\ + expanded Σ (repeat 0 #|bcontext br| ++ Γ) (bbody br)) + brs /\ + expanded Σ Γ c. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tProj_inv Σ Γ p c : + expanded Σ Γ (tProj p c) -> + expanded Σ Γ c. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Lemma expanded_tCoFix_inv Σ Γ mfix idx : + expanded Σ Γ (tCoFix mfix idx) -> + Forall (fun d : def term => expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix. +Proof. + intros exp; depind exp; solve_discr => //; eauto. +Qed. + +Import PCUICOnOne. + +Module Red1Apps. + + Set Warnings "-notation-overridden". + + Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := + (** Reductions *) + (** Beta *) + | red_beta na t b a ts : + Σ ;;; Γ |- mkApps (tLambda na t b) (a :: ts) ⇝ mkApps (b {0 := a}) ts + + (** Let *) + | red_zeta na b t b' : + Σ ;;; Γ |- tLetIn na b t b' ⇝ b' {0 := b} + + | red_rel i body : + option_map decl_body (nth_error Γ i) = Some (Some body) -> + Σ ;;; Γ |- tRel i ⇝ lift0 (S i) body + + (** Case *) + | red_iota ci c u args p brs br : + nth_error brs c = Some br -> + #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> + Σ ;;; Γ |- tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs + ⇝ iota_red ci.(ci_npar) p args br + + (** Fix unfolding, with guard *) + | red_fix mfix idx args narg fn : + unfold_fix mfix idx = Some (narg, fn) -> + is_constructor narg args = true -> + Σ ;;; Γ |- mkApps (tFix mfix idx) args ⇝ mkApps fn args + + (** CoFix-case unfolding *) + | red_cofix_case ip p mfix idx args narg fn brs : + unfold_cofix mfix idx = Some (narg, fn) -> + Σ ;;; Γ |- tCase ip p (mkApps (tCoFix mfix idx) args) brs ⇝ + tCase ip p (mkApps fn args) brs + + (** CoFix-proj unfolding *) + | red_cofix_proj p mfix idx args narg fn : + unfold_cofix mfix idx = Some (narg, fn) -> + Σ ;;; Γ |- tProj p (mkApps (tCoFix mfix idx) args) ⇝ tProj p (mkApps fn args) + + (** Constant unfolding *) + | red_delta c decl body (isdecl : declared_constant Σ c decl) u : + decl.(cst_body) = Some body -> + Σ ;;; Γ |- tConst c u ⇝ subst_instance u body + + (** Proj *) + | red_proj p args u arg: + nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg -> + Σ ;;; Γ |- tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args) ⇝ arg + + + | abs_red_l na M M' N : Σ ;;; Γ |- M ⇝ M' -> Σ ;;; Γ |- tLambda na M N ⇝ tLambda na M' N + | abs_red_r na M M' N : Σ ;;; Γ ,, vass na N |- M ⇝ M' -> Σ ;;; Γ |- tLambda na N M ⇝ tLambda na N M' + + | letin_red_def na b t b' r : Σ ;;; Γ |- b ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na r t b' + | letin_red_ty na b t b' r : Σ ;;; Γ |- t ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na b r b' + | letin_red_body na b t b' r : Σ ;;; Γ ,, vdef na b t |- b' ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na b t r + + | case_red_param ci p params' c brs : + OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) p.(pparams) params' -> + Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_pparams p params') c brs + + | case_red_return ci p preturn' c brs : + Σ ;;; Γ ,,, inst_case_predicate_context p |- p.(preturn) ⇝ preturn' -> + Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_preturn p preturn') c brs + + | case_red_discr ci p c c' brs : + Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c' brs + + | case_red_brs ci p c brs brs' : + OnOne2 (fun br br' => + on_Trel_eq (fun t u => Σ ;;; Γ ,,, inst_case_branch_context p br |- t ⇝ u) bbody bcontext br br') + brs brs' -> + Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c brs' + + | proj_red p c c' : Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tProj p c ⇝ tProj p c' + + | app_red_l M1 N1 M2 : Σ ;;; Γ |- M1 ⇝ N1 -> ~~ isApp M1 -> ~~ isFix M1 -> M2 <> nil -> + Σ ;;; Γ |- mkApps M1 M2 ⇝ mkApps N1 M2 + + | app_red_r M2 N2 M1 : ~~ isApp M1 -> OnOne2 (fun M2 N2 => Σ ;;; Γ |- M2 ⇝ N2) M2 N2 -> Σ ;;; Γ |- mkApps M1 M2 ⇝ mkApps M1 N2 + + | app_fix_red_ty mfix0 mfix1 idx M2 : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- mkApps (tFix mfix0 idx) M2 ⇝ mkApps (tFix mfix1 idx) M2 + + | app_fix_red_body mfix0 mfix1 idx M2 : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- mkApps (tFix mfix0 idx) M2 ⇝ mkApps (tFix mfix1 idx) M2 + + | prod_red_l na M1 M2 N1 : Σ ;;; Γ |- M1 ⇝ N1 -> Σ ;;; Γ |- tProd na M1 M2 ⇝ tProd na N1 M2 + | prod_red_r na M2 N2 M1 : Σ ;;; Γ ,, vass na M1 |- M2 ⇝ N2 -> + Σ ;;; Γ |- tProd na M1 M2 ⇝ tProd na M1 N2 + + | evar_red ev l l' : OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) l l' -> Σ ;;; Γ |- tEvar ev l ⇝ tEvar ev l' + + | fix_red_ty mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- tFix mfix0 idx ⇝ tFix mfix1 idx + + | fix_red_body mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) + mfix0 mfix1 -> + Σ ;;; Γ |- tFix mfix0 idx ⇝ tFix mfix1 idx + + | cofix_red_ty mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- tCoFix mfix0 idx ⇝ tCoFix mfix1 idx + + | cofix_red_body mfix0 mfix1 idx : + OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + Σ ;;; Γ |- tCoFix mfix0 idx ⇝ tCoFix mfix1 idx + where " Σ ;;; Γ |- t ⇝ u " := (red1 Σ Γ t u). + + Lemma red1_ind_all : + forall (Σ : global_env) (P : context -> term -> term -> Type), + + (forall (Γ : context) (na : aname) (t b a : term) ts, + P Γ (mkApps (tLambda na t b) (a :: ts)) (mkApps (b {0 := a}) ts)) -> + + (forall (Γ : context) (na : aname) (b t b' : term), P Γ (tLetIn na b t b') (b' {0 := b})) -> + + (forall (Γ : context) (i : nat) (body : term), + option_map decl_body (nth_error Γ i) = Some (Some body) -> P Γ (tRel i) ((lift0 (S i)) body)) -> + + (forall (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term) + (p : predicate term) (brs : list (branch term)) br, + nth_error brs c = Some br -> + #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> + P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + (iota_red ci.(ci_npar) p args br)) -> + + (forall (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), + unfold_fix mfix idx = Some (narg, fn) -> + is_constructor narg args = true -> P Γ (mkApps (tFix mfix idx) args) (mkApps fn args)) -> + + (forall (Γ : context) ci (p : predicate term) (mfix : mfixpoint term) (idx : nat) + (args : list term) (narg : nat) (fn : term) (brs : list (branch term)), + unfold_cofix mfix idx = Some (narg, fn) -> + P Γ (tCase ci p (mkApps (tCoFix mfix idx) args) brs) (tCase ci p (mkApps fn args) brs)) -> + + (forall (Γ : context) (p : projection) (mfix : mfixpoint term) (idx : nat) (args : list term) + (narg : nat) (fn : term), + unfold_cofix mfix idx = Some (narg, fn) -> P Γ (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args))) -> + + (forall (Γ : context) c (decl : constant_body) (body : term), + declared_constant Σ c decl -> + forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance u body)) -> + + (forall (Γ : context) p (args : list term) (u : Instance.t) + (arg : term), + nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg -> + P Γ (tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args)) arg) -> + + (forall (Γ : context) (na : aname) (M M' N : term), + red1 Σ Γ M M' -> P Γ M M' -> P Γ (tLambda na M N) (tLambda na M' N)) -> + + (forall (Γ : context) (na : aname) (M M' N : term), + red1 Σ (Γ,, vass na N) M M' -> P (Γ,, vass na N) M M' -> P Γ (tLambda na N M) (tLambda na N M')) -> + + (forall (Γ : context) (na : aname) (b t b' r : term), + red1 Σ Γ b r -> P Γ b r -> P Γ (tLetIn na b t b') (tLetIn na r t b')) -> + + (forall (Γ : context) (na : aname) (b t b' r : term), + red1 Σ Γ t r -> P Γ t r -> P Γ (tLetIn na b t b') (tLetIn na b r b')) -> + + (forall (Γ : context) (na : aname) (b t b' r : term), + red1 Σ (Γ,, vdef na b t) b' r -> P (Γ,, vdef na b t) b' r -> P Γ (tLetIn na b t b') (tLetIn na b t r)) -> + + (forall (Γ : context) (ci : case_info) p params' c brs, + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) p.(pparams) params' -> + P Γ (tCase ci p c brs) + (tCase ci (set_pparams p params') c brs)) -> + + (forall (Γ : context) (ci : case_info) p preturn' c brs, + red1 Σ (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> + P (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> + P Γ (tCase ci p c brs) + (tCase ci (set_preturn p preturn') c brs)) -> + + (forall (Γ : context) (ind : case_info) (p : predicate term) (c c' : term) (brs : list (branch term)), + red1 Σ Γ c c' -> P Γ c c' -> P Γ (tCase ind p c brs) (tCase ind p c' brs)) -> + + (forall (Γ : context) ci p c brs brs', + OnOne2 (fun br br' => + (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, inst_case_branch_context p br)) + (P (Γ ,,, inst_case_branch_context p br))) + bbody bcontext br br')) brs brs' -> + P Γ (tCase ci p c brs) (tCase ci p c brs')) -> + + (forall (Γ : context) (p : projection) (c c' : term), red1 Σ Γ c c' -> P Γ c c' -> + P Γ (tProj p c) (tProj p c')) -> + + (forall (Γ : context) M1 N1 M2, red1 Σ Γ M1 N1 -> P Γ M1 N1 -> ~~ isApp M1 -> ~~ isFix M1 -> M2 <> [] -> + P Γ (mkApps M1 M2) (mkApps N1 M2)) -> + + (forall (Γ : context) M1 N2 M2, ~~ isApp M1 -> + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) M2 N2 -> + P Γ (mkApps M1 M2) (mkApps M1 N2)) -> + + (forall (Γ : context) mfix0 mfix1 idx M2, + OnOne2 (on_Trel_eq (Trel_conj (fun t u => Σ ;;; Γ |- t ⇝ u) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + P Γ (mkApps (tFix mfix0 idx) M2) (mkApps (tFix mfix1 idx) M2)) -> + + (forall (Γ : context) mfix0 mfix1 idx M2, + OnOne2 (on_Trel_eq (Trel_conj (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) (P (Γ ,,, fix_context mfix0))) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + P Γ (mkApps (tFix mfix0 idx) M2) (mkApps (tFix mfix1 idx) M2)) -> + + (forall (Γ : context) (na : aname) (M1 M2 N1 : term), + red1 Σ Γ M1 N1 -> P Γ M1 N1 -> P Γ (tProd na M1 M2) (tProd na N1 M2)) -> + + (forall (Γ : context) (na : aname) (M2 N2 M1 : term), + red1 Σ (Γ,, vass na M1) M2 N2 -> P (Γ,, vass na M1) M2 N2 -> P Γ (tProd na M1 M2) (tProd na M1 N2)) -> + + (forall (Γ : context) (ev : nat) (l l' : list term), + OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) l l' -> P Γ (tEvar ev l) (tEvar ev l')) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + P Γ (tFix mfix0 idx) (tFix mfix1 idx)) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, fix_context mfix0)) + (P (Γ ,,, fix_context mfix0))) dbody + (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + P Γ (tFix mfix0 idx) (tFix mfix1 idx)) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> + P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> + + (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), + OnOne2 (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, fix_context mfix0)) + (P (Γ ,,, fix_context mfix0))) dbody + (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> + P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> + + forall (Γ : context) (t t0 : term), red1 Σ Γ t t0 -> P Γ t t0. + Proof. + intros. rename X29 into Xlast. revert Γ t t0 Xlast. + fix aux 4. intros Γ t T. + move aux at top. + destruct 1; match goal with + | |- P _ (tFix _ _) (tFix _ _) => idtac + | |- P _ (tCoFix _ _) (tCoFix _ _) => idtac + | |- P _ (mkApps (tFix _ _) _) _ => idtac + | |- P _ (tCase _ _ (mkApps (tCoFix _ _) _) _) _ => idtac + | |- P _ (tProj _ (mkApps (tCoFix _ _) _)) _ => idtac + | H : _ |- _ => eapply H; eauto + end. + - eapply X3; eauto. + - eapply X4; eauto. + - eapply X5; eauto. + + - revert params' o. + generalize (pparams p). + fix auxl 3. + intros params params' []. + + constructor. split; auto. + + constructor. auto. + + - revert brs' o. + revert brs. + fix auxl 3. + intros l l' Hl. destruct Hl. + + simpl in *. constructor; intros; intuition auto. + + constructor. eapply auxl. apply Hl. + + - revert M2 N2 o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor. split; auto. + + constructor. auto. + + - eapply X20. + revert mfix0 mfix1 o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor; split; auto; intuition. + + constructor; try split; auto; intuition. + + - eapply X21. revert o. + generalize (fix_context mfix0). + intros c o. revert mfix0 mfix1 o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor. split; auto; intuition. + + constructor; try split; auto; intuition. + + - revert l l' o. + fix auxl 3. + intros l l' Hl. destruct Hl. + + constructor. split; auto. + + constructor. auto. + + - eapply X25. + revert mfix0 mfix1 o; fix auxl 3. + intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. + + - eapply X26. + revert o. generalize (fix_context mfix0). intros c Xnew. + revert mfix0 mfix1 Xnew; fix auxl 3; intros l l' Hl; + destruct Hl; constructor; try split; auto; intuition. + + - eapply X27. + revert mfix0 mfix1 o. + fix auxl 3; intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. + + - eapply X28. + revert o. generalize (fix_context mfix0). intros c new. + revert mfix0 mfix1 new; fix auxl 3; intros l l' Hl; destruct Hl; + constructor; try split; auto; intuition. + Defined. + + Lemma red_tApp Σ Γ t v u : + red1 Σ Γ t v -> + red1 Σ Γ (tApp t u) (tApp v u). + Proof. + induction 1. + all:try solve [eapply (app_red_l _ _ _ _ [u]) => //; econstructor; eauto]. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). + eapply red_beta. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. + now apply is_constructor_app_ge. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. + now eapply OnOne2_app_r. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). now eapply app_fix_red_ty. + - rewrite -![tApp _ u](mkApps_app _ _ [u]). now eapply app_fix_red_body. + - now eapply (app_fix_red_ty _ _ _ _ _ [_]). + - now eapply (app_fix_red_body _ _ _ _ _ [_]). + Qed. + + Lemma isLambda_red1 Σ Γ b b' : isLambda b -> red1 Σ Γ b b' -> isLambda b'. + Proof. + destruct b; simpl; try discriminate. + intros _ red. + depelim red; solve_discr; eauto. depelim o. + Qed. + +End Red1Apps. + +Lemma red1_red1apps Σ Γ t v : + red1 Σ Γ t v -> Red1Apps.red1 Σ Γ t v. +Proof. + intros red; induction red using red1_ind_all in |- *. + all:try solve [econstructor; eauto; solve_all; eauto]. + - eapply (Red1Apps.red_beta _ _ _ _ _ _ []). + - now eapply Red1Apps.red_tApp. + - remember (decompose_app (tApp M1 M2)). + destruct p as [hd args]. + edestruct (decompose_app_rec_inv' M1 [M2]). rewrite /decompose_app in Heqp. + cbn in Heqp. rewrite -Heqp. reflexivity. + destruct a as [napp [hm2 hm1]]. + symmetry in Heqp; eapply decompose_app_inv in Heqp. rewrite Heqp. + assert (tApp M1 N2 = mkApps hd (firstn x args ++ [N2])) as ->. + { now rewrite mkApps_app -hm1. } + rewrite -{1}(firstn_skipn x args) -hm2. eapply Red1Apps.app_red_r => //. + eapply OnOne2_app. now constructor. +Qed. + +Lemma head_nApp f : + ~~ isApp f -> head f = f. +Proof. + induction f => //. +Qed. + +Lemma expanded_mkApps_inv Σ Γ f v : + ~~ isApp f -> + ~~ (isConstruct f || isFix f || isRel f) -> + expanded Σ Γ (mkApps f v) -> + expanded Σ Γ f /\ Forall (expanded Σ Γ) v. +Proof. + intros happ hc. + induction v using rev_ind; cbn. + - intros exp; split => //. + - rewrite mkApps_app /=. + move/expanded_tApp_inv => e. + forward e. rewrite head_mkApps. + rewrite head_nApp //. now move/negbTE: hc ->. + intuition auto. eapply app_Forall; eauto. +Qed. + +Lemma expanded_mkApps_inv' Σ Γ f : + expanded Σ Γ f -> + let args := arguments f in + Forall (expanded Σ Γ) args /\ + match head f with + | tRel n => exists m, nth_error Γ n = Some m /\ m <= #|args| + | tConstruct ind c u => exists mind idecl cdecl, + declared_constructor Σ (ind, c) mind idecl cdecl /\ #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) + | tFix mfix idx => exists d, + Forall + (fun d0 : def term => + isLambda (dbody d0) /\ + (let ctx := + rev_map (fun d1 : def term => (1 + rarg d1)%nat) + mfix in + expanded Σ (ctx ++ Γ) (dbody d0))) mfix /\ + args <> [] /\ + nth_error mfix idx = Some d /\ #|args| > rarg d + | _ => expanded Σ Γ (head f) + end. +Proof. + induction 1 using expanded_ind; cbn. + all: try solve [split; econstructor; eauto]. + all:rewrite head_mkApps /=. + - rewrite arguments_mkApps_nApp //. split => //. now exists m. + - destruct IHexpanded. rewrite arguments_mkApps. split. + eapply app_Forall => //. + rewrite app_length. + destruct (head f6) => //; firstorder (eauto; try lia). + exists x. split => //. firstorder (eauto; try lia). + intros heq; apply H5. now eapply app_eq_nil in heq. + - rewrite arguments_mkApps_nApp //. split => //. now exists d. + - rewrite arguments_mkApps_nApp //. split => //. + firstorder. +Qed. + +Lemma All_fold_map_context (P : context -> context_decl -> Type) (f : term -> term) ctx : + All_fold P (map_context f ctx) <~> All_fold (fun Γ d => P (map_context f Γ) (map_decl f d)) ctx. +Proof. + induction ctx. + - split; constructor. + - cbn. split; intros H; depelim H; constructor; auto; now apply IHctx. +Qed. + +Lemma expanded_fix_subst Σ a k b Γ Γs Δ : + #|Γ| = k -> + Forall2 (fun n arg => forall args Γ' k', + Forall (expanded Σ (Γ' ++ Δ)) args -> + n <= #|args| -> + #|Γ'| = k' -> + expanded Σ (Γ' ++ Δ) (mkApps (lift0 k' arg) args)) Γs a -> + expanded Σ (Γ ++ Γs ++ Δ) b -> + expanded Σ (Γ ++ Δ) (subst a k b). +Proof. + intros Hk Hs. + remember (Γ ++ _ ++ Δ)%list as Γ_. + intros exp; revert Γ k Hk HeqΓ_. + induction exp using expanded_ind; intros Γ' k Hk ->. + all:try solve[ cbn; econstructor => // ]. + 2,7:solve[ cbn; econstructor => //; solve_all ]. + - rewrite subst_mkApps /=. + destruct (Nat.leb_spec k n). + destruct (nth_error a _) eqn:hnth. + * pose proof (Forall2_length Hs). + pose proof (Forall2_nth_error_Some_r _ _ _ _ _ _ _ hnth Hs) as [t' [hnth' hargs]]. + eapply hargs => //. + eapply Forall_map. + 2:{ len. rewrite nth_error_app_ge in H. lia. subst k. + rewrite nth_error_app_lt in H. + eapply nth_error_Some_length in hnth'. lia. rewrite hnth' in H. noconf H. exact H0. } + solve_all. + * rewrite nth_error_app_ge in H. lia. + eapply nth_error_None in hnth. + pose proof (Forall2_length Hs). + rewrite nth_error_app_ge in H. lia. + eapply expanded_tRel. rewrite nth_error_app_ge. lia. erewrite <- H. + lia_f_equal. len. solve_all. + * rewrite nth_error_app_lt in H. lia. + eapply expanded_tRel. rewrite nth_error_app_lt. lia. tea. now len. + solve_all. + - cbn. econstructor. + eapply (IHexp (0 :: Γ') (S k)); cbn; auto; try lia. + - cbn. econstructor. apply IHexp1; auto. + eapply (IHexp2 (0 :: Γ') (S k)); cbn; auto; lia. + - rewrite subst_mkApps. + destruct (isConstruct (subst a k f6) || isFix (subst a k f6) || isRel (subst a k f6)) eqn:eqc. + specialize (IHexp _ _ Hk eq_refl). + eapply expanded_mkApps_expanded => //. solve_all. + eapply expanded_mkApps => //. rewrite eqc //. now eapply IHexp. solve_all. + - cbn. econstructor. eauto. cbn. solve_all. solve_all. + specialize (H1 (repeat 0 #|bcontext x| ++ Γ') (#|bcontext x| + k)%nat). + forward H1 by len. + forward H1. now rewrite app_assoc. + rewrite /id. rewrite app_assoc. apply H1. + - rewrite subst_mkApps. cbn. + eapply expanded_tFix. + + solve_all. now eapply isLambda_subst. + specialize (a0 + (rev_map (fun d0 : def term => S (rarg d0)) + (map (map_def (subst a k) (subst a (#|mfix| + k))) mfix) ++ Γ') (#|mfix| + k)%nat). + forward a0 by len. + forward a0. { rewrite app_assoc. f_equal. f_equal. + rewrite !rev_map_spec. f_equal. now rewrite map_map_compose /=. } + rewrite app_assoc. eapply a0. + + solve_all. + + now destruct args. + + rewrite nth_error_map /= H4 //. + + len. + - cbn. constructor. + solve_all. + specialize (a0 (repeat 0 #|mfix| ++ Γ') (#|mfix| + k)%nat). + forward a0 by len. + forward a0. { rewrite app_assoc //. } + rewrite app_assoc. eapply a0. + - rewrite subst_mkApps. cbn. + eapply expanded_tConstruct_app; tea. now len. + solve_all. +Qed. + +Lemma expanded_unfold_fix Σ Γ' mfix idx narg fn : + unfold_fix mfix idx = Some (narg, fn) -> + All (fun d0 : def term => isLambda (dbody d0) /\ expanded Σ (rev_map (fun d1 : def term => S (rarg d1)) mfix ++ Γ') (dbody d0)) mfix -> + expanded Σ Γ' fn. +Proof. + unfold unfold_fix. + destruct nth_error eqn:e => //. + intros [= <- <-] hf. + pose proof (nth_error_all e hf) as [hl hf']. + eapply (expanded_fix_subst _ _ _ _ []) => //; tea. + rewrite rev_map_spec. + eapply Forall2_from_nth_error. len. + intros n rarg f. len. intros hn hrarg hnthf args Γ'' k' hargs hrarg' <-. + eapply PCUICParallelReductionConfluence.nth_error_fix_subst in hnthf. subst f. + move: hrarg. + rewrite nth_error_rev; len. rewrite List.rev_involutive nth_error_map. + intros hrarg. + destruct (nth_error mfix (_ - _)) eqn:e'. cbn in hrarg. noconf hrarg. + eapply expanded_tFix => //. solve_all. + eapply expanded_lift; len. rewrite !rev_map_spec in H1 *. + rewrite map_map => //. destruct args => //. cbn in hrarg'. lia. + rewrite nth_error_map /= e' /= //. cbn. lia. + eapply nth_error_None in e'. lia. +Qed. + +Lemma expanded_unfold_cofix Σ Γ' mfix idx narg fn : + unfold_cofix mfix idx = Some (narg, fn) -> + All (fun d0 : def term => expanded Σ (repeat 0 #|mfix| ++ Γ') (dbody d0)) mfix -> + expanded Σ Γ' fn. +Proof. + unfold unfold_cofix. + destruct nth_error eqn:e => //. + intros [= <- <-] hf. + pose proof (nth_error_all e hf) as hf'. + eapply (expanded_subst _ _ _ _ []) => //; tea. + rewrite /cofix_subst. + generalize #|mfix|. + induction n; repeat constructor; eauto. solve_all. + len. +Qed. + +Lemma expanded_weakening_env {cf : checker_flags} Σ Σ' Γ t : + wf Σ' -> + extends Σ Σ' -> + expanded Σ Γ t -> expanded Σ' Γ t. +Proof. + intros w s. + eapply expanded_ind; intros. + all:try solve [econstructor; eauto]. + - econstructor; eauto. solve_all. sq. eapply All_fold_impl; tea. cbn. + intros. now rewrite repeat_app in H6. + - eapply expanded_tFix; eauto. solve_all. + - eapply expanded_tConstruct_app; eauto. + eapply PCUICWeakeningEnv.weakening_env_declared_constructor; tea. +Qed. + +Lemma expanded_global_env_constant {cf : checker_flags} Σ c decl : + wf Σ -> + expanded_global_env Σ -> + declared_constant Σ c decl -> + ForOption (expanded Σ []) (cst_body decl). +Proof. + intros wf; destruct Σ as [Σ univs] => /=. cbn. + unfold expanded_global_env. cbn. + induction 1; cbn => //. + intros [->|H']. + - depelim H0. + destruct decl as [? [] ?]; cbn in *. + constructor. cbn. + eapply expanded_weakening_env; tea. + eapply extends_strictly_on_decls_extends. + split => //=. eapply incl_cs_refl. 2:eapply Retroknowledge.extends_refl. + set (cb := ConstantDecl _). now exists [(c, cb)]. + constructor. + - forward IHexpanded_global_declarations. + destruct wf. cbn in *. split => //. + cbn. now depelim o0. + eapply IHexpanded_global_declarations in H'. + destruct decl as [? [] ?]; cbn in * => //. 2:constructor. + depelim H'. constructor. + eapply expanded_weakening_env; tea. + eapply extends_strictly_on_decls_extends. + split => //=. eapply incl_cs_refl. 2:eapply Retroknowledge.extends_refl. + now exists [decl0]. +Qed. + +Lemma All_fold_nth_error P (ctx : context) n b : + All_fold P ctx -> nth_error ctx n = Some b -> + P (skipn (S n) ctx) b. +Proof. + induction 1 in n, b |- *. + - rewrite nth_error_nil //. + - destruct n => //=. + * intros [= <-]. now rewrite skipn_S skipn_0. + * intros hnth. now rewrite skipn_S. +Qed. + +Lemma skipn_repeat {A} k n (a : A) : + skipn n (repeat a k) = repeat a (k - n). +Proof. + induction n in k |- *. + - rewrite skipn_0. lia_f_equal. + - destruct k => //=. + rewrite skipn_S IHn. lia_f_equal. +Qed. + +Lemma expanded_red1 {cf : checker_flags} {Σ : global_env_ext} Γ Γ' t v : wf Σ -> + expanded_global_env Σ -> + (forall n body, option_map decl_body (nth_error Γ n) = Some (Some body) -> expanded Σ (skipn (S n) Γ') body) -> + red1 Σ Γ t v -> + expanded Σ Γ' t -> + expanded Σ Γ' v. +Proof. + move=> wf expΣ wfΓ /red1_red1apps red. + induction red using Red1Apps.red1_ind_all in wfΓ, Γ' |- *; intros exp. + - eapply expanded_mkApps_inv in exp as [] => //. + eapply expanded_tLambda_inv in H. + depelim H0. + eapply expanded_mkApps_expanded => //. + eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. solve_all. + - eapply expanded_tLetIn_inv in exp as []. + eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. + - rewrite -(firstn_skipn (S i) Γ'). + eapply expanded_mkApps_inv' in exp; cbn in exp. + destruct exp as [_ [m []]]. eapply nth_error_Some_length in H0. + eapply (expanded_lift _ _ _ _ []) => //. + rewrite firstn_length_le; try lia. + now eapply wfΓ. + - eapply expanded_tCase_inv in exp as [? []]. + unfold iota_red. + move/expanded_mkApps_inv': H3 => /=. + rewrite arguments_mkApps_nApp // head_mkApps //=. + intros [hargs [mind [idecl [cdecl [declc hargs']]]]]. + eapply nth_error_forall in H2; tea. + destruct H2 as [[hbctx] hbod]. + eapply (expanded_subst _ _ _ _ [] _) => //. + + eapply Forall_rev, Forall_skipn => //. + + len. replace #|skipn (ci_npar ci) args| with (context_assumptions (inst_case_branch_context p br)). + eapply expanded_let_expansion; len. red. + sq. rewrite /inst_case_branch_context /inst_case_context /subst_context. + eapply PCUICParallelReduction.All_fold_fold_context_k. + eapply All_fold_map_context, All_fold_impl; tea; cbn. + intros ? ? fo. len. destruct x as [? [] ?] => //; constructor. + cbn in fo. depelim fo. eapply (expanded_subst _ _ _ _ (repeat 0 #|Γ0|) _); len. + eapply Forall_rev; eauto. + eapply expanded_subst_instance. rewrite app_assoc. now eapply expanded_weakening. + rewrite skipn_length. len. + - move/expanded_mkApps_inv': exp. cbn. + rewrite arguments_mkApps_nApp // head_mkApps //=. + move=> [hargs [d [hf [hargs' []]]]] hnth hrarg. + eapply expanded_mkApps_expanded => //; solve_all. + eapply expanded_unfold_fix in H; tea. + - eapply expanded_tCase_inv in exp as [? []]. + constructor => //. + eapply expanded_mkApps_inv' in H2. move: H2; rewrite arguments_mkApps_nApp // head_mkApps //=. + intros [hargs' hcof]. cbn in hcof. eapply expanded_tCoFix_inv in hcof. + eapply expanded_unfold_cofix in H; tea. eapply expanded_mkApps_expanded; tea => //; solve_all. solve_all. + - eapply expanded_tProj_inv in exp. econstructor. + eapply expanded_mkApps_inv' in exp. move: exp; rewrite arguments_mkApps_nApp // head_mkApps //=. + intros [hargs' hcof]. cbn in hcof. eapply expanded_tCoFix_inv in hcof. + eapply expanded_mkApps_expanded => //; solve_all. + eapply expanded_unfold_cofix in H; tea. + - eapply expanded_subst_instance. + eapply expanded_global_env_constant in expΣ; tea. + eapply (expanded_weakening _ []). rewrite H0 in expΣ. now depelim expΣ. + - eapply expanded_tProj_inv in exp. + move/expanded_mkApps_inv': exp. rewrite arguments_mkApps_nApp // head_mkApps //=. + intros []. + eapply nth_error_forall in H0; tea. + - constructor. now eapply expanded_tLambda_inv in exp. + - constructor. eapply expanded_tLambda_inv in exp. + eapply IHred => //. + { intros [] body; cbn => //. rewrite skipn_S. eapply wfΓ. } + - eapply expanded_tLetIn_inv in exp; now constructor. + - eapply expanded_tLetIn_inv in exp. now constructor. + - eapply expanded_tLetIn_inv in exp. constructor; intuition eauto. + eapply IHred => //. + { intros [] ? => //=. intros [=]. subst b. now rewrite skipn_S skipn_0. + rewrite skipn_S. eapply wfΓ. } + - eapply expanded_tCase_inv in exp as [? []]. + constructor; eauto. cbn. + solve_all. eapply OnOne2_impl_All_r; tea. intuition eauto. now apply X0. + now rewrite /PCUICOnOne.set_pparams /= -(OnOne2_length X). + - eapply expanded_tCase_inv in exp as [? []]. + constructor; eauto. + - eapply expanded_tCase_inv in exp as [? []]. + econstructor; eauto. + - eapply expanded_tCase_inv in exp as [? []]. + econstructor; eauto. solve_all. + eapply OnOne2_impl_All_r; tea. + intros x y [? ?]. intros [[] ?]. rewrite -e0. + solve_all. eapply e => //. + intros n b. + clear -H H2 wfΓ. + destruct nth_error eqn:e' => //. + cbn. intros [=]. destruct c as [? [] ?]. cbn in *. noconf H1. + eapply nth_error_app_inv in e' as [[]|[]]. + { rewrite inst_case_branch_context_length in H0. destruct H2. + rewrite /inst_case_branch_context /inst_case_context in H1. + destruct (nth_error (bcontext x) n) eqn:e. + 2:{ eapply nth_error_None in e. rewrite skipn_app skipn_all2. len. cbn. len. } + rewrite /subst_context in H1. + erewrite nth_error_fold_context_k in H1. 4:{ rewrite nth_error_map e //. } 3:len. 2:exact []. + len in H1. noconf H1. destruct c as [? [] ?]; noconf H1. + rewrite skipn_app. len. eapply All_fold_nth_error in X; tea. cbn in X. depelim X. + rewrite skipn_length in H1. + eapply expanded_subst. rewrite skipn_length. len. + replace (S n - #|bcontext x|) with 0. 2:{ lia. } rewrite skipn_0. eapply Forall_rev. solve_all. + len. rewrite app_assoc. eapply expanded_weakening. eapply expanded_subst_instance. + now rewrite skipn_repeat. } + { rewrite inst_case_branch_context_length in H0, H1. + rewrite skipn_app skipn_all2 /=; len. + replace (S n - #|bcontext x|) with (S (n - #|bcontext x|)). 2:lia. + eapply wfΓ. rewrite H1 //. } + noconf H1. + - eapply expanded_tProj_inv in exp. now econstructor. + - eapply expanded_mkApps_inv' in exp. + rewrite head_mkApps head_nApp in exp => //. + rewrite arguments_mkApps_nApp // in exp. destruct exp as []. + specialize (IHred Γ' wfΓ). + destruct M1; try solve [eapply expanded_mkApps_expanded => //; eauto; solve_all]. + * depelim red; solve_discr. eapply wfΓ in e. + eapply expanded_mkApps_expanded => //; solve_all. + rewrite -(firstn_skipn (S n) Γ'). eapply (expanded_lift _ _ _ _ []) => //. + destruct H3 as [m [hn ha]]. + rewrite firstn_length_le //. now eapply nth_error_Some_length in hn. + depelim o. + * depelim red; solve_discr. depelim o. + + - eapply expanded_mkApps_inv' in exp. + move: exp. + rewrite head_mkApps head_nApp // arguments_mkApps_nApp //. + intros []. + assert(Forall (expanded Σ Γ') N2). + { clear H1. solve_all. eapply OnOne2_impl_All_r; tea. cbn. intuition auto. } + destruct M1; try solve [eapply expanded_mkApps => //; eauto]. + + rewrite (OnOne2_length X) in H1. destruct H1 as [m []]; eapply expanded_tRel; tea. + + rewrite (OnOne2_length X) in H1. destruct H1 as [m [? [? []]]]; eapply expanded_tConstruct_app; tea. + + rewrite (OnOne2_length X) in H1. + destruct H1 as [d [? [? []]]]; eapply expanded_tFix; tea. + destruct N2; cbn in *; eauto. lia. intros eq; discriminate. + + - move/expanded_mkApps_inv': exp. + rewrite head_mkApps head_nApp // arguments_mkApps_nApp // => [] [] hargs [d [hf [hm2 [hnth harg]]]]. + eapply OnOne2_nth_error in hnth as [t' [hnth hor]]; tea. + eapply expanded_tFix; tea. + { clear hor. solve_all. eapply OnOne2_impl_All_r; tea. + intros ? ? [] []. noconf e. rewrite -H2. split => //. solve_all. + clear -X H1. + enough (rev_map (fun d1 : def term => S (rarg d1)) mfix0 = (rev_map (fun d1 : def term => S (rarg d1)) mfix1)) as <- => //. + clear -X. rewrite !rev_map_spec. f_equal. induction X. destruct p as []. cbn in *. congruence. cbn. congruence. } + { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } + + - move/expanded_mkApps_inv': exp. + rewrite head_mkApps head_nApp // arguments_mkApps_nApp // => [] [] hargs [d [hf [hm2 [hnth harg]]]]. + eapply OnOne2_nth_error in hnth as [t' [hnth hor]]; tea. + eapply expanded_tFix; tea. + { clear hor. solve_all. + assert (rev_map (fun d1 : def term => S (rarg d1)) mfix0 = (rev_map (fun d1 : def term => S (rarg d1)) mfix1)). + { clear -X. rewrite !rev_map_spec. f_equal. induction X. destruct p as []. cbn in *. congruence. cbn. congruence. } + rewrite -H. + eapply OnOne2_impl_All_r; tea. + intros ? ? [] []. noconf e. destruct p. + eapply Red1Apps.isLambda_red1 in r; tea. split => //. + set(Γ'' := rev_map (fun d1 : def term => S (rarg d1)) mfix0). + eapply e => //. + { intros n b hnth'. + destruct (nth_error (fix_context mfix0) n) eqn:e'. + rewrite nth_error_app_lt in hnth'. now eapply nth_error_Some_length in e'. + rewrite e' in hnth'. noconf hnth'. + pose proof (PCUICParallelReductionConfluence.fix_context_assumption_context mfix0). + eapply PCUICParallelReductionConfluence.nth_error_assumption_context in H6; tea. congruence. + rewrite /Γ''. + eapply nth_error_None in e'. len in e'. + rewrite nth_error_app_ge in hnth' => //. now len. + rewrite skipn_app skipn_all2. len. + cbn. len. replace (S n - #|mfix0|) with (S (n - #|mfix0|)). 2:{ lia. } + eapply wfΓ. now len in hnth'. } } + { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } + - eapply expanded_tProd. + - constructor. + - constructor. + eapply expanded_tEvar_inv in exp. + solve_all; eapply OnOne2_impl_All_r; tea. intuition eauto. + now eapply X0. + - depelim exp; solve_discr. now cbn in H. + - depelim exp; solve_discr. now cbn in H. + - eapply expanded_tCoFix_inv in exp. econstructor. + rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. + destruct X0. noconf e. now rewrite -H1. + - eapply expanded_tCoFix_inv in exp. econstructor. + rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. + destruct X0. destruct p. noconf e. eapply e0 => //. + intros n b. + destruct nth_error eqn:e' => //. + cbn. intros [=]. destruct c as [? [] ?]. cbn in *. noconf H4. + eapply nth_error_app_inv in e' as [[]|[]]. + { pose proof (PCUICParallelReductionConfluence.fix_context_assumption_context mfix0). + eapply PCUICParallelReductionConfluence.nth_error_assumption_context in H5; tea. cbn in H5. congruence. } + len in H3. len in H4. + rewrite skipn_app skipn_all2; len. + replace (S n - #|mfix0|) with (S (n - #|mfix0|)) by lia. eapply wfΓ. rewrite H4 /= //. + noconf H4. +Qed. + +Lemma expanded_red {cf : checker_flags} {Σ : global_env_ext} Γ Γ' t v : wf Σ -> + expanded_global_env Σ -> + (forall n body, option_map decl_body (nth_error Γ n) = Some (Some body) -> expanded Σ (skipn (S n) Γ') body) -> + red Σ Γ t v -> + expanded Σ Γ' t -> + expanded Σ Γ' v. +Proof. + intros. + induction X0. now eapply expanded_red1. auto. + eapply IHX0_2. now eapply IHX0_1. +Qed. + diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index 6fdc13e16..e80e6f7de 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -163,8 +163,6 @@ Proof. simpl. intros. now rewrite mkApps_app in H. Qed. -Global Hint Resolve app_tip_nil : core. - Definition cstr_arity mdecl cdecl := (mdecl.(ind_npars) + context_assumptions cdecl.(cstr_args))%nat. @@ -1220,939 +1218,4 @@ Proof. eapply value_final, value_app. now constructor. auto. - eapply eval_cofix_case; tea. eapply value_final, value_app. now constructor. auto. -Qed. - -Lemma expanded_tApp (Σ : global_env) (Γ : list nat) (f : term) a : - expanded Σ Γ f -> expanded Σ Γ a -> - expanded Σ Γ (tApp f a). -Proof. - induction 1 using expanded_ind; intros expa. - all:rewrite -?[tApp _ a](mkApps_app _ _ [a]). - all:try (eapply (expanded_mkApps _ _ _ [a]) => //; econstructor; eauto). - - - econstructor; tea. rewrite app_length. lia. eapply app_Forall;eauto. - - econstructor; tea. eapply app_Forall; eauto. - - eapply expanded_tFix; tea. eapply app_Forall; eauto. eauto. rewrite app_length; cbn; eauto. lia. - - eapply expanded_tConstruct_app; tea. rewrite app_length ; lia. eapply app_Forall; eauto. -Qed. - -Lemma expanded_mkApps (Σ : global_env) (Γ : list nat) (f : term) (args : list term) : - expanded Σ Γ f -> Forall (expanded Σ Γ) args -> expanded Σ Γ (mkApps f args). -Proof. - intros expf expa; induction expa in f, expf |- *; eauto. - cbn. eapply IHexpa. now eapply expanded_tApp. -Qed. - -Lemma expanded_tApp_inv Σ Γ f a : - ~ isConstructApp f || isFixApp f || isRel (head f) -> - expanded Σ Γ (tApp f a) -> - expanded Σ Γ f /\ expanded Σ Γ a. -Proof. - rewrite /isConstructApp /isFixApp. - intros hf exp; depind exp. - - destruct args using rev_case; solve_discr; try discriminate. - rewrite mkApps_app in H3; noconf H3. - eapply Forall_app in H1 as [? ha]. depelim ha. - destruct args using rev_case; cbn in hf => //. - now rewrite !head_mkApps /= in hf. - - destruct args using rev_case; solve_discr. subst f6. - eapply IHexp => //. - rewrite mkApps_app in H2; noconf H2. - eapply Forall_app in H0 as [? H0]. depelim H0. split => //. - rewrite !head_mkApps in hf. - eapply expanded_mkApps => //. - - destruct args using rev_case; solve_discr. discriminate. - rewrite mkApps_app in H6; noconf H6. - eapply Forall_app in H1 as [? h]. depelim h. split => //. - now rewrite !head_mkApps /= in hf. - - destruct args using rev_case; solve_discr. discriminate. - rewrite mkApps_app in H3; noconf H3. - now rewrite !head_mkApps /= in hf. -Qed. - -Lemma expanded_tLambda_inv Σ Γ na t b : - expanded Σ Γ (tLambda na t b) -> - expanded Σ (0 :: Γ) b. -Proof. - intros exp; depind exp; solve_discr => //; eauto. -Qed. - -Lemma expanded_tLetIn_inv Σ Γ na t t' b : - expanded Σ Γ (tLetIn na t t' b) -> - expanded Σ Γ t /\ expanded Σ (0 :: Γ) b. -Proof. - intros exp; depind exp; solve_discr => //; eauto. -Qed. - -Lemma expanded_tEvar_inv Σ Γ ev l: - expanded Σ Γ (tEvar ev l) -> - Forall (expanded Σ Γ) l. -Proof. - intros exp; depind exp; solve_discr => //; eauto. -Qed. - -Lemma expanded_tCase_inv Σ Γ ci p c brs : - expanded Σ Γ (tCase ci p c brs) -> - Forall (expanded Σ Γ) (pparams p) /\ - Forall - (fun br : branch term => - ∥ All_fold - (fun (Δ : list context_decl) (d : context_decl) - => - ForOption - (fun b : term => - expanded Σ - (repeat 0 #|Δ| ++ - repeat 0 #|pparams p|) b) - (decl_body d)) (bcontext br) ∥ /\ - expanded Σ (repeat 0 #|bcontext br| ++ Γ) (bbody br)) - brs /\ - expanded Σ Γ c. -Proof. - intros exp; depind exp; solve_discr => //; eauto. -Qed. - -Lemma expanded_tProj_inv Σ Γ p c : - expanded Σ Γ (tProj p c) -> - expanded Σ Γ c. -Proof. - intros exp; depind exp; solve_discr => //; eauto. -Qed. - -Lemma expanded_tCoFix_inv Σ Γ mfix idx : - expanded Σ Γ (tCoFix mfix idx) -> - Forall (fun d : def term => expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix. -Proof. - intros exp; depind exp; solve_discr => //; eauto. -Qed. - -Import PCUICOnOne. - -Module Red1Apps. - - - Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := - (** Reductions *) - (** Beta *) - | red_beta na t b a ts : - Σ ;;; Γ |- mkApps (tLambda na t b) (a :: ts) ⇝ mkApps (b {0 := a}) ts - - (** Let *) - | red_zeta na b t b' : - Σ ;;; Γ |- tLetIn na b t b' ⇝ b' {0 := b} - - | red_rel i body : - option_map decl_body (nth_error Γ i) = Some (Some body) -> - Σ ;;; Γ |- tRel i ⇝ lift0 (S i) body - - (** Case *) - | red_iota ci c u args p brs br : - nth_error brs c = Some br -> - #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> - Σ ;;; Γ |- tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs - ⇝ iota_red ci.(ci_npar) p args br - - (** Fix unfolding, with guard *) - | red_fix mfix idx args narg fn : - unfold_fix mfix idx = Some (narg, fn) -> - is_constructor narg args = true -> - Σ ;;; Γ |- mkApps (tFix mfix idx) args ⇝ mkApps fn args - - (** CoFix-case unfolding *) - | red_cofix_case ip p mfix idx args narg fn brs : - unfold_cofix mfix idx = Some (narg, fn) -> - Σ ;;; Γ |- tCase ip p (mkApps (tCoFix mfix idx) args) brs ⇝ - tCase ip p (mkApps fn args) brs - - (** CoFix-proj unfolding *) - | red_cofix_proj p mfix idx args narg fn : - unfold_cofix mfix idx = Some (narg, fn) -> - Σ ;;; Γ |- tProj p (mkApps (tCoFix mfix idx) args) ⇝ tProj p (mkApps fn args) - - (** Constant unfolding *) - | red_delta c decl body (isdecl : declared_constant Σ c decl) u : - decl.(cst_body) = Some body -> - Σ ;;; Γ |- tConst c u ⇝ subst_instance u body - - (** Proj *) - | red_proj p args u arg: - nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg -> - Σ ;;; Γ |- tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args) ⇝ arg - - - | abs_red_l na M M' N : Σ ;;; Γ |- M ⇝ M' -> Σ ;;; Γ |- tLambda na M N ⇝ tLambda na M' N - | abs_red_r na M M' N : Σ ;;; Γ ,, vass na N |- M ⇝ M' -> Σ ;;; Γ |- tLambda na N M ⇝ tLambda na N M' - - | letin_red_def na b t b' r : Σ ;;; Γ |- b ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na r t b' - | letin_red_ty na b t b' r : Σ ;;; Γ |- t ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na b r b' - | letin_red_body na b t b' r : Σ ;;; Γ ,, vdef na b t |- b' ⇝ r -> Σ ;;; Γ |- tLetIn na b t b' ⇝ tLetIn na b t r - - | case_red_param ci p params' c brs : - OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) p.(pparams) params' -> - Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_pparams p params') c brs - - | case_red_return ci p preturn' c brs : - Σ ;;; Γ ,,, inst_case_predicate_context p |- p.(preturn) ⇝ preturn' -> - Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_preturn p preturn') c brs - - | case_red_discr ci p c c' brs : - Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c' brs - - | case_red_brs ci p c brs brs' : - OnOne2 (fun br br' => - on_Trel_eq (fun t u => Σ ;;; Γ ,,, inst_case_branch_context p br |- t ⇝ u) bbody bcontext br br') - brs brs' -> - Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c brs' - - | proj_red p c c' : Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tProj p c ⇝ tProj p c' - - | app_red_l M1 N1 M2 : Σ ;;; Γ |- M1 ⇝ N1 -> ~~ isApp M1 -> ~~ isFix M1 -> M2 <> nil -> - Σ ;;; Γ |- mkApps M1 M2 ⇝ mkApps N1 M2 - - | app_red_r M2 N2 M1 : ~~ isApp M1 -> OnOne2 (fun M2 N2 => Σ ;;; Γ |- M2 ⇝ N2) M2 N2 -> Σ ;;; Γ |- mkApps M1 M2 ⇝ mkApps M1 N2 - - | app_fix_red_ty mfix0 mfix1 idx M2 : - OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> - Σ ;;; Γ |- mkApps (tFix mfix0 idx) M2 ⇝ mkApps (tFix mfix1 idx) M2 - - | app_fix_red_body mfix0 mfix1 idx M2 : - OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> - Σ ;;; Γ |- mkApps (tFix mfix0 idx) M2 ⇝ mkApps (tFix mfix1 idx) M2 - - | prod_red_l na M1 M2 N1 : Σ ;;; Γ |- M1 ⇝ N1 -> Σ ;;; Γ |- tProd na M1 M2 ⇝ tProd na N1 M2 - | prod_red_r na M2 N2 M1 : Σ ;;; Γ ,, vass na M1 |- M2 ⇝ N2 -> - Σ ;;; Γ |- tProd na M1 M2 ⇝ tProd na M1 N2 - - | evar_red ev l l' : OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) l l' -> Σ ;;; Γ |- tEvar ev l ⇝ tEvar ev l' - - | fix_red_ty mfix0 mfix1 idx : - OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> - Σ ;;; Γ |- tFix mfix0 idx ⇝ tFix mfix1 idx - - | fix_red_body mfix0 mfix1 idx : - OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) - mfix0 mfix1 -> - Σ ;;; Γ |- tFix mfix0 idx ⇝ tFix mfix1 idx - - | cofix_red_ty mfix0 mfix1 idx : - OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ |- t ⇝ u) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> - Σ ;;; Γ |- tCoFix mfix0 idx ⇝ tCoFix mfix1 idx - - | cofix_red_body mfix0 mfix1 idx : - OnOne2 (on_Trel_eq (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> - Σ ;;; Γ |- tCoFix mfix0 idx ⇝ tCoFix mfix1 idx - where " Σ ;;; Γ |- t ⇝ u " := (red1 Σ Γ t u). - -Lemma red1_ind_all : - forall (Σ : global_env) (P : context -> term -> term -> Type), - - (forall (Γ : context) (na : aname) (t b a : term) ts, - P Γ (mkApps (tLambda na t b) (a :: ts)) (mkApps (b {0 := a}) ts)) -> - - (forall (Γ : context) (na : aname) (b t b' : term), P Γ (tLetIn na b t b') (b' {0 := b})) -> - - (forall (Γ : context) (i : nat) (body : term), - option_map decl_body (nth_error Γ i) = Some (Some body) -> P Γ (tRel i) ((lift0 (S i)) body)) -> - - (forall (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term) - (p : predicate term) (brs : list (branch term)) br, - nth_error brs c = Some br -> - #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> - P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) - (iota_red ci.(ci_npar) p args br)) -> - - (forall (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), - unfold_fix mfix idx = Some (narg, fn) -> - is_constructor narg args = true -> P Γ (mkApps (tFix mfix idx) args) (mkApps fn args)) -> - - (forall (Γ : context) ci (p : predicate term) (mfix : mfixpoint term) (idx : nat) - (args : list term) (narg : nat) (fn : term) (brs : list (branch term)), - unfold_cofix mfix idx = Some (narg, fn) -> - P Γ (tCase ci p (mkApps (tCoFix mfix idx) args) brs) (tCase ci p (mkApps fn args) brs)) -> - - (forall (Γ : context) (p : projection) (mfix : mfixpoint term) (idx : nat) (args : list term) - (narg : nat) (fn : term), - unfold_cofix mfix idx = Some (narg, fn) -> P Γ (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args))) -> - - (forall (Γ : context) c (decl : constant_body) (body : term), - declared_constant Σ c decl -> - forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance u body)) -> - - (forall (Γ : context) p (args : list term) (u : Instance.t) - (arg : term), - nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg -> - P Γ (tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args)) arg) -> - - (forall (Γ : context) (na : aname) (M M' N : term), - red1 Σ Γ M M' -> P Γ M M' -> P Γ (tLambda na M N) (tLambda na M' N)) -> - - (forall (Γ : context) (na : aname) (M M' N : term), - red1 Σ (Γ,, vass na N) M M' -> P (Γ,, vass na N) M M' -> P Γ (tLambda na N M) (tLambda na N M')) -> - - (forall (Γ : context) (na : aname) (b t b' r : term), - red1 Σ Γ b r -> P Γ b r -> P Γ (tLetIn na b t b') (tLetIn na r t b')) -> - - (forall (Γ : context) (na : aname) (b t b' r : term), - red1 Σ Γ t r -> P Γ t r -> P Γ (tLetIn na b t b') (tLetIn na b r b')) -> - - (forall (Γ : context) (na : aname) (b t b' r : term), - red1 Σ (Γ,, vdef na b t) b' r -> P (Γ,, vdef na b t) b' r -> P Γ (tLetIn na b t b') (tLetIn na b t r)) -> - - (forall (Γ : context) (ci : case_info) p params' c brs, - OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) p.(pparams) params' -> - P Γ (tCase ci p c brs) - (tCase ci (set_pparams p params') c brs)) -> - - (forall (Γ : context) (ci : case_info) p preturn' c brs, - red1 Σ (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> - P (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> - P Γ (tCase ci p c brs) - (tCase ci (set_preturn p preturn') c brs)) -> - - (forall (Γ : context) (ind : case_info) (p : predicate term) (c c' : term) (brs : list (branch term)), - red1 Σ Γ c c' -> P Γ c c' -> P Γ (tCase ind p c brs) (tCase ind p c' brs)) -> - - (forall (Γ : context) ci p c brs brs', - OnOne2 (fun br br' => - (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, inst_case_branch_context p br)) - (P (Γ ,,, inst_case_branch_context p br))) - bbody bcontext br br')) brs brs' -> - P Γ (tCase ci p c brs) (tCase ci p c brs')) -> - - (forall (Γ : context) (p : projection) (c c' : term), red1 Σ Γ c c' -> P Γ c c' -> - P Γ (tProj p c) (tProj p c')) -> - - (forall (Γ : context) M1 N1 M2, red1 Σ Γ M1 N1 -> P Γ M1 N1 -> ~~ isApp M1 -> ~~ isFix M1 -> M2 <> [] -> - P Γ (mkApps M1 M2) (mkApps N1 M2)) -> - - (forall (Γ : context) M1 N2 M2, ~~ isApp M1 -> - OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) M2 N2 -> - P Γ (mkApps M1 M2) (mkApps M1 N2)) -> - - (forall (Γ : context) mfix0 mfix1 idx M2, - OnOne2 (on_Trel_eq (Trel_conj (fun t u => Σ ;;; Γ |- t ⇝ u) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> - P Γ (mkApps (tFix mfix0 idx) M2) (mkApps (tFix mfix1 idx) M2)) -> - - (forall (Γ : context) mfix0 mfix1 idx M2, - OnOne2 (on_Trel_eq (Trel_conj (fun t u => Σ ;;; Γ ,,, fix_context mfix0 |- t ⇝ u) (P (Γ ,,, fix_context mfix0))) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> - P Γ (mkApps (tFix mfix0 idx) M2) (mkApps (tFix mfix1 idx) M2)) -> - - (forall (Γ : context) (na : aname) (M1 M2 N1 : term), - red1 Σ Γ M1 N1 -> P Γ M1 N1 -> P Γ (tProd na M1 M2) (tProd na N1 M2)) -> - - (forall (Γ : context) (na : aname) (M2 N2 M1 : term), - red1 Σ (Γ,, vass na M1) M2 N2 -> P (Γ,, vass na M1) M2 N2 -> P Γ (tProd na M1 M2) (tProd na M1 N2)) -> - - (forall (Γ : context) (ev : nat) (l l' : list term), - OnOne2 (Trel_conj (red1 Σ Γ) (P Γ)) l l' -> P Γ (tEvar ev l) (tEvar ev l')) -> - - (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), - OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> - P Γ (tFix mfix0 idx) (tFix mfix1 idx)) -> - - (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), - OnOne2 (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, fix_context mfix0)) - (P (Γ ,,, fix_context mfix0))) dbody - (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> - P Γ (tFix mfix0 idx) (tFix mfix1 idx)) -> - - (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), - OnOne2 (on_Trel_eq (Trel_conj (red1 Σ Γ) (P Γ)) dtype (fun x => (dname x, dbody x, rarg x))) mfix0 mfix1 -> - P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> - - (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), - OnOne2 (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, fix_context mfix0)) - (P (Γ ,,, fix_context mfix0))) dbody - (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> - P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> - - forall (Γ : context) (t t0 : term), red1 Σ Γ t t0 -> P Γ t t0. -Proof. - intros. rename X29 into Xlast. revert Γ t t0 Xlast. - fix aux 4. intros Γ t T. - move aux at top. - destruct 1; match goal with - | |- P _ (tFix _ _) (tFix _ _) => idtac - | |- P _ (tCoFix _ _) (tCoFix _ _) => idtac - | |- P _ (mkApps (tFix _ _) _) _ => idtac - | |- P _ (tCase _ _ (mkApps (tCoFix _ _) _) _) _ => idtac - | |- P _ (tProj _ (mkApps (tCoFix _ _) _)) _ => idtac - | H : _ |- _ => eapply H; eauto - end. - - eapply X3; eauto. - - eapply X4; eauto. - - eapply X5; eauto. - - - revert params' o. - generalize (pparams p). - fix auxl 3. - intros params params' []. - + constructor. split; auto. - + constructor. auto. - - - revert brs' o. - revert brs. - fix auxl 3. - intros l l' Hl. destruct Hl. - + simpl in *. constructor; intros; intuition auto. - + constructor. eapply auxl. apply Hl. - - - revert M2 N2 o. - fix auxl 3. - intros l l' Hl. destruct Hl. - + constructor. split; auto. - + constructor. auto. - - - eapply X20. - revert mfix0 mfix1 o. - fix auxl 3. - intros l l' Hl. destruct Hl. - + constructor; split; auto; intuition. - + constructor; try split; auto; intuition. - - - eapply X21. revert o. - generalize (fix_context mfix0). - intros c o. revert mfix0 mfix1 o. - fix auxl 3. - intros l l' Hl. destruct Hl. - + constructor. split; auto; intuition. - + constructor; try split; auto; intuition. - - - revert l l' o. - fix auxl 3. - intros l l' Hl. destruct Hl. - + constructor. split; auto. - + constructor. auto. - - - eapply X25. - revert mfix0 mfix1 o; fix auxl 3. - intros l l' Hl; destruct Hl; - constructor; try split; auto; intuition. - - - eapply X26. - revert o. generalize (fix_context mfix0). intros c Xnew. - revert mfix0 mfix1 Xnew; fix auxl 3; intros l l' Hl; - destruct Hl; constructor; try split; auto; intuition. - - - eapply X27. - revert mfix0 mfix1 o. - fix auxl 3; intros l l' Hl; destruct Hl; - constructor; try split; auto; intuition. - - - eapply X28. - revert o. generalize (fix_context mfix0). intros c new. - revert mfix0 mfix1 new; fix auxl 3; intros l l' Hl; destruct Hl; - constructor; try split; auto; intuition. -Defined. - -Lemma red_tApp Σ Γ t v u : - red1 Σ Γ t v -> - red1 Σ Γ (tApp t u) (tApp v u). -Proof. - induction 1. - all:try solve [eapply (app_red_l _ _ _ _ [u]) => //; econstructor; eauto]. - - rewrite -![tApp _ u](mkApps_app _ _ [u]). - eapply red_beta. - - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. - now apply is_constructor_app_ge. - - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. - - rewrite -![tApp _ u](mkApps_app _ _ [u]). econstructor; eauto. - now eapply OnOne2_app_r. - - rewrite -![tApp _ u](mkApps_app _ _ [u]). now eapply app_fix_red_ty. - - rewrite -![tApp _ u](mkApps_app _ _ [u]). now eapply app_fix_red_body. - - now eapply (app_fix_red_ty _ _ _ _ _ [_]). - - now eapply (app_fix_red_body _ _ _ _ _ [_]). -Qed. - -Lemma isLambda_red1 Σ Γ b b' : isLambda b -> red1 Σ Γ b b' -> isLambda b'. -Proof. - destruct b; simpl; try discriminate. - intros _ red. - depelim red; solve_discr; eauto. depelim o. -Qed. - -End Red1Apps. - -Lemma red1_red1apps Σ Γ t v : - red1 Σ Γ t v -> Red1Apps.red1 Σ Γ t v. -Proof. - intros red; induction red using red1_ind_all in |- *. - all:try solve [econstructor; eauto; solve_all; eauto]. - - eapply (Red1Apps.red_beta _ _ _ _ _ _ []). - - now eapply Red1Apps.red_tApp. - - remember (decompose_app (tApp M1 M2)). - destruct p as [hd args]. - edestruct (decompose_app_rec_inv' M1 [M2]). rewrite /decompose_app in Heqp. - cbn in Heqp. rewrite -Heqp. reflexivity. - destruct a as [napp [hm2 hm1]]. - symmetry in Heqp; eapply decompose_app_inv in Heqp. rewrite Heqp. - assert (tApp M1 N2 = mkApps hd (firstn x args ++ [N2])) as ->. - { now rewrite mkApps_app -hm1. } - rewrite -{1}(firstn_skipn x args) -hm2. eapply Red1Apps.app_red_r => //. - eapply OnOne2_app. now constructor. -Qed. - -Lemma head_nApp f : - ~~ isApp f -> head f = f. -Proof. - induction f => //. -Qed. - -Lemma expanded_mkApps_inv Σ Γ f v : - ~~ isApp f -> - ~~ (isConstruct f || isFix f || isRel f) -> - expanded Σ Γ (mkApps f v) -> - expanded Σ Γ f /\ Forall (expanded Σ Γ) v. -Proof. - intros happ hc. - induction v using rev_ind; cbn. - - intros exp; split => //. - - rewrite mkApps_app /=. - move/expanded_tApp_inv => e. - forward e. rewrite /isConstructApp /isFixApp head_mkApps. - rewrite head_nApp //. now move/negbTE: hc ->. - intuition auto. eapply app_Forall; eauto. -Qed. - - -Lemma arguments_mkApps f args : - ~~ isApp f -> - arguments (mkApps f args) = args. -Proof. - rewrite /arguments => isa. - rewrite decompose_app_mkApps //. -Qed. - -Lemma arguments_mkApps' f args : - arguments (mkApps f args) = arguments f ++ args. -Proof. - rewrite /arguments. - rewrite /decompose_app decompose_app_rec_mkApps //. - rewrite app_nil_r. - induction f in args |- * => //=. - rewrite IHf1. now rewrite (IHf1 [f2]) -app_assoc. -Qed. - -Lemma expanded_mkApps_inv' Σ Γ f : - expanded Σ Γ f -> - let args := arguments f in - Forall (expanded Σ Γ) args /\ - match head f with - | tRel n => exists m, nth_error Γ n = Some m /\ m <= #|args| - | tConstruct ind c u => exists mind idecl cdecl, - declared_constructor Σ (ind, c) mind idecl cdecl /\ #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) - | tFix mfix idx => exists d, - Forall - (fun d0 : def term => - isLambda (dbody d0) /\ - (let ctx := - rev_map (fun d1 : def term => (1 + rarg d1)%nat) - mfix in - expanded Σ (ctx ++ Γ) (dbody d0))) mfix /\ - args <> [] /\ - nth_error mfix idx = Some d /\ #|args| > rarg d - | _ => expanded Σ Γ (head f) - end. -Proof. - induction 1 using expanded_ind; cbn. - all: try solve [split; econstructor; eauto]. - all:rewrite head_mkApps /=. - - rewrite arguments_mkApps //. split => //. now exists m. - - destruct IHexpanded. rewrite arguments_mkApps'. split. - eapply app_Forall => //. - rewrite app_length. - destruct (head f6) => //; firstorder (eauto; try lia). - exists x. split => //. firstorder (eauto; try lia). - intros heq; apply H5. now eapply app_eq_nil in heq. - - rewrite arguments_mkApps //. split => //. now exists d. - - rewrite arguments_mkApps //. split => //. - firstorder. -Qed. - -Lemma All_fold_map_context (P : context -> context_decl -> Type) (f : term -> term) ctx : - All_fold P (map_context f ctx) <~> All_fold (fun Γ d => P (map_context f Γ) (map_decl f d)) ctx. -Proof. - induction ctx. - - split; constructor. - - cbn. split; intros H; depelim H; constructor; auto; now apply IHctx. -Qed. - -Lemma expanded_fix_subst Σ a k b Γ Γs Δ : - #|Γ| = k -> - Forall2 (fun n arg => forall args Γ' k', - Forall (expanded Σ (Γ' ++ Δ)) args -> - n <= #|args| -> - #|Γ'| = k' -> - expanded Σ (Γ' ++ Δ) (mkApps (lift0 k' arg) args)) Γs a -> - expanded Σ (Γ ++ Γs ++ Δ) b -> - expanded Σ (Γ ++ Δ) (subst a k b). -Proof. - intros Hk Hs. - remember (Γ ++ _ ++ Δ)%list as Γ_. - intros exp; revert Γ k Hk HeqΓ_. - induction exp using expanded_ind; intros Γ' k Hk ->. - all:try solve[ cbn; econstructor => // ]. - 2,7:solve[ cbn; econstructor => //; solve_all ]. - - rewrite subst_mkApps /=. - destruct (Nat.leb_spec k n). - destruct (nth_error a _) eqn:hnth. - * pose proof (Forall2_length Hs). - pose proof (Forall2_nth_error_Some_r _ _ _ _ _ _ _ hnth Hs) as [t' [hnth' hargs]]. - eapply hargs => //. - eapply Forall_map. - 2:{ len. rewrite nth_error_app_ge in H. lia. subst k. - rewrite nth_error_app_lt in H. - eapply nth_error_Some_length in hnth'. lia. rewrite hnth' in H. noconf H. exact H0. } - solve_all. - * rewrite nth_error_app_ge in H. lia. - eapply nth_error_None in hnth. - pose proof (Forall2_length Hs). - rewrite nth_error_app_ge in H. lia. - eapply expanded_tRel. rewrite nth_error_app_ge. lia. erewrite <- H. - lia_f_equal. len. solve_all. - * rewrite nth_error_app_lt in H. lia. - eapply expanded_tRel. rewrite nth_error_app_lt. lia. tea. now len. - solve_all. - - cbn. econstructor. - eapply (IHexp (0 :: Γ') (S k)); cbn; auto; try lia. - - cbn. econstructor. apply IHexp1; auto. - eapply (IHexp2 (0 :: Γ') (S k)); cbn; auto; lia. - - rewrite subst_mkApps. - destruct (isConstruct (subst a k f6) || isFix (subst a k f6) || isRel (subst a k f6)) eqn:eqc. - specialize (IHexp _ _ Hk eq_refl). - eapply expanded_mkApps_expanded => //. solve_all. - eapply expanded_mkApps => //. now eapply IHexp. solve_all. - - cbn. econstructor. eauto. cbn. solve_all. solve_all. - specialize (H1 (repeat 0 #|bcontext x| ++ Γ') (#|bcontext x| + k)%nat). - forward H1 by len. - forward H1. now rewrite app_assoc. - rewrite /id. rewrite app_assoc. apply H1. - - rewrite subst_mkApps. cbn. - eapply expanded_tFix. - + solve_all. now eapply isLambda_subst. - specialize (a0 - (rev_map (fun d0 : def term => S (rarg d0)) - (map (map_def (subst a k) (subst a (#|mfix| + k))) mfix) ++ Γ') (#|mfix| + k)%nat). - forward a0 by len. - forward a0. { rewrite app_assoc. f_equal. f_equal. - rewrite !rev_map_spec. f_equal. now rewrite map_map_compose /=. } - rewrite app_assoc. eapply a0. - + solve_all. - + now destruct args. - + rewrite nth_error_map /= H4 //. - + len. - - cbn. constructor. - solve_all. - specialize (a0 (repeat 0 #|mfix| ++ Γ') (#|mfix| + k)%nat). - forward a0 by len. - forward a0. { rewrite app_assoc //. } - rewrite app_assoc. eapply a0. - - rewrite subst_mkApps. cbn. - eapply expanded_tConstruct_app; tea. now len. - solve_all. -Qed. - -Lemma expanded_unfold_fix Σ Γ' mfix idx narg fn : - unfold_fix mfix idx = Some (narg, fn) -> - All (fun d0 : def term => isLambda (dbody d0) /\ expanded Σ (rev_map (fun d1 : def term => S (rarg d1)) mfix ++ Γ') (dbody d0)) mfix -> - expanded Σ Γ' fn. -Proof. - unfold unfold_fix. - destruct nth_error eqn:e => //. - intros [= <- <-] hf. - pose proof (nth_error_all e hf) as [hl hf']. - eapply (expanded_fix_subst _ _ _ _ []) => //; tea. - rewrite rev_map_spec. - eapply Forall2_from_nth_error. len. - intros n rarg f. len. intros hn hrarg hnthf args Γ'' k' hargs hrarg' <-. - eapply PCUICParallelReductionConfluence.nth_error_fix_subst in hnthf. subst f. - move: hrarg. - rewrite nth_error_rev; len. rewrite List.rev_involutive nth_error_map. - intros hrarg. - destruct (nth_error mfix (_ - _)) eqn:e'. cbn in hrarg. noconf hrarg. - eapply expanded_tFix => //. solve_all. - eapply expanded_lift; len. rewrite !rev_map_spec in H1 *. - rewrite map_map => //. destruct args => //. cbn in hrarg'. lia. - rewrite nth_error_map /= e' /= //. cbn. lia. - eapply nth_error_None in e'. lia. -Qed. - -Lemma expanded_unfold_cofix Σ Γ' mfix idx narg fn : - unfold_cofix mfix idx = Some (narg, fn) -> - All (fun d0 : def term => expanded Σ (repeat 0 #|mfix| ++ Γ') (dbody d0)) mfix -> - expanded Σ Γ' fn. -Proof. - unfold unfold_cofix. - destruct nth_error eqn:e => //. - intros [= <- <-] hf. - pose proof (nth_error_all e hf) as hf'. - eapply (expanded_subst _ _ _ _ []) => //; tea. - rewrite /cofix_subst. - generalize #|mfix|. - induction n; repeat constructor; eauto. solve_all. - len. -Qed. - -Lemma expanded_weakening_env {cf : checker_flags} Σ Σ' Γ t : - wf Σ' -> - extends Σ Σ' -> - expanded Σ Γ t -> expanded Σ' Γ t. -Proof. - intros w s. - eapply expanded_ind; intros. - all:try solve [econstructor; eauto]. - - econstructor; eauto. solve_all. sq. eapply All_fold_impl; tea. cbn. - intros. now rewrite repeat_app in H6. - - eapply expanded_tFix; eauto. solve_all. - - eapply expanded_tConstruct_app; eauto. - eapply PCUICWeakeningEnv.weakening_env_declared_constructor; tea. -Qed. - -Lemma expanded_global_env_constant {cf : checker_flags} Σ c decl : - wf Σ -> - expanded_global_env Σ -> - declared_constant Σ c decl -> - ForOption (expanded Σ []) (cst_body decl). -Proof. - intros wf; destruct Σ as [Σ univs] => /=. cbn. - unfold expanded_global_env. cbn. - induction 1; cbn => //. - intros [->|H']. - - depelim H0. - destruct decl as [? [] ?]; cbn in *. - constructor. cbn. - eapply expanded_weakening_env; tea. - eapply extends_strictly_on_decls_extends. - split => //=. eapply incl_cs_refl. 2:eapply Retroknowledge.extends_refl. - set (cb := ConstantDecl _). now exists [(c, cb)]. - constructor. - - forward IHexpanded_global_declarations. - destruct wf. cbn in *. split => //. - cbn. now depelim o0. - eapply IHexpanded_global_declarations in H'. - destruct decl as [? [] ?]; cbn in * => //. 2:constructor. - depelim H'. constructor. - eapply expanded_weakening_env; tea. - eapply extends_strictly_on_decls_extends. - split => //=. eapply incl_cs_refl. 2:eapply Retroknowledge.extends_refl. - now exists [decl0]. -Qed. - -Lemma All_fold_nth_error P (ctx : context) n b : - All_fold P ctx -> nth_error ctx n = Some b -> - P (skipn (S n) ctx) b. -Proof. - induction 1 in n, b |- *. - - rewrite nth_error_nil //. - - destruct n => //=. - * intros [= <-]. now rewrite skipn_S skipn_0. - * intros hnth. now rewrite skipn_S. -Qed. - -Lemma skipn_repeat {A} k n (a : A) : - skipn n (repeat a k) = repeat a (k - n). -Proof. - induction n in k |- *. - - rewrite skipn_0. lia_f_equal. - - destruct k => //=. - rewrite skipn_S IHn. lia_f_equal. -Qed. - -Lemma expanded_red {cf : checker_flags} {Σ : global_env_ext} Γ Γ' t v : wf Σ -> - expanded_global_env Σ -> - (forall n body, option_map decl_body (nth_error Γ n) = Some (Some body) -> expanded Σ (skipn (S n) Γ') body) -> - red1 Σ Γ t v -> - expanded Σ Γ' t -> - expanded Σ Γ' v. -Proof. - move=> wf expΣ wfΓ /red1_red1apps red. - induction red using Red1Apps.red1_ind_all in wfΓ, Γ' |- *; intros exp. - - eapply expanded_mkApps_inv in exp as [] => //. - eapply expanded_tLambda_inv in H. - depelim H0. - eapply expanded_mkApps => //. - eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. - - eapply expanded_tLetIn_inv in exp as []. - eapply (expanded_subst _ _ _ _ [] Γ') => //. now constructor. - - rewrite -(firstn_skipn (S i) Γ'). - eapply expanded_mkApps_inv' in exp; cbn in exp. - destruct exp as [_ [m []]]. eapply nth_error_Some_length in H0. - eapply (expanded_lift _ _ _ _ []) => //. - rewrite firstn_length_le; try lia. - now eapply wfΓ. - - eapply expanded_tCase_inv in exp as [? []]. - unfold iota_red. - move/expanded_mkApps_inv': H3 => /=. - rewrite arguments_mkApps // head_mkApps //=. - intros [hargs [mind [idecl [cdecl [declc hargs']]]]]. - eapply nth_error_forall in H2; tea. - destruct H2 as [[hbctx] hbod]. - eapply (expanded_subst _ _ _ _ [] _) => //. - + eapply Forall_rev, Forall_skipn => //. - + len. replace #|skipn (ci_npar ci) args| with (context_assumptions (inst_case_branch_context p br)). - eapply expanded_let_expansion; len. red. - sq. rewrite /inst_case_branch_context /inst_case_context /subst_context. - eapply PCUICParallelReduction.All_fold_fold_context_k. - eapply All_fold_map_context, All_fold_impl; tea; cbn. - intros ? ? fo. len. destruct x as [? [] ?] => //; constructor. - cbn in fo. depelim fo. eapply (expanded_subst _ _ _ _ (repeat 0 #|Γ0|) _); len. - eapply Forall_rev; eauto. - eapply expanded_subst_instance. rewrite app_assoc. now eapply expanded_weakening. - rewrite skipn_length. len. - - move/expanded_mkApps_inv': exp. cbn. - rewrite arguments_mkApps // head_mkApps //=. - move=> [hargs [d [hf [hargs' []]]]] hnth hrarg. - eapply expanded_mkApps_expanded => //; solve_all. - eapply expanded_unfold_fix in H; tea. - - eapply expanded_tCase_inv in exp as [? []]. - constructor => //. - eapply expanded_mkApps_inv' in H2. move: H2; rewrite arguments_mkApps // head_mkApps //=. - intros [hargs' hcof]. cbn in hcof. eapply expanded_tCoFix_inv in hcof. - eapply expanded_unfold_cofix in H; tea. eapply expanded_mkApps; tea => //. solve_all. - - eapply expanded_tProj_inv in exp. econstructor. - eapply expanded_mkApps_inv' in exp. move: exp; rewrite arguments_mkApps // head_mkApps //=. - intros [hargs' hcof]. cbn in hcof. eapply expanded_tCoFix_inv in hcof. - eapply expanded_mkApps => //. - eapply expanded_unfold_cofix in H; tea. solve_all. - - eapply expanded_subst_instance. - eapply expanded_global_env_constant in expΣ; tea. - eapply (expanded_weakening _ []). rewrite H0 in expΣ. now depelim expΣ. - - eapply expanded_tProj_inv in exp. - move/expanded_mkApps_inv': exp. rewrite arguments_mkApps // head_mkApps //=. - intros []. - eapply nth_error_forall in H0; tea. - - constructor. now eapply expanded_tLambda_inv in exp. - - constructor. eapply expanded_tLambda_inv in exp. - eapply IHred => //. - { intros [] body; cbn => //. rewrite skipn_S. eapply wfΓ. } - - eapply expanded_tLetIn_inv in exp; now constructor. - - eapply expanded_tLetIn_inv in exp. now constructor. - - eapply expanded_tLetIn_inv in exp. constructor; intuition eauto. - eapply IHred => //. - { intros [] ? => //=. intros [=]. subst b. now rewrite skipn_S skipn_0. - rewrite skipn_S. eapply wfΓ. } - - eapply expanded_tCase_inv in exp as [? []]. - constructor; eauto. cbn. - solve_all. eapply OnOne2_impl_All_r; tea. intuition eauto. now apply X0. - now rewrite /PCUICOnOne.set_pparams /= -(OnOne2_length X). - - eapply expanded_tCase_inv in exp as [? []]. - constructor; eauto. - - eapply expanded_tCase_inv in exp as [? []]. - econstructor; eauto. - - eapply expanded_tCase_inv in exp as [? []]. - econstructor; eauto. solve_all. - eapply OnOne2_impl_All_r; tea. - intros x y [? ?]. intros [[] ?]. rewrite -e0. - solve_all. eapply e => //. - intros n b. - clear -H H2 wfΓ. - destruct nth_error eqn:e' => //. - cbn. intros [=]. destruct c as [? [] ?]. cbn in *. noconf H1. - eapply nth_error_app_inv in e' as [[]|[]]. - { rewrite inst_case_branch_context_length in H0. destruct H2. - rewrite /inst_case_branch_context /inst_case_context in H1. - destruct (nth_error (bcontext x) n) eqn:e. - 2:{ eapply nth_error_None in e. rewrite skipn_app skipn_all2. len. cbn. len. } - rewrite /subst_context in H1. - erewrite nth_error_fold_context_k in H1. 4:{ rewrite nth_error_map e //. } 3:len. 2:exact []. - len in H1. noconf H1. destruct c as [? [] ?]; noconf H1. - rewrite skipn_app. len. eapply All_fold_nth_error in X; tea. cbn in X. depelim X. - rewrite skipn_length in H1. - eapply expanded_subst. rewrite skipn_length. len. - replace (S n - #|bcontext x|) with 0. 2:{ lia. } rewrite skipn_0. eapply Forall_rev. solve_all. - len. rewrite app_assoc. eapply expanded_weakening. eapply expanded_subst_instance. - now rewrite skipn_repeat. } - { rewrite inst_case_branch_context_length in H0, H1. - rewrite skipn_app skipn_all2 /=; len. - replace (S n - #|bcontext x|) with (S (n - #|bcontext x|)). 2:lia. - eapply wfΓ. rewrite H1 //. } - noconf H1. - - eapply expanded_tProj_inv in exp. now econstructor. - - eapply expanded_mkApps_inv' in exp. - rewrite head_mkApps head_nApp in exp => //. - rewrite arguments_mkApps // in exp. destruct exp as []. - specialize (IHred Γ' wfΓ). - destruct M1; try solve [eapply expanded_mkApps => //; eauto]. - * depelim red; solve_discr. eapply wfΓ in e. - eapply expanded_mkApps => //. - rewrite -(firstn_skipn (S n) Γ'). eapply (expanded_lift _ _ _ _ []) => //. - destruct H3 as [m [hn ha]]. - rewrite firstn_length_le //. now eapply nth_error_Some_length in hn. - depelim o. - * depelim red; solve_discr. depelim o. - - - eapply expanded_mkApps_inv' in exp. - move: exp. - rewrite head_mkApps head_nApp // arguments_mkApps //. - intros []. - assert(Forall (expanded Σ Γ') N2). - { clear H1. solve_all. eapply OnOne2_impl_All_r; tea. cbn. intuition auto. } - destruct M1; try solve [eapply expanded_mkApps => //; eauto]. - + rewrite (OnOne2_length X) in H1. destruct H1 as [m []]; eapply expanded_tRel; tea. - + rewrite (OnOne2_length X) in H1. destruct H1 as [m [? [? []]]]; eapply expanded_tConstruct_app; tea. - + rewrite (OnOne2_length X) in H1. - destruct H1 as [d [? [? []]]]; eapply expanded_tFix; tea. - destruct N2; cbn in *; eauto. lia. intros eq; discriminate. - - - move/expanded_mkApps_inv': exp. - rewrite head_mkApps head_nApp // arguments_mkApps // => [] [] hargs [d [hf [hm2 [hnth harg]]]]. - eapply OnOne2_nth_error in hnth as [t' [hnth hor]]; tea. - eapply expanded_tFix; tea. - { clear hor. solve_all. eapply OnOne2_impl_All_r; tea. - intros ? ? [] []. noconf e. rewrite -H2. split => //. solve_all. - clear -X H1. - enough (rev_map (fun d1 : def term => S (rarg d1)) mfix0 = (rev_map (fun d1 : def term => S (rarg d1)) mfix1)) as <- => //. - clear -X. rewrite !rev_map_spec. f_equal. induction X. destruct p as []. cbn in *. congruence. cbn. congruence. } - { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } - - - move/expanded_mkApps_inv': exp. - rewrite head_mkApps head_nApp // arguments_mkApps // => [] [] hargs [d [hf [hm2 [hnth harg]]]]. - eapply OnOne2_nth_error in hnth as [t' [hnth hor]]; tea. - eapply expanded_tFix; tea. - { clear hor. solve_all. - assert (rev_map (fun d1 : def term => S (rarg d1)) mfix0 = (rev_map (fun d1 : def term => S (rarg d1)) mfix1)). - { clear -X. rewrite !rev_map_spec. f_equal. induction X. destruct p as []. cbn in *. congruence. cbn. congruence. } - rewrite -H. - eapply OnOne2_impl_All_r; tea. - intros ? ? [] []. noconf e. destruct p. - eapply Red1Apps.isLambda_red1 in r; tea. split => //. - set(Γ'' := rev_map (fun d1 : def term => S (rarg d1)) mfix0). - eapply e => //. - { intros n b hnth'. - destruct (nth_error (fix_context mfix0) n) eqn:e'. - rewrite nth_error_app_lt in hnth'. now eapply nth_error_Some_length in e'. - rewrite e' in hnth'. noconf hnth'. - pose proof (PCUICParallelReductionConfluence.fix_context_assumption_context mfix0). - eapply PCUICParallelReductionConfluence.nth_error_assumption_context in H6; tea. congruence. - rewrite /Γ''. - eapply nth_error_None in e'. len in e'. - rewrite nth_error_app_ge in hnth' => //. now len. - rewrite skipn_app skipn_all2. len. - cbn. len. replace (S n - #|mfix0|) with (S (n - #|mfix0|)). 2:{ lia. } - eapply wfΓ. now len in hnth'. } } - { destruct hor; subst => //. destruct p as [? e]; noconf e. now congruence. } - - eapply expanded_tProd. - - constructor. - - constructor. - eapply expanded_tEvar_inv in exp. - solve_all; eapply OnOne2_impl_All_r; tea. intuition eauto. - now eapply X0. - - depelim exp; solve_discr. now cbn in H. - - depelim exp; solve_discr. now cbn in H. - - eapply expanded_tCoFix_inv in exp. econstructor. - rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. - destruct X0. noconf e. now rewrite -H1. - - eapply expanded_tCoFix_inv in exp. econstructor. - rewrite -(OnOne2_length X). solve_all; eapply OnOne2_impl_All_r; tea; intuition eauto. - destruct X0. destruct p. noconf e. eapply e0 => //. - intros n b. - destruct nth_error eqn:e' => //. - cbn. intros [=]. destruct c as [? [] ?]. cbn in *. noconf H4. - eapply nth_error_app_inv in e' as [[]|[]]. - { pose proof (PCUICParallelReductionConfluence.fix_context_assumption_context mfix0). - eapply PCUICParallelReductionConfluence.nth_error_assumption_context in H5; tea. cbn in H5. congruence. } - len in H3. len in H4. - rewrite skipn_app skipn_all2; len. - replace (S n - #|mfix0|) with (S (n - #|mfix0|)) by lia. eapply wfΓ. rewrite H4 /= //. - noconf H4. Qed. \ No newline at end of file diff --git a/pcuic/theories/PCUICWellScopedCumulativity.v b/pcuic/theories/PCUICWellScopedCumulativity.v index 1488b87a5..a2fd67f45 100644 --- a/pcuic/theories/PCUICWellScopedCumulativity.v +++ b/pcuic/theories/PCUICWellScopedCumulativity.v @@ -13,6 +13,8 @@ Require Import Equations.Prop.DepElim. Require Import Equations.Type.Relation Equations.Type.Relation_Properties. From Equations Require Import Equations. +Local Ltac intuition_solver ::= auto with *. + (* We show that conversion/cumulativity starting from well-typed terms is transitive. We first use typing to decorate the reductions/comparisons with invariants showing that all the considered contexts/terms are well-scoped. In a second step diff --git a/pcuic/theories/Typing/PCUICContextConversionTyp.v b/pcuic/theories/Typing/PCUICContextConversionTyp.v index e91f60548..9f289f114 100644 --- a/pcuic/theories/Typing/PCUICContextConversionTyp.v +++ b/pcuic/theories/Typing/PCUICContextConversionTyp.v @@ -16,6 +16,8 @@ Arguments red_ctx : clear implicits. Implicit Types (cf : checker_flags) (Σ : global_env_ext). +Local Ltac intuition_solver ::= auto with *. + Lemma lift0_open {cf:checker_flags} {Γ : closed_context} {Γ'' : open_context Γ} {M : open_term Γ} {n} : n = #|Γ''| -> is_open_term (Γ ,,, Γ'') (lift0 n M). diff --git a/pcuic/theories/utils/PCUICAstUtils.v b/pcuic/theories/utils/PCUICAstUtils.v index 1ad4cec57..c83af52f8 100644 --- a/pcuic/theories/utils/PCUICAstUtils.v +++ b/pcuic/theories/utils/PCUICAstUtils.v @@ -595,6 +595,30 @@ Qed. Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1. Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed. +Lemma head_mkApps t args : head (mkApps t args) = head t. +Proof. + induction args using rev_ind; simpl; auto. + now rewrite mkApps_app /= head_tapp. +Qed. + +Lemma arguments_mkApps_nApp f args : + ~~ isApp f -> + arguments (mkApps f args) = args. +Proof. + rewrite /arguments => isa. + rewrite decompose_app_mkApps //. +Qed. + +Lemma arguments_mkApps f args : + arguments (mkApps f args) = arguments f ++ args. +Proof. + rewrite /arguments. + rewrite /decompose_app decompose_app_rec_mkApps //. + rewrite app_nil_r. + induction f in args |- * => //=. + rewrite IHf1. now rewrite (IHf1 [f2]) -app_assoc. +Qed. + Lemma mkApps_Fix_spec mfix idx args t : mkApps (tFix mfix idx) args = t -> match decompose_app t with | (tFix mfix idx, args') => args' = args diff --git a/template-coq/theories/TypingWf.v b/template-coq/theories/TypingWf.v index 9ef53b3c8..125210814 100644 --- a/template-coq/theories/TypingWf.v +++ b/template-coq/theories/TypingWf.v @@ -1117,7 +1117,6 @@ Section TypingWf. (decompose_app (mkApp f u)).2 <> []. Proof using Type. induction f; simpl; auto; try congruence. - destruct args; simpl; congruence. Qed. Lemma mkApps_tApp' f u f' u' : diff --git a/template-coq/theories/WcbvEval.v b/template-coq/theories/WcbvEval.v index 90c22bdef..a41410626 100644 --- a/template-coq/theories/WcbvEval.v +++ b/template-coq/theories/WcbvEval.v @@ -645,10 +645,10 @@ Section Wcbv. cbn in vf'; destruct vf'. - eapply eval_construct; tea. apply app_tip_nil. now eapply All2_app. - rewrite -mkApps_tApp => //. rewrite is_empty_app /= andb_false_r //. - eapply eval_app_cong; auto. eapply app_tip_nil. + eapply eval_app_cong; auto. eapply All2_app; auto. - rewrite -mkApps_tApp => //. rewrite is_empty_app /= andb_false_r //. - eapply eval_app_cong; auto. eapply app_tip_nil. + eapply eval_app_cong; auto. eapply All2_app; auto. - eapply eval_fix_value with (fixargsv := []) (argsv := x0 ++ [y]). 4:tea. all: move=> //. diff --git a/template-coq/theories/WfAst.v b/template-coq/theories/WfAst.v index 0fb54d7b7..a723d762e 100644 --- a/template-coq/theories/WfAst.v +++ b/template-coq/theories/WfAst.v @@ -198,7 +198,7 @@ Lemma wf_mkApp Σ u a : wf Σ u -> wf Σ a -> wf Σ (mkApp u a). Proof. intros H H'. inversion_clear H; try constructor; simpl; auto; try congruence; try constructor; auto. - intro. destruct u0; simpl in *; congruence. solve_all. + solve_all. apply All_app_inv; auto. all:econstructor; eauto. Qed. diff --git a/utils/theories/MCList.v b/utils/theories/MCList.v index b3900805b..d08b8d870 100644 --- a/utils/theories/MCList.v +++ b/utils/theories/MCList.v @@ -1383,6 +1383,7 @@ Lemma app_tip_nil {A} (l : list A) (x : A) : (l ++ [x])%list <> []. Proof. destruct l; cbn; congruence. Qed. +Global Hint Resolve app_tip_nil : core. Definition remove_last {A} (args : list A) := List.firstn (#|args| - 1) args. From b072acf2ec507b1fb3cbce17607d7b973e92afe1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 13 Sep 2023 10:15:21 +0200 Subject: [PATCH 54/65] Filled all proofs in ErasureCorrectness --- erasure-plugin/theories/ErasureCorrectness.v | 270 ++++++++++--------- 1 file changed, 150 insertions(+), 120 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index dbbaacecf..551ded36b 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -106,91 +106,6 @@ Ltac destruct_compose_no_clear := rewrite H; revert pre'' H end. -(* -Section TransformValue. - Context {program program' : Type}. - Context {value value' : Type}. - Context {eval : program -> value -> Prop}. - Context {eval' : program' -> value' -> Prop}. - Context (t : Transform.t program program' value value' eval eval'). - - Lemma preserves_value p : value p.1 p.2 (transform t p) - - Definition preserves_eval pre (transform : forall p : program, pre p -> program') - (obseq : forall p : program, pre p -> program' -> value -> value' -> Prop) := - forall p v (pr : pre p), - eval p v -> - let p' := transform p pr in - exists v', eval' p' v' /\ obseq p pr p' v v'. - - Record t := - { name : string; - -Lemma transform_value *) - - -Inductive is_construct_app : EAst.term -> Prop := -| is_cstr_app_cstr kn c args : Forall is_construct_app args -> is_construct_app (EAst.tConstruct kn c args) -| is_cstr_app_app f a : is_construct_app f -> is_construct_app a -> is_construct_app (EAst.tApp f a). - -Section lambdabox_theorem. - - Context (Σ Σ' : EEnvMap.GlobalContextMap.t) (v : EAst.term). - - Context (p : pre verified_lambdabox_pipeline (Σ, v)). - Context (p' : pre verified_lambdabox_pipeline (Σ', v)). - Context (is_value : value (wfl := default_wcbv_flags) Σ v). - - Lemma pres : extends_eprogram_env (Σ, v) (Σ', v) -> - extends_eprogram (transform verified_lambdabox_pipeline (Σ, v) p) - (transform verified_lambdabox_pipeline (Σ', v) p'). - Proof. - epose proof (pres := verified_lambdabox_pipeline_extends). - red in pres. specialize (pres _ _ p p'). auto. - Qed. - - (* Final evaluation flags *) - Definition evflags := {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}. - - Lemma pres_firstorder_value : - is_construct_app v -> - is_construct_app (transform verified_lambdabox_pipeline (Σ, v) p).2. - Proof. - intros isapp. - destruct (preservation verified_lambdabox_pipeline (Σ, v) v p) as [v' [[ev] obs]]. - { red. cbn. sq. eapply value_final, is_value. } - set (transp := transform _ _ p) in *. - assert (value (wfl := evflags) transp.1 transp.2). admit. - eapply eval_value in ev => //. subst v'. - clear -obs isapp. - unfold verified_lambdabox_pipeline in obs. - cbn [obseq compose] in obs. - unfold run, time in obs. - decompose [ex and prod] obs. clear obs. subst. - cbn [obseq compose verified_lambdabox_pipeline] in *. - cbn [obseq compose constructors_as_blocks_transformation] in *. - cbn [obseq run compose rebuild_wf_env_transform] in *. - cbn [obseq compose inline_projections_optimization] in *. - cbn [obseq compose remove_match_on_box_trans] in *. - cbn [obseq compose remove_params_optimization] in *. - cbn [obseq compose guarded_to_unguarded_fix] in *. - cbn [obseq compose verified_lambdabox_pipeline] in *. - subst. - cbn [transform rebuild_wf_env_transform] in *. - cbn [transform constructors_as_blocks_transformation] in *. - cbn [transform inline_projections_optimization] in *. - cbn [transform remove_match_on_box_trans] in *. - cbn [transform remove_params_optimization] in *. - cbn [transform guarded_to_unguarded_fix] in *. - clearbody transp. revert b. intros ->. clear transp. - induction isapp. - cbn in *. constructor. constructor. - Admitted. - - -End lambdabox_theorem. - - Lemma rebuild_wf_env_irr {efl : EWellformed.EEnvFlags} p wf p' wf' : p.1 = p'.1 -> (rebuild_wf_env p wf).1 = (rebuild_wf_env p' wf').1. @@ -880,7 +795,7 @@ Qed. Arguments PCUICFirstorder.firstorder_ind _ _ : clear implicits. Section PCUICExpandLets. - Import PCUICAst. + Import PCUICAst PCUICAstUtils PCUICFirstorder. Import PCUICEnvironment. Import PCUICExpandLets PCUICExpandLetsCorrectness. @@ -896,10 +811,10 @@ Section PCUICExpandLets. Lemma expand_lets_preserves_fo (Σ : global_env_ext) Γ v : wf Σ -> - PCUICFirstorder.firstorder_value Σ Γ v -> - PCUICFirstorder.firstorder_value (trans_global Σ) (trans_local Γ) (trans v). + firstorder_value Σ Γ v -> + firstorder_value (trans_global Σ) (trans_local Γ) (trans v). Proof. - intros wfΣ; move: v; apply: PCUICFirstorder.firstorder_value_inds. + intros wfΣ; move: v; apply: firstorder_value_inds. intros i n ui u args pandi hty hargs ihargs isp. rewrite trans_mkApps. econstructor. apply expand_lets_sound in hty. @@ -914,6 +829,122 @@ Section PCUICExpandLets. rewrite (trans_destArity []). destruct destArity => //. destruct p => //. now intros ->. Qed. + + Lemma forallb_mapi {A B} (f f' : nat -> A -> B) (g g' : B -> bool) l : + (forall n x, nth_error l n = Some x -> g (f n x) = g' (f' n x)) -> + forallb g (mapi f l) = forallb g' (mapi f' l). + Proof. + unfold mapi. + intros. + assert + (forall (n : nat) (x : A), nth_error l n = Some x -> g (f (0 + n) x) = g' (f' (0 + n) x)). + { intros n x. now apply H. } + clear H. + revert H0. + generalize 0. + induction l; cbn; auto. + intros n hfg. f_equal. specialize (hfg 0). rewrite Nat.add_0_r in hfg. now apply hfg. + eapply IHl. intros. replace (S n + n0) with (n + S n0) by lia. eapply hfg. + now cbn. + Qed. + + Lemma forallb_mapi_impl {A B} (f f' : nat -> A -> B) (g g' : B -> bool) l : + (forall n x, nth_error l n = Some x -> g (f n x) -> g' (f' n x)) -> + forallb g (mapi f l) -> forallb g' (mapi f' l). + Proof. + unfold mapi. + intros hfg. + assert + (forall (n : nat) (x : A), nth_error l n = Some x -> g (f (0 + n) x) -> g' (f' (0 + n) x)). + { intros n x ?. now apply hfg. } + clear hfg. + revert H. + generalize 0. + induction l; cbn; auto. + intros n hfg. move/andP => [] hg hf. + pose proof (hfg 0). rewrite Nat.add_0_r in H. apply H in hg => //. rewrite hg /=. + eapply IHl. intros. replace (S n + n0) with (n + S n0) by lia. eapply hfg. now cbn. + now rewrite Nat.add_succ_r. assumption. + Qed. + + Lemma expand_firstorder_type Σ n k t : + (forall nm, plookup_env (firstorder_env' Σ) nm = Some true -> + plookup_env (firstorder_env' (trans_global_decls Σ)) nm = Some true) -> + @PCUICFirstorder.firstorder_type (firstorder_env' Σ) n k t -> + @PCUICFirstorder.firstorder_type (firstorder_env' (trans_global_decls Σ)) n k (trans t). + Proof. + rewrite /PCUICFirstorder.firstorder_type /PCUICFirstorder.firstorder_env. + pose proof (trans_decompose_app t). + destruct decompose_app. rewrite H. cbn. + destruct t0 => //. intros hd => /=. + destruct ind. + destruct plookup_env eqn:hp => //. + destruct b => //. + eapply hd in hp. rewrite hp //. + Qed. + + Lemma trans_firstorder_mutind Σ m : + (forall nm, plookup_env (firstorder_env' Σ) nm = Some true -> + plookup_env (firstorder_env' (trans_global_decls Σ)) nm = Some true) -> + @firstorder_mutind (firstorder_env' Σ) m -> + @firstorder_mutind (firstorder_env' (trans_global_decls Σ)) (trans_minductive_body m). + Proof. + intros he. + rewrite /firstorder_mutind. f_equal. + rewrite /trans_minductive_body /=. + rewrite -{1}[ind_bodies m]map_id. rewrite -mapi_cst_map. + move/andP => [] -> /=. + eapply forallb_mapi_impl. + intros n x hnth. + rewrite /firstorder_oneind. destruct x; cbn. + move/andP => [] hc ->; rewrite andb_true_r. + rewrite forallb_map. solve_all. + move: H; rewrite /firstorder_con /=. + rewrite !rev_app_distr !alli_app. + move/andP => [hp ha]. apply/andP; split. + - len. rewrite /trans_local -map_rev alli_map. + eapply alli_impl; tea. intros i []. cbn. + now eapply expand_firstorder_type. + - len. len in ha. clear -ha he. + move: ha; generalize (cstr_args x) as args. + induction args => ha; cbn => //. + destruct a as [na [] ?] => /=. eapply IHargs. cbn in ha. + rewrite alli_app in ha. move/andP: ha => [] //. + cbn. rewrite PCUICSigmaCalculus.smash_context_acc /=. + cbn in ha. rewrite alli_app in ha. move/andP: ha => [] // hc hd. + rewrite alli_app. apply/andP. split. apply IHargs => //. + len. cbn. rewrite andb_true_r. cbn in hd. rewrite andb_true_r in hd. len in hd. + clear -he hd. move: hd. rewrite /firstorder_type. + destruct (decompose_app decl_type) eqn:e. cbn. + destruct t0 => //; apply decompose_app_inv in e; rewrite e. + { rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps + decompose_app_mkApps //=. todo "foo". + destruct nth_error eqn:hnth. + move/andP => [] /Nat.leb_le hn /Nat.ltb_lt hn'. + move/nth_error_Some_length: hnth. len. destruct (Nat.leb_spec #|args| n). lia. lia. + len. + move/andP => [] /Nat.leb_le hn /Nat.ltb_lt hn'. + destruct (Nat.leb_spec #|args| n). apply/andP. split. + eapply Nat.leb_le. lia. apply Nat.ltb_lt. lia. + apply/andP; split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } + { rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps + decompose_app_mkApps //=. + destruct ind. destruct plookup_env eqn:hp => //. destruct b => //. apply he in hp. rewrite hp //. } + Qed. + + Lemma trans_firstorder_env Σ : + (forall nm, plookup_env (firstorder_env' Σ) nm = Some true -> + plookup_env (firstorder_env' (trans_global_decls Σ)) nm = Some true). + Proof. + induction Σ; cbn => //. + destruct a. destruct g => //=. + intros nm. + destruct eqb => //. now apply IHΣ. + intros nm. destruct eqb => //. + intros [=]. f_equal. + now eapply trans_firstorder_mutind. apply IHΣ. + Qed. + End PCUICExpandLets. @@ -1015,26 +1046,13 @@ Section pipeline_theorem. move: fo. rewrite /PCUICFirstorder.firstorder_ind /= PCUICExpandLetsCorrectness.trans_lookup /=. destruct PCUICAst.PCUICEnvironment.lookup_env => //. destruct g => //=. - unfold PCUICFirstorder.firstorder_mutind. cbn. - move/andP => [] -> /=. ELiftSubst.solve_all. - eapply forallb_Forall in b. apply forallb_Forall. - ELiftSubst.solve_all. eapply All_mapi. - eapply All_Alli; tea. cbn. - intros n []. rewrite /PCUICFirstorder.firstorder_oneind /=. - move/andP => [] hf ->; rewrite andb_true_r. - eapply forallb_Forall in hf. apply forallb_Forall. - ELiftSubst.solve_all. - rewrite /PCUICFirstorder.firstorder_con in H *. - eapply alli_Alli. eapply alli_Alli in H. - destruct x; cbn in *. - eapply Alli_rev. - ELiftSubst.solve_all. - - re - destruct m; cbn in *. - - forward H0. - { cbn. todo "preserves values". } + eapply trans_firstorder_mutind. eapply trans_firstorder_env. } + forward H0. { cbn. rewrite -eqtr. + unshelve eapply (PCUICExpandLetsCorrectness.trans_wcbveval (Σ := Σ)); tea. exact extraction_checker_flags. + apply HΣ. apply PCUICExpandLetsCorrectness.trans_wf, HΣ. + 2:{ eapply PCUICWcbvEval.value_final. now eapply PCUICWcbvEval.eval_to_value in X. } + eapply PCUICWcbvEval.eval_closed; tea. apply HΣ. + unshelve apply (PCUICClosedTyp.subject_closed typing). } specialize (H0 _ eq_refl). rewrite /p. rewrite erase_transform_fo //. @@ -1055,7 +1073,7 @@ Section pipeline_theorem. Import PCUICWfEnv. Lemma verified_erasure_pipeline_theorem : - ∥ eval (wfl := extraction_wcbv_flags) Σ_t t_t v_t∥. + ∥ eval (wfl := extraction_wcbv_flags) Σ_t t_t v_t ∥. Proof. hnf. pose proof (preservation verified_erasure_pipeline (Σ, t)) as Hcorr. @@ -1120,26 +1138,38 @@ Section pipeline_theorem. eapply (ErasureFunctionProperties.firstorder_erases_deterministic optimized_abstract_env_impl wfe Σ.2) in b0. 3:tea. 2:{ cbn. reflexivity. } 2:{ eapply PCUICExpandLetsCorrectness.trans_wcbveval. eapply PCUICWcbvEval.eval_closed; tea. apply HΣ. - admit. + clear -typing HΣ; now eapply PCUICClosedTyp.subject_closed in typing. eapply PCUICWcbvEval.value_final. now eapply PCUICWcbvEval.eval_to_value in X0. } - 2:{ clear -fo. admit. } + 2:{ clear -fo. revert fo. rewrite /PCUICFirstorder.firstorder_ind /=. + rewrite PCUICExpandLetsCorrectness.trans_lookup. + destruct PCUICAst.PCUICEnvironment.lookup_env => //. + destruct g => //=. + eapply trans_firstorder_mutind. eapply trans_firstorder_env. } 2:{ apply HΣ. } 2:{ apply PCUICExpandLetsCorrectness.trans_wf, HΣ. } - rewrite b0. - intros obs. - constructor. + rewrite b0. intros obs. constructor. match goal with [ H1 : eval _ _ ?v1 |- eval _ _ ?v2 ] => enough (v2 = v1) as -> by exact ev end. eapply obseq_lambdabox; revgoals. unfold erase_pcuic_program. cbn [fst snd]. exact obs. + Unshelve. all:eauto. + 2:{ eapply PCUICExpandLetsCorrectness.trans_wf, HΣ. } clear obs b0 ev e w. eapply extends_erase_pcuic_program. cbn. - eapply (PCUICExpandLetsCorrectness.trans_wcbveval (Σ := (Σ.1, Σ.2))). + unshelve eapply (PCUICExpandLetsCorrectness.trans_wcbveval (cf := extraction_checker_flags) (Σ := (Σ.1, Σ.2))). + { now eapply PCUICExpandLetsCorrectness.trans_wf. } { clear -HΣ typing. now eapply PCUICClosedTyp.subject_closed in typing. } cbn. 2:cbn. 3:cbn. exact X0. - - - - Admitted. + now eapply trans_axiom_free. + pose proof (PCUICExpandLetsCorrectness.expand_lets_sound typing). + rewrite PCUICExpandLetsCorrectness.trans_mkApps in X1. eapply X1. + cbn. + move: fo. clear. + { rewrite /PCUICFirstorder.firstorder_ind /=. + rewrite PCUICExpandLetsCorrectness.trans_lookup. + destruct PCUICAst.PCUICEnvironment.lookup_env => //. + destruct g => //=. + eapply trans_firstorder_mutind. eapply trans_firstorder_env. } + Qed. Lemma verified_erasure_pipeline_lambda : PCUICAst.isLambda t -> EAst.isLambda t_t. From 708302f5901363a86bc522ba9bbeed91a1aa9366 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 13 Sep 2023 11:29:35 +0200 Subject: [PATCH 55/65] Cleanup a bit, remain only normalization side-conditions --- erasure-plugin/theories/ErasureCorrectness.v | 144 +++++++++++++------ erasure/theories/ErasureFunctionProperties.v | 33 +++-- erasure/theories/Typed/Erasure.v | 2 - erasure/theories/Typed/Extraction.v | 2 +- 4 files changed, 120 insertions(+), 61 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 551ded36b..bcf1c9600 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -581,6 +581,41 @@ Proof. Qed. Derive Signature for firstorder_evalue. +Section PCUICenv. + Import PCUICAst. + Import PCUICEnvironment. + + Lemma pres_inductives_lookup Σ Σ' i n mdecl idecl cdecl : + wf Σ -> + erase_preserves_inductives Σ Σ' -> + declared_constructor Σ (i, n) mdecl idecl cdecl -> + forall npars nargs, EGlobalEnv.lookup_constructor_pars_args Σ' i n = Some (npars, nargs) -> + npars = mdecl.(ind_npars) /\ nargs = cdecl.(cstr_arity). + Proof. + intros wf he. + rewrite /declared_constructor /declared_inductive. + intros [[declm decli] declc]. + unshelve eapply declared_minductive_to_gen in declm. 3:exact wf. red in declm. + intros npars nargs. rewrite /EGlobalEnv.lookup_constructor_pars_args. + rewrite /EGlobalEnv.lookup_constructor /EGlobalEnv.lookup_inductive /EGlobalEnv.lookup_minductive. + destruct EGlobalEnv.lookup_env eqn:e => //=. + destruct g => //. + eapply he in declm; tea. subst m. + rewrite nth_error_map decli /=. + rewrite nth_error_map declc /=. intuition congruence. + Qed. +End PCUICenv. + +Lemma lookup_constructor_pars_args_lookup_inductive_pars Σ i n npars nargs : + EGlobalEnv.lookup_constructor_pars_args Σ i n = Some (npars, nargs) -> + EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars. +Proof. + rewrite /EGlobalEnv.lookup_constructor_pars_args /EGlobalEnv.lookup_inductive_pars. + rewrite /EGlobalEnv.lookup_constructor /EGlobalEnv.lookup_inductive. + destruct EGlobalEnv.lookup_minductive => //=. + destruct nth_error => //. destruct nth_error => //. congruence. +Qed. + Lemma compile_evalue_erase (Σ : PCUICAst.PCUICEnvironment.global_env_ext) (Σ' : EEnvMap.GlobalContextMap.t) v : wf Σ.1 -> PCUICFirstorder.firstorder_value Σ [] v -> @@ -593,16 +628,9 @@ Proof. intros i n ui u args pandi hty hargs ih isp. eapply PCUICInductiveInversion.Construct_Ind_ind_eq' in hty as [mdecl [idecl [cdecl [declc _]]]] => //. rewrite compile_value_erase_mkApps. - intros fo'. depelim fo'. EAstUtils.solve_discr. noconf H1. + intros fo'. depelim fo'. EAstUtils.solve_discr. noconf H1. noconf H2. assert (npars = PCUICAst.PCUICEnvironment.ind_npars mdecl). - { destruct declc as [[declm decli] declc]. - unshelve eapply declared_minductive_to_gen in declm. 3:exact wf. red in declm. - rewrite /EGlobalEnv.lookup_inductive_pars /EGlobalEnv.lookup_minductive in H. - destruct (PCUICAst.PCUICEnvironment.lookup_env) eqn:hl => //. - noconf declm. - destruct (EGlobalEnv.lookup_env) eqn:hl' => //. destruct g => //. - red in hΣ. - eapply hΣ in hl'; tea. cbn in H. noconf H. subst m. reflexivity. } + { now eapply pres_inductives_lookup in declc; tea. } subst npars. rewrite (compile_value_box_mkApps (npars := PCUICAst.PCUICEnvironment.ind_npars mdecl)). { destruct declc as [[declm decli] declc]. @@ -611,6 +639,7 @@ Proof. rewrite /pcuic_lookup_inductive_pars // declm //. } rewrite (compile_evalue_box_strip_mkApps (npars := PCUICAst.PCUICEnvironment.ind_npars mdecl)) //. rewrite lookup_inductive_pars_spec //. + eapply lookup_constructor_pars_args_lookup_inductive_pars; tea. rewrite !app_nil_r. f_equal. rewrite app_nil_r skipn_map in H0. eapply Forall_map_inv in H0. @@ -619,6 +648,19 @@ Proof. ELiftSubst.solve_all. Qed. + +Lemma lookup_constructor_pars_args_nopars {efl : EEnvFlags} Σ ind c npars nargs : + wf_glob Σ -> + has_cstr_params = false -> + EGlobalEnv.lookup_constructor_pars_args Σ ind c = Some (npars, nargs) -> npars = 0. +Proof. + intros wf h. + rewrite /EGlobalEnv.lookup_constructor_pars_args. + destruct EGlobalEnv.lookup_constructor eqn:e => //=. + destruct p as [[m i] cb]. intros [= <- <-]. + now eapply wellformed_lookup_constructor_pars in e. +Qed. + Lemma compile_evalue_box_firstorder {efl : EEnvFlags} {Σ : EEnvMap.GlobalContextMap.t} v : has_cstr_params = false -> EWellformed.wf_glob Σ -> @@ -628,10 +670,8 @@ Proof. move: v; apply: firstorder_evalue_elim. intros. rewrite /flip (compile_evalue_box_mkApps) // ?app_nil_r. - rewrite /EGlobalEnv.lookup_inductive_pars /= in H. - destruct EGlobalEnv.lookup_minductive eqn:e => //. - eapply wellformed_lookup_inductive_pars in hpars; tea => //. - noconf H. rewrite hpars in H1. rewrite skipn_0 in H1. + eapply lookup_constructor_pars_args_nopars in H; tea. subst npars. + rewrite skipn_0 in H1. constructor. ELiftSubst.solve_all. Qed. @@ -667,11 +707,13 @@ Proof. split => //. clear wf; move: t1 fo. unfold fo_evalue, fo_evalue_map. cbn. apply: firstorder_evalue_elim; intros. econstructor. - rewrite EInlineProjections.lookup_inductive_pars_optimize in H => //; tea. auto. + move: H. rewrite /EGlobalEnv.lookup_constructor_pars_args. + rewrite EInlineProjections.lookup_constructor_optimize //. intros h; exact h. auto. auto. - rewrite /fo_evalue_map. intros [] pr fo. cbn in *. unfold EInlineProjections.optimize_program. cbn. f_equal. destruct pr as [[pr _] _]. cbn in *. move: t1 fo. apply: firstorder_evalue_elim; intros. - eapply wf_glob_lookup_inductive_pars in H => //. subst npars; rewrite skipn_0 in H0 H1. + eapply lookup_constructor_pars_args_nopars in H; tea => //. subst npars. + rewrite skipn_0 in H0 H1. rewrite EInlineProjections.optimize_mkApps /=. f_equal. ELiftSubst.solve_all. Qed. @@ -688,17 +730,26 @@ Proof. split => //. clear wf; move: t1 fo. apply: firstorder_evalue_elim; intros. econstructor; tea. - rewrite EOptimizePropDiscr.lookup_inductive_pars_optimize in H0 => //; tea. + move: H0. + rewrite /EGlobalEnv.lookup_constructor_pars_args EOptimizePropDiscr.lookup_constructor_remove_match_on_box //. - intros [] pr fo. cbn in *. unfold EOptimizePropDiscr.remove_match_on_box_program; cbn. f_equal. destruct pr as [[pr _] _]; cbn in *; move: t1 fo. apply: firstorder_evalue_elim; intros. - eapply wf_glob_lookup_inductive_pars in H0 => //. subst npars; rewrite skipn_0 in H2. - rewrite EOptimizePropDiscr.remove_match_on_box_mkApps /=. f_equal. + eapply lookup_constructor_pars_args_nopars in H0; tea => //. subst npars. + rewrite skipn_0 in H2. rewrite EOptimizePropDiscr.remove_match_on_box_mkApps /=. f_equal. ELiftSubst.solve_all. Qed. +Lemma lookup_constructor_pars_args_strip (Σ : t) i n npars nargs : + EGlobalEnv.lookup_constructor_pars_args Σ i n = Some (npars, nargs) -> + EGlobalEnv.lookup_constructor_pars_args (ERemoveParams.strip_env Σ) i n = Some (0, nargs). +Proof. + rewrite /EGlobalEnv.lookup_constructor_pars_args. rewrite ERemoveParams.lookup_constructor_strip //=. + destruct EGlobalEnv.lookup_constructor => //. destruct p as [[] ?] => //=. now intros [= <- <-]. +Qed. + #[global] Instance remove_params_optimization_pres {fl : WcbvFlags} {wcon : with_constructor_as_block = false} : ETransformPresFO.t (remove_params_optimization (wcon := wcon)) @@ -708,12 +759,12 @@ Proof. split => //. cbn [transform remove_params_optimization] in *. destruct pr as [[pr _] _]; cbn -[ERemoveParams.strip] in *; move: t1 fo. apply: firstorder_evalue_elim; intros. - rewrite ERemoveParams.strip_mkApps //. cbn -[EGlobalEnv.lookup_inductive_pars]. rewrite H. - econstructor. cbn -[EGlobalEnv.lookup_inductive_pars]. - now eapply ERemoveParams.lookup_inductive_pars_strip in H; tea. - rewrite skipn_0 /=. - rewrite skipn_map. - ELiftSubst.solve_all. + rewrite ERemoveParams.strip_mkApps //. cbn -[EGlobalEnv.lookup_inductive_pars]. + rewrite (lookup_constructor_pars_args_lookup_inductive_pars _ _ _ _ _ H). + eapply lookup_constructor_pars_args_strip in H. + econstructor; tea. rewrite skipn_0 /= skipn_map. + ELiftSubst.solve_all. len. + rewrite skipn_map. len. rewrite skipn_length. lia. Qed. #[global] Instance constructors_as_blocks_transformation_pres {efl : EWellformed.EEnvFlags} @@ -726,16 +777,18 @@ Proof. split. - intros v pr fo; eapply compile_evalue_box_firstorder; tea. apply pr. - move=> [Σ v] /= pr fo. rewrite /flip. - clear pr. move: v fo. + destruct pr as [[wf _] _]. cbn in wf. + move: v fo. apply: firstorder_evalue_elim; intros. rewrite /transform_blocks_program /=. f_equal. rewrite EConstructorsAsBlocks.transform_blocks_decompose. rewrite EAstUtils.decompose_app_mkApps // /=. rewrite compile_evalue_box_mkApps // ?app_nil_r. - (* rewrite lookup_inductive_pars_spec //. *) - admit. -Admitted. - + rewrite H. + eapply lookup_constructor_pars_args_nopars in H => //. subst npars. + rewrite chop_all. len. cbn. f_equal. rewrite skipn_0 in H1 H0. + ELiftSubst.solve_all. unfold transform_blocks_program in a. now noconf a. +Qed. #[global] Instance guarded_to_unguarded_fix_pres {efl : EWellformed.EEnvFlags} {has_guard : with_guarded_fix} {has_cstrblocks : with_constructor_as_block = false} : @@ -783,9 +836,11 @@ Lemma compile_evalue_strip (Σer : EEnvMap.GlobalContextMap.t) p : Proof. move: p. apply: firstorder_evalue_elim; intros. - rewrite ERemoveParams.strip_mkApps //=. rewrite H. + rewrite ERemoveParams.strip_mkApps //=. + rewrite (lookup_constructor_pars_args_lookup_inductive_pars _ _ _ _ _ H). rewrite compile_evalue_box_mkApps. rewrite (compile_evalue_box_strip_mkApps (npars:=npars)). + pose proof (lookup_constructor_pars_args_lookup_inductive_pars _ _ _ _ _ H). rewrite lookup_inductive_pars_spec //. rewrite !app_nil_r !skipn_map. f_equal. rewrite map_map. @@ -917,16 +972,18 @@ Section PCUICExpandLets. clear -he hd. move: hd. rewrite /firstorder_type. destruct (decompose_app decl_type) eqn:e. cbn. destruct t0 => //; apply decompose_app_inv in e; rewrite e. - { rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps - decompose_app_mkApps //=. todo "foo". + { move/andP => [] /Nat.leb_le hn /Nat.ltb_lt hn'. + rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps + decompose_app_mkApps //=. + { destruct nth_error eqn:hnth. + pose proof (nth_error_Some_length hnth). + move: hnth H. + destruct (Nat.leb_spec #|args| n). len. lia. len. lia. now cbn. } destruct nth_error eqn:hnth. - move/andP => [] /Nat.leb_le hn /Nat.ltb_lt hn'. - move/nth_error_Some_length: hnth. len. destruct (Nat.leb_spec #|args| n). lia. lia. - len. - move/andP => [] /Nat.leb_le hn /Nat.ltb_lt hn'. - destruct (Nat.leb_spec #|args| n). apply/andP. split. - eapply Nat.leb_le. lia. apply Nat.ltb_lt. lia. - apply/andP; split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } + move/nth_error_Some_length: hnth. len. destruct (Nat.leb_spec #|args| n). lia. lia. len. + destruct (Nat.leb_spec #|args| n). apply/andP. split. + eapply Nat.leb_le. lia. apply Nat.ltb_lt. lia. + apply/andP; split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } { rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps decompose_app_mkApps //=. destruct ind. destruct plookup_env eqn:hp => //. destruct b => //. apply he in hp. rewrite hp //. } @@ -1080,10 +1137,6 @@ Section pipeline_theorem. unshelve eapply Hcorr in Heval as Hev. eapply precond. destruct Hev as [v' [[H1] H2]]. move: H2. - - (* repeat match goal with - [ H : obseq _ _ _ _ _ |- _ ] => hnf in H ; decompose [ex and prod] H ; subst - end. *) rewrite v_t_spec. subst v_t Σ_t t_t. revert H1. @@ -1171,10 +1224,11 @@ Section pipeline_theorem. eapply trans_firstorder_mutind. eapply trans_firstorder_env. } Qed. - Lemma verified_erasure_pipeline_lambda : + (*Lemma verified_erasure_pipeline_lambda : PCUICAst.isLambda t -> EAst.isLambda t_t. Proof. unfold t_t. clear. - Admitted. + Qed.*) End pipeline_theorem. + diff --git a/erasure/theories/ErasureFunctionProperties.v b/erasure/theories/ErasureFunctionProperties.v index b1c0a710e..ca453b065 100644 --- a/erasure/theories/ErasureFunctionProperties.v +++ b/erasure/theories/ErasureFunctionProperties.v @@ -1989,9 +1989,10 @@ From MetaCoq.PCUIC Require Import PCUICFirstorder. From Equations Require Import Equations. Inductive firstorder_evalue Σ : EAst.term -> Prop := - | is_fo i n args npars : - EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + | is_fo i n args npars nargs : + EGlobalEnv.lookup_constructor_pars_args Σ i n = Some (npars, nargs) -> Forall (firstorder_evalue Σ) (skipn npars args) -> + #|args| = npars + nargs -> firstorder_evalue Σ (EAst.mkApps (EAst.tConstruct i n []) args). Lemma list_size_skipn {A} (l : list A) size n : @@ -2006,14 +2007,15 @@ Qed. Section elim. Context (Σ : E.global_context). Context (P : EAst.term -> Prop). - Context (ih : (forall i n args npars, - EGlobalEnv.lookup_inductive_pars Σ (Kernames.inductive_mind i) = Some npars -> + Context (ih : (forall i n args npars nargs, + EGlobalEnv.lookup_constructor_pars_args Σ i n = Some (npars, nargs) -> Forall (firstorder_evalue Σ) (skipn npars args) -> Forall P (skipn npars args) -> + #|args| = npars + nargs -> P (EAst.mkApps (EAst.tConstruct i n []) args))). Equations? firstorder_evalue_elim (t : EAst.term) (fo : firstorder_evalue Σ t) : P t by wf t (MR lt EInduction.size) := - { | _, is_fo i n args npars hl hf => _ }. + { | _, is_fo i n args npars nargs hl hf hargs => _ }. Proof. eapply ih; tea. eapply In_Forall. intros x hin. @@ -2101,10 +2103,10 @@ Lemma firstorder_evalue_extends Σ Σ' t : firstorder_evalue Σ' t. Proof. intros ext; move: t. - apply: firstorder_evalue_elim => i n args npars hl hf ih. + apply: firstorder_evalue_elim => i n args npars nargs hl hf hargs ih. econstructor; tea. red in ext. - move: hl; rewrite /lookup_inductive_pars /lookup_minductive. + move: hl; rewrite /lookup_constructor_pars_args /lookup_constructor /lookup_inductive /lookup_minductive. move: (ext (inductive_mind i)). now case: lookup_env => // a; move/(_ _ eq_refl) ->. Qed. @@ -2167,6 +2169,7 @@ Proof. { destruct (wfext Σg Hg). eapply PCUICFirstorder.firstorder_value_spec; tea. apply X0. constructor. eapply PCUICClassification.subject_reduction_eval; tea. eapply PCUICWcbvEval.eval_to_value; tea. } + 2:{ eapply subject_reduction; eauto. } { rewrite H1 in e. eapply erase_global_deps_eval in e. eapply firstorder_evalue_extends; tea. clear e. clear -Hrel H Hg Hwf. move: v H wt'. @@ -2186,16 +2189,18 @@ Proof. move/is_erasableP: i0. intros hc. destruct (hc _ Hrel). eapply (isErasable_Propositional (args:=[])) in X0 => //. cbn in X0, isp => //. rewrite X0 in isp => //. - eapply PCUICInductiveInversion.Construct_Ind_ind_eq' in hty as [mdecl [idecl [cdecl [declc _]]]] => //=. + eapply PCUICInductiveInversion.Construct_Ind_ind_eq' in hty as [mdecl [idecl [cdecl [declc [hcstr _]]]]] => //=. + destruct hcstr as [_ hcstr]. set (v := E.mkApps _ _). - eapply (erase_global_declared_constructor _ _ _ _ _ _ _ (term_global_deps v) decls normalization_in prf) in declc; tea. + pose proof declc as declc'. + eapply (erase_global_declared_constructor _ _ _ _ _ _ _ (term_global_deps v) decls normalization_in prf _ Hg) in declc; tea. destruct declc as [[hm hi] hc]. 2:{ rewrite /v /= term_global_deps_mkApps. destruct i => /=. eapply KernameSet.union_spec; left. now eapply KernameSet.singleton_spec. } 2:{ eapply Hwf. } econstructor. - { rewrite /lookup_inductive_pars /lookup_minductive hm /= //. } + { rewrite /lookup_constructor_pars_args /lookup_constructor /lookup_inductive /lookup_minductive hm /= hi //= hc //. } eapply Forall_skipn. - clear -ih Hrel isp. + clear -ih Hwf Hrel isp hcstr declc'. { revert v. rewrite erase_terms_eq => v. eapply Forall_All in ih. assert (All @@ -2216,8 +2221,10 @@ Proof. erewrite (erase_irrel _ _).1; tea. } eapply All_Forall, All_map_All. { intros. exact X0. } - cbn. intros x y rx h. apply h. exact Hrel. } } - { eapply subject_reduction; eauto. } + cbn. intros x y rx h. apply h. exact Hrel. } + rewrite erase_terms_eq map_All_length. cbn. + clear -wt' Hwf declc' Hrel hcstr. specialize (wt' _ Hrel). + now rewrite -(declared_constructor_arity declc'). } { eapply PCUICWcbvEval.value_final. eapply PCUICWcbvEval.eval_to_value. eauto. } all: eauto. Unshelve. eauto. diff --git a/erasure/theories/Typed/Erasure.v b/erasure/theories/Typed/Erasure.v index 4e1e9640e..8092b1566 100644 --- a/erasure/theories/Typed/Erasure.v +++ b/erasure/theories/Typed/Erasure.v @@ -572,8 +572,6 @@ Record type_flag {Σ Γ T} := Global Arguments type_flag : clear implicits. -Import PCUICSN. - Hint Resolve abstract_env_wf : erase. Definition isTT Γ T := diff --git a/erasure/theories/Typed/Extraction.v b/erasure/theories/Typed/Extraction.v index 2e7c75a9d..9ff35f659 100644 --- a/erasure/theories/Typed/Extraction.v +++ b/erasure/theories/Typed/Extraction.v @@ -185,7 +185,7 @@ Definition get_projections (env : ExAst.global_env) : list (ident * ExAst.one_in | [oib] => match oib.(ExAst.ind_ctors), oib.(ExAst.ind_projs) with (* case 1-ind with primitive projections *) - | [ctor],_::_ => map (fun '(na, _) => (na, oib)) oib.(ExAst.ind_projs) + | [_],_::_ => map (fun '(na, _) => (na, oib)) oib.(ExAst.ind_projs) (* case 1-ind without primitive projections *) | [(_,ctor_args,_)],[] => (* let is_named '(nm,_) := match nm with nNamed _ => true | _ => false end in *) From a0dc628f1b4566c2b36dda823ee4f73ab164dff5 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 13 Sep 2023 11:31:59 +0200 Subject: [PATCH 56/65] Fix erasure plugin compilation --- erasure-plugin/_PluginProject.in | 2 ++ erasure-plugin/src/metacoq_erasure_plugin.mlpack | 1 + 2 files changed, 3 insertions(+) diff --git a/erasure-plugin/_PluginProject.in b/erasure-plugin/_PluginProject.in index 1b344fb8a..dc5b48e22 100644 --- a/erasure-plugin/_PluginProject.in +++ b/erasure-plugin/_PluginProject.in @@ -79,6 +79,8 @@ src/eRemoveParams.ml src/erasureFunction.mli src/erasureFunction.ml +src/erasureFunctionProperties.mli +src/erasureFunctionProperties.ml src/ePretty.mli src/ePretty.ml src/eOptimizePropDiscr.mli diff --git a/erasure-plugin/src/metacoq_erasure_plugin.mlpack b/erasure-plugin/src/metacoq_erasure_plugin.mlpack index 662a2d49a..29a6ec0d0 100644 --- a/erasure-plugin/src/metacoq_erasure_plugin.mlpack +++ b/erasure-plugin/src/metacoq_erasure_plugin.mlpack @@ -54,6 +54,7 @@ Extract EEtaExpanded ERemoveParams ErasureFunction +ErasureFunctionProperties EOptimizePropDiscr EInlineProjections EConstructorsAsBlocks From 487cdf52b8d8edbc76a5fa3133bb141fae0dbedc Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 15 Sep 2023 14:12:38 +0200 Subject: [PATCH 57/65] Cleanup --- erasure-plugin/theories/ErasureCorrectness.v | 29 ++------------------ 1 file changed, 3 insertions(+), 26 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index bcf1c9600..5a2e5ed3e 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -9,8 +9,6 @@ From MetaCoq Require Import ETransform EConstructorsAsBlocks. From MetaCoq.Erasure Require Import EWcbvEvalNamed ErasureFunction ErasureFunctionProperties. From MetaCoq.ErasurePlugin Require Import Erasure. Import PCUICProgram. -(* Import TemplateProgram (template_eta_expand). - *) Import PCUICTransform (template_to_pcuic_transform, pcuic_expand_lets_transform). (* This is the total erasure function + @@ -300,16 +298,6 @@ Import EWcbvEval. Arguments erase_global_deps _ _ _ _ _ : clear implicits. Arguments erase_global_deps_fast _ _ _ _ _ _ : clear implicits. -(*Lemma erase_pcuic_program_spec {guard : abstract_guard_impl} - (p : pcuic_program) - (nin : (wf_ext p.1 -> PCUICSN.NormalizationIn p.1)) - (nin' : (wf_ext p.1 -> PCUICWeakeningEnvSN.normalizationInAdjustUniversesIn p.1)) - (wfext : ∥ wf_ext p.1 ∥) - (wt : ∥ ∑ T : PCUICAst.term, p.1;;; [] |- p.2 : T ∥) : - erase_pcuic_program p nin nin'wfext wt = - let et' := @erase optimized_abstract_env_impl - @erase_global_deps optimized_abstract_env_impl*) - Section PCUICProof. Import PCUICAst.PCUICEnvironment. @@ -442,15 +430,6 @@ Proof. eapply erase_transform_fo_gen; tea. reflexivity. Qed. - -(* Import PCUICAst. - -Lemma compile_fo_value (Σ : global_env_ext) Σ' t : - PCUICFirstorder.firstorder_value Σ [] t -> - erases_global - firstorder_evalue Σ (compile_value_erase t []). -Proof. Admitted. *) - Import MetaCoq.Common.Transform. From Coq Require Import Morphisms. @@ -1027,14 +1006,13 @@ Section pipeline_theorem. Variable fo : @PCUICFirstorder.firstorder_ind Σ (PCUICFirstorder.firstorder_env Σ) i. - Variable Normalisation : PCUICSN.NormalizationIn Σ. + Variable Normalisation : (forall Σ, wf_ext Σ -> PCUICSN.NormalizationIn Σ). Lemma precond : pre verified_erasure_pipeline (Σ, t). Proof. hnf. repeat eapply conj; sq; cbn; eauto. - red. cbn. eauto. - - todo "normalization". - - todo "normalization". + - intros. red. intros. now eapply Normalisation. Qed. Variable Heval : ∥PCUICWcbvEval.eval Σ t v∥. @@ -1048,8 +1026,7 @@ Section pipeline_theorem. - eapply (PCUICClassification.wcbveval_red (Σ := Σ)) in X; tea. eapply PCUICEtaExpand.expanded_red in X; tea. apply HΣ. intros ? ?; rewrite nth_error_nil => //. - - cbn. todo "normalization". - - todo "normalization". + - cbn. intros wf ? ? ? ? ? ?. now eapply Normalisation. Qed. Let Σ_t := (transform verified_erasure_pipeline (Σ, t) precond).1. From dfb03d1f3dd68613fc123c50683e25027b078594 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 2 Oct 2023 13:34:43 +0200 Subject: [PATCH 58/65] Minor fixes --- common/theories/Transform.v | 22 ++++++++-------- erasure-plugin/Makefile.plugin.local | 1 + erasure-plugin/theories/ETransform.v | 18 ++++++------- erasure-plugin/theories/Erasure.v | 16 ++++++------ erasure-plugin/theories/ErasureCorrectness.v | 27 ++++++++++---------- erasure/theories/EProgram.v | 20 ++++++++------- pcuic/Makefile.plugin.local | 2 ++ pcuic/theories/PCUICEtaExpand.v | 2 +- safechecker-plugin/Makefile.plugin.local | 1 + template-coq/Makefile.plugin.local | 6 +++-- template-coq/theories/TemplateProgram.v | 2 +- template-pcuic/theories/PCUICTransform.v | 2 +- 12 files changed, 64 insertions(+), 55 deletions(-) diff --git a/common/theories/Transform.v b/common/theories/Transform.v index d1678fb27..55785e023 100644 --- a/common/theories/Transform.v +++ b/common/theories/Transform.v @@ -23,13 +23,14 @@ Module Transform. Section Opt. Context {env env' : Type}. Context {term term' : Type}. + Context {value value' : Type}. Notation program' := (program env' term'). Notation program := (program env term). - Context {eval : program -> term -> Prop}. - Context {eval' : program' -> term' -> Prop}. + Context {eval : program -> value -> Prop}. + Context {eval' : program' -> value' -> Prop}. Definition preserves_eval pre (transform : forall p : program, pre p -> program') - (obseq : forall p : program, pre p -> program' -> term -> term' -> Prop) := + (obseq : forall p : program, pre p -> program' -> value -> value' -> Prop) := forall p v (pr : pre p), eval p v -> let p' := transform p pr in @@ -41,7 +42,7 @@ Module Transform. transform : forall p : program, pre p -> program'; post : program' -> Prop; correctness : forall input (p : pre input), post (transform input p); - obseq : forall p : program, pre p -> program' -> term -> term' -> Prop; + obseq : forall p : program, pre p -> program' -> value -> value' -> Prop; preservation : preserves_eval pre transform obseq }. Definition run (x : t) (p : program) (pr : pre x p) : program' := @@ -50,19 +51,20 @@ Module Transform. End Opt. Arguments t : clear implicits. - Definition self_transform env term eval eval' := t env env term term eval eval'. + Definition self_transform env term eval eval' := t env env term term term term eval eval'. Section Comp. Context {env env' env'' : Type}. Context {term term' term'' : Type}. - Context {eval : program env term -> term -> Prop}. - Context {eval' : program env' term' -> term' -> Prop}. - Context {eval'' : program env'' term'' -> term'' -> Prop}. + Context {value value' value'' : Type}. + Context {eval : program env term -> value -> Prop}. + Context {eval' : program env' term' -> value' -> Prop}. + Context {eval'' : program env'' term'' -> value'' -> Prop}. Local Obligation Tactic := idtac. - Program Definition compose (o : t env env' term term' eval eval') (o' : t env' env'' term' term'' eval' eval'') + Program Definition compose (o : t env env' term term' _ _ eval eval') (o' : t env' env'' term' term'' _ _ eval' eval'') (hpp : (forall p, o.(post) p -> o'.(pre) p)) - : t env env'' term term'' eval eval'' := + : t env env'' term term'' _ _ eval eval'' := {| name := (o.(name) ^ " -> " ^ o'.(name))%bs; transform p hp := run o' (run o p hp) (hpp _ (o.(correctness) _ hp)); diff --git a/erasure-plugin/Makefile.plugin.local b/erasure-plugin/Makefile.plugin.local index 2514f50e5..62cfbc2d2 100644 --- a/erasure-plugin/Makefile.plugin.local +++ b/erasure-plugin/Makefile.plugin.local @@ -1,3 +1,4 @@ +CAMLFLAGS :=-thread -bin-annot -strict-sequence -w -a+1..3-4+5..8-9+10..26-27+28..39-40-41-42+43-44-45+46..47-48+49..57-58+59..66-67-68+69-70 CAMLFLAGS+=-open Metacoq_template_plugin CAMLFLAGS+=-w -8 # Non-exhaustive matches due to translation of comparison to int CAMLFLAGS+=-w -20 # Unused arguments diff --git a/erasure-plugin/theories/ETransform.v b/erasure-plugin/theories/ETransform.v index f108396d6..fe2ab20b3 100644 --- a/erasure-plugin/theories/ETransform.v +++ b/erasure-plugin/theories/ETransform.v @@ -195,7 +195,7 @@ Qed. Local Obligation Tactic := try solve [ eauto ]. -Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t _ _ PCUICAst.term EAst.term +Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t _ _ PCUICAst.term EAst.term PCUICAst.term EAst.term eval_pcuic_program (eval_eprogram_env EWcbvEval.default_wcbv_flags) := {| name := "erasure"; pre p := @@ -327,7 +327,7 @@ End PCUICEnv. Import EWcbvEval (WcbvFlags, with_prop_case, with_guarded_fix). Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) : - Transform.t _ _ EAst.term EAst.term + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram_env fl) (eval_eprogram_env (EWcbvEval.switch_unguarded_fix fl)) := {| name := "switching to unguarded fixpoints"; transform p pre := p; @@ -356,7 +356,7 @@ Definition rebuild_wf_env {efl} (p : eprogram) (hwf : wf_eprogram efl p): eprogr (GlobalContextMap.make p.1 (wf_glob_fresh p.1 (proj1 hwf)), p.2). Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} (with_exp : bool) : - Transform.t _ _ EAst.term EAst.term (eval_eprogram fl) (eval_eprogram_env fl) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram fl) (eval_eprogram_env fl) := {| name := "rebuilding environment lookup table"; pre p := wf_eprogram efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_cstrs p); transform p pre := rebuild_wf_env p (proj1 pre); @@ -378,7 +378,7 @@ Qed. Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags): - Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters"; transform p pre := ERemoveParams.strip_program p; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -414,7 +414,7 @@ Qed. Program Definition remove_params_fast_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags) : - Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters (faster?)"; transform p _ := (ERemoveParams.Fast.strip_env p.1, ERemoveParams.Fast.strip p.1 [] p.2); pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -456,7 +456,7 @@ Qed. Import EOptimizePropDiscr EWcbvEval. Program Definition remove_match_on_box_trans {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : - Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := {| name := "optimize_prop_discr"; transform p _ := remove_match_on_box_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -492,7 +492,7 @@ From MetaCoq.Erasure Require Import EInlineProjections. Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) {hastrel : has_tRel} {hastbox : has_tBox} : - Transform.t _ _ EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "primitive projection inlining"; transform p _ := EInlineProjections.optimize_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -528,7 +528,7 @@ From MetaCoq.Erasure Require Import EConstructorsAsBlocks. Program Definition constructors_as_blocks_transformation {efl : EEnvFlags} {has_app : has_tApp} {has_rel : has_tRel} {hasbox : has_tBox} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : - Transform.t _ _ EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := {| name := "transforming to constuctors as blocks"; transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; @@ -568,7 +568,7 @@ From MetaCoq.Erasure Require Import EImplementBox. Program Definition implement_box_transformation {efl : EEnvFlags} {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = true} : - Transform.t _ _ EAst.term EAst.term (eval_eprogram block_wcbv_flags) (eval_eprogram block_wcbv_flags) := + Transform.t _ _ EAst.term EAst.term _ _ (eval_eprogram block_wcbv_flags) (eval_eprogram block_wcbv_flags) := {| name := "transforming to constuctors as blocks"; transform p _ := EImplementBox.implement_box_program p ; pre p := wf_eprogram efl p ; diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index 175f9210f..f04c84f23 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -42,7 +42,7 @@ Axiom assume_preservation_template_program_env_expansion : (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) -Program Definition eta_expand K : Transform.t _ _ Ast.term Ast.term +Program Definition eta_expand K : Transform.t _ _ Ast.term Ast.term _ _ eval_template_program_env eval_template_program := {| name := "eta expand cstrs and fixpoints"; pre := fun p => ∥ wt_template_program_env p ∥ /\ K (eta_expand_global_env p.1) ; @@ -59,7 +59,7 @@ Next Obligation. Qed. Program Definition verified_lambdabox_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t _ _ EAst.term EAst.term + Transform.t _ _ EAst.term EAst.term _ _ (EProgram.eval_eprogram_env {| with_prop_case := true; with_guarded_fix := true; with_constructor_as_block := false |}) (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := (* Simulation of the guarded fixpoint rules with a single unguarded one: @@ -99,7 +99,7 @@ Qed. Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : Transform.t _ _ - PCUICAst.term EAst.term + PCUICAst.term EAst.term _ _ PCUICTransform.eval_pcuic_program (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := (* a bunch of nonsense for normalization preconditions *) @@ -117,10 +117,10 @@ Program Definition verified_erasure_pipeline {guard : abstract_guard_impl} (efl Import EGlobalEnv EWellformed. Definition transform_compose - {env env' env'' term term' term'' : Type} + {env env' env'' term term' term'' value value' value'' : Type} {eval eval' eval''} - (o : t env env' term term' eval eval') - (o' : t env' env'' term' term'' eval' eval'') + (o : t env env' term term' value value' eval eval') + (o' : t env' env'' term' term'' value' value'' eval' eval'') (pre : forall p, post o p -> pre o' p) : forall x p1, exists p3, transform (compose o o' pre) x p1 = transform o' (transform o x p1) p3. @@ -138,7 +138,7 @@ Qed. Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : Transform.t _ _ - Ast.term PCUICAst.term + Ast.term PCUICAst.term _ _ TemplateProgram.eval_template_program PCUICTransform.eval_pcuic_program := (* a bunch of nonsense for normalization preconditions *) @@ -159,7 +159,7 @@ Program Definition pre_erasure_pipeline {guard : abstract_guard_impl} (efl := EW Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : Transform.t _ _ - Ast.term EAst.term + Ast.term EAst.term _ _ TemplateProgram.eval_template_program (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := pre_erasure_pipeline ▷ diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index 5a2e5ed3e..d85c2cb9a 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -25,11 +25,11 @@ Import Transform. Import EWcbvEval. Lemma transform_compose_assoc - {env env' env'' env''' term term' term'' term''' : Type} + {env env' env'' env''' term term' term'' term''' value value' value'' value''' : Type} {eval eval' eval'' eval'''} - (o : t env env' term term' eval eval') - (o' : t env' env'' term' term'' eval' eval'') - (o'' : t env'' env''' term'' term''' eval'' eval''') + (o : t env env' term term' value value' eval eval') + (o' : t env' env'' term' term'' value' value'' eval' eval'') + (o'' : t env'' env''' term'' term''' value'' value''' eval'' eval''') (prec : forall p, post o p -> pre o' p) (prec' : forall p, post o' p -> pre o'' p) : forall x p1, @@ -43,11 +43,11 @@ Proof. Qed. Lemma obseq_compose_assoc - {env env' env'' env''' term term' term'' term''' : Type} + {env env' env'' env''' term term' term'' term''' value value' value'' value''' : Type} {eval eval' eval'' eval'''} - (o : t env env' term term' eval eval') - (o' : t env' env'' term' term'' eval' eval'') - (o'' : t env'' env''' term'' term''' eval'' eval''') + (o : t env env' term term' value value' eval eval') + (o' : t env' env'' term' term'' value' value'' eval' eval'') + (o'' : t env'' env''' term'' term''' value'' value''' eval'' eval''') (prec : forall p, post o p -> pre o' p) (prec' : forall p, post o' p -> pre o'' p) : forall x p1 p2 v1 v2, obseq (compose o (compose o' o'' prec') prec) x p1 p2 v1 v2 <-> @@ -438,7 +438,7 @@ Module ETransformPresFO. Context {env env' : Type}. Context {eval : program env EAst.term -> EAst.term -> Prop}. Context {eval' : program env' EAst.term -> EAst.term -> Prop}. - Context (o : Transform.t _ _ _ _ eval eval'). + Context (o : Transform.t _ _ _ _ _ _ eval eval'). Context (firstorder_value : program env EAst.term -> Prop). Context (firstorder_value' : program env' EAst.term -> Prop). Context (compile_fo_value : forall p : program env EAst.term, o.(pre) p -> @@ -453,7 +453,7 @@ Module ETransformPresFO. Context {env env' : Type}. Context {eval : program env EAst.term -> EAst.term -> Prop}. Context {eval' : program env' EAst.term -> EAst.term -> Prop}. - Context (o : Transform.t _ _ _ _ eval eval'). + Context (o : Transform.t _ _ _ _ _ _ eval eval'). Context (firstorder_value : program env EAst.term -> Prop). Context (firstorder_value' : program env' EAst.term -> Prop). @@ -478,7 +478,7 @@ Module ETransformPresFO. Context (firstorder_value : program env EAst.term -> Prop). Context (firstorder_value' : program env' EAst.term -> Prop). Context (firstorder_value'' : program env'' EAst.term -> Prop). - Context (o : Transform.t _ _ _ _ eval eval') (o' : Transform.t _ _ _ _ eval' eval''). + Context (o : Transform.t _ _ _ _ _ _ eval eval') (o' : Transform.t _ _ _ _ _ _ eval' eval''). Context compile_fo_value compile_fo_value' (oext : t o firstorder_value firstorder_value' compile_fo_value) (o'ext : t o' firstorder_value' firstorder_value'' compile_fo_value') @@ -909,9 +909,8 @@ Section PCUICExpandLets. Proof. rewrite /PCUICFirstorder.firstorder_type /PCUICFirstorder.firstorder_env. pose proof (trans_decompose_app t). - destruct decompose_app. rewrite H. cbn. - destruct t0 => //. intros hd => /=. - destruct ind. + destruct decompose_app. rewrite {}H. cbn. + case: t0 => //; case => /= kn _ _ hd. destruct plookup_env eqn:hp => //. destruct b => //. eapply hd in hp. rewrite hp //. diff --git a/erasure/theories/EProgram.v b/erasure/theories/EProgram.v index 15cfe1e16..f069d6c25 100644 --- a/erasure/theories/EProgram.v +++ b/erasure/theories/EProgram.v @@ -55,10 +55,11 @@ Module TransformExt. Section Opt. Context {env env' env'' : Type}. Context {term term' term'' : Type}. - Context {eval : program env term -> term -> Prop}. - Context {eval' : program env' term' -> term' -> Prop}. - Context {eval'' : program env'' term'' -> term'' -> Prop}. - Context (o : Transform.t env env' term term' eval eval'). + Context {value value' value'' : Type}. + Context {eval : program env term -> value -> Prop}. + Context {eval' : program env' term' -> value' -> Prop}. + Context {eval'' : program env'' term'' -> value'' -> Prop}. + Context (o : Transform.t env env' term term' value value' eval eval'). Context (extends : program env term -> program env term -> Prop). Context (extends' : program env' term' -> program env' term' -> Prop). @@ -70,17 +71,18 @@ Module TransformExt. Section Comp. Context {env env' env'' : Type}. Context {term term' term'' : Type}. - Context {eval : program env term -> term -> Prop}. - Context {eval' : program env' term' -> term' -> Prop}. - Context {eval'' : program env'' term'' -> term'' -> Prop}. + Context {value value' value'' : Type}. + Context {eval : program env term -> value -> Prop}. + Context {eval' : program env' term' -> value' -> Prop}. + Context {eval'' : program env'' term'' -> value'' -> Prop}. Context {extends : program env term -> program env term -> Prop}. Context {extends' : program env' term' -> program env' term' -> Prop}. Context {extends'' : program env'' term'' -> program env'' term'' -> Prop}. Local Obligation Tactic := idtac. #[global] - Instance compose (o : Transform.t env env' term term' eval eval') - (o' : Transform.t env' env'' term' term'' eval' eval'') + Instance compose (o : Transform.t env env' term term' value value' eval eval') + (o' : Transform.t env' env'' term' term'' value' value'' eval' eval'') (oext : t o extends extends') (o'ext : t o' extends' extends'') (hpp : (forall p, o.(post) p -> o'.(pre) p)) diff --git a/pcuic/Makefile.plugin.local b/pcuic/Makefile.plugin.local index f8a95036e..e30465def 100644 --- a/pcuic/Makefile.plugin.local +++ b/pcuic/Makefile.plugin.local @@ -1,2 +1,4 @@ + +CAMLFLAGS :=-thread -bin-annot -strict-sequence -w -a+1..3-4+5..8-9+10..26-27+28..39-40-41-42+43-44-45+46..47-48+49..57-58+59..66-67-68+69-70 CAMLFLAGS+=-open Metacoq_template_plugin -open Metacoq_checker_plugin CAMLFLAGS+=-w -33 # Unused opens diff --git a/pcuic/theories/PCUICEtaExpand.v b/pcuic/theories/PCUICEtaExpand.v index 2b097e2e1..ef7fca054 100644 --- a/pcuic/theories/PCUICEtaExpand.v +++ b/pcuic/theories/PCUICEtaExpand.v @@ -5,7 +5,7 @@ From MetaCoq.Common Require Import config. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICReduction PCUICProgram PCUICLiftSubst PCUICCSubst PCUICUnivSubst. -(* todo move *) +(* move *) Lemma All_fold_tip {A : Type} (P : list A -> A -> Type) {x} : All_fold P [x] -> P [] x. Proof. intros a; now depelim a. diff --git a/safechecker-plugin/Makefile.plugin.local b/safechecker-plugin/Makefile.plugin.local index 2514f50e5..62cfbc2d2 100644 --- a/safechecker-plugin/Makefile.plugin.local +++ b/safechecker-plugin/Makefile.plugin.local @@ -1,3 +1,4 @@ +CAMLFLAGS :=-thread -bin-annot -strict-sequence -w -a+1..3-4+5..8-9+10..26-27+28..39-40-41-42+43-44-45+46..47-48+49..57-58+59..66-67-68+69-70 CAMLFLAGS+=-open Metacoq_template_plugin CAMLFLAGS+=-w -8 # Non-exhaustive matches due to translation of comparison to int CAMLFLAGS+=-w -20 # Unused arguments diff --git a/template-coq/Makefile.plugin.local b/template-coq/Makefile.plugin.local index 3d1b9c40a..f52f9c737 100644 --- a/template-coq/Makefile.plugin.local +++ b/template-coq/Makefile.plugin.local @@ -1,3 +1,7 @@ +CAMLPKGS+=-package stdlib-shims +INSTALLDEFAULTROOT=MetaCoq/Template + +CAMLFLAGS :=-thread -bin-annot -strict-sequence -w -a+1..3-4+5..8-9+10..26-27+28..39-40-41-42+43-44-45+46..47-48+49..57-58+59..66-67-68+69-70 CAMLFLAGS+=-w -20 # Unused argument (produced by extraction) CAMLFLAGS+=-w -33 # Unused opens CAMLFLAGS+=-w -32 # Unused value @@ -7,7 +11,5 @@ CAMLFLAGS+=-w -34 # Unused type CAMLFLAGS+=-w -60 # Unused module # CAMLFLAGS+=-w -8 # Non-exhaustive pattern-matchings (BEWARE, just for extracted code) CAMLFLAGS+=-bin-annot # For merlin -CAMLPKGS+=-package stdlib-shims -INSTALLDEFAULTROOT=MetaCoq/Template .PHONY: META \ No newline at end of file diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v index 6db0926ba..482e5ed03 100644 --- a/template-coq/theories/TemplateProgram.v +++ b/template-coq/theories/TemplateProgram.v @@ -47,7 +47,7 @@ Definition make_template_program_env {cf : checker_flags} (p : template_program) (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) Program Definition build_template_program_env {cf : checker_flags} K : - Transform.t global_env GlobalEnvMap.t Ast.term Ast.term eval_template_program eval_template_program_env := + Transform.t global_env GlobalEnvMap.t Ast.term Ast.term Ast.term Ast.term eval_template_program eval_template_program_env := {| name := "rebuilding environment lookup table"; pre p := ∥ wt_template_program p ∥ /\ forall pf, K (GlobalEnvMap.make p.1 (wt_template_program_fresh p pf)) : Prop ; transform p pre := make_template_program_env p (proj1 pre); diff --git a/template-pcuic/theories/PCUICTransform.v b/template-pcuic/theories/PCUICTransform.v index ef840ddaf..8bafdc8c5 100644 --- a/template-pcuic/theories/PCUICTransform.v +++ b/template-pcuic/theories/PCUICTransform.v @@ -34,7 +34,7 @@ Local Obligation Tactic := idtac. (** We kludge the normalization assumptions by parameterizing over a continuation of "what will be done to the program later" as well as what properties we'll need of it *) Program Definition template_to_pcuic_transform {cf : checker_flags} K : - Transform.t Ast.Env.global_env global_env_ext_map Ast.term term + Transform.t Ast.Env.global_env global_env_ext_map Ast.term term Ast.term term eval_template_program eval_pcuic_program := {| name := "template to pcuic"; pre p := ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p /\ K (trans_global (Ast.Env.empty_ext p.1)) ; From efe2b96dd74cdbcc09c652dd8eaae41e6814cbcb Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Mon, 2 Oct 2023 15:21:59 +0200 Subject: [PATCH 59/65] fix CI --- .github/workflows/build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 835fbadb1..d6e97c50c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -50,12 +50,12 @@ jobs: startGroup "Workaround permission issue" sudo chown -R coq:coq . # <-- opam exec -- ocamlfind list - opam pin coq-equations.1.3 "https://github.com/mattam82/Coq-Equations.git#8.18" endGroup before_install: | startGroup "Print opam config" sudo chown -R coq:coq . opam config list; opam repo list; opam list + opam pin -y coq-equations.1.3 "https://github.com/mattam82/Coq-Equations.git#8.18" endGroup script: | startGroup "Build project" From f2b1cc0783dd745d9dd52e562bac30221599dd63 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 3 Oct 2023 10:30:52 +0200 Subject: [PATCH 60/65] Fix after rebase --- erasure-plugin/theories/ErasureCorrectness.v | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/erasure-plugin/theories/ErasureCorrectness.v b/erasure-plugin/theories/ErasureCorrectness.v index d85c2cb9a..dea582694 100644 --- a/erasure-plugin/theories/ErasureCorrectness.v +++ b/erasure-plugin/theories/ErasureCorrectness.v @@ -910,10 +910,12 @@ Section PCUICExpandLets. rewrite /PCUICFirstorder.firstorder_type /PCUICFirstorder.firstorder_env. pose proof (trans_decompose_app t). destruct decompose_app. rewrite {}H. cbn. - case: t0 => //; case => /= kn _ _ hd. - destruct plookup_env eqn:hp => //. - destruct b => //. - eapply hd in hp. rewrite hp //. + case: t0 => //=. + - intros n' hn. destruct l => //. + - case => /= kn _ _ hd. destruct l => //. + destruct plookup_env eqn:hp => //. + destruct b => //. + eapply hd in hp. rewrite hp //. Qed. Lemma trans_firstorder_mutind Σ m : @@ -950,6 +952,7 @@ Section PCUICExpandLets. clear -he hd. move: hd. rewrite /firstorder_type. destruct (decompose_app decl_type) eqn:e. cbn. destruct t0 => //; apply decompose_app_inv in e; rewrite e. + destruct l => //. { move/andP => [] /Nat.leb_le hn /Nat.ltb_lt hn'. rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps decompose_app_mkApps //=. @@ -964,7 +967,8 @@ Section PCUICExpandLets. apply/andP; split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. } { rewrite trans_mkApps PCUICLiftSubst.lift_mkApps PCUICLiftSubst.subst_mkApps decompose_app_mkApps //=. - destruct ind. destruct plookup_env eqn:hp => //. destruct b => //. apply he in hp. rewrite hp //. } + destruct ind, l => //=. destruct plookup_env eqn:hp => //. + destruct b => //. apply he in hp. rewrite hp //. } Qed. Lemma trans_firstorder_env Σ : From 357e8a7ddd140f4396c18eb9bd95e822f9363d25 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 3 Oct 2023 11:27:01 +0200 Subject: [PATCH 61/65] Fix test suite --- test-suite/erasure_live_test.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test-suite/erasure_live_test.v b/test-suite/erasure_live_test.v index c619b7d5e..b3f89a2fb 100644 --- a/test-suite/erasure_live_test.v +++ b/test-suite/erasure_live_test.v @@ -323,8 +323,10 @@ Require Import Coq.Arith.Compare_dec. Require Import Coq.Arith.PeanoNat. Require Import Coq.Arith.Peano_dec. Require Import Arith Init.Wf. +Require Import Program. Program Fixpoint provedCopy (n:nat) {wf lt n} : nat := match n with 0 => 0 | S k => S (provedCopy k) end. + Print Assumptions provedCopy. (* MetaCoq Quote Recursively Definition pCopy := provedCopy. program *) From 1fcd7ffbc7ec19f2849aa92cc9874edee7d38828 Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Thu, 5 Oct 2023 10:38:01 +0200 Subject: [PATCH 62/65] coq-equations.1.3+8.18 --- .github/workflows/build.yml | 2 +- coq-metacoq-utils.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d6e97c50c..b6f3cf815 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -55,7 +55,7 @@ jobs: startGroup "Print opam config" sudo chown -R coq:coq . opam config list; opam repo list; opam list - opam pin -y coq-equations.1.3 "https://github.com/mattam82/Coq-Equations.git#8.18" + opam pin -y coq-equations.1.3+8.18 "https://github.com/mattam82/Coq-Equations.git#8.18" endGroup script: | startGroup "Build project" diff --git a/coq-metacoq-utils.opam b/coq-metacoq-utils.opam index 680c1ded6..3593a7aca 100644 --- a/coq-metacoq-utils.opam +++ b/coq-metacoq-utils.opam @@ -30,7 +30,7 @@ install: [ depends: [ "stdlib-shims" "coq" { >= "8.18" & < "8.19~" } - "coq-equations" { = "1.3" } + "coq-equations" { = "1.3+8.18" } ] synopsis: "The utility library of Template Coq and PCUIC" description: """ From 1dc79610c4994d1b0f03150bee2d6ea65617d321 Mon Sep 17 00:00:00 2001 From: nicolas tabareau Date: Tue, 10 Oct 2023 13:38:07 +0200 Subject: [PATCH 63/65] add not_isErasable lemma in EArities --- erasure/theories/EArities.v | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index 3b11eeb08..056133d5b 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -1031,3 +1031,24 @@ Proof. intros [Tty []] hred. exists Tty. split => //. eapply subject_reduction; tea. Qed. + +Lemma not_isErasable Σ Γ f A u : + wf_ext Σ -> wf_local Σ Γ -> + ∥Σ;;; Γ |- f : A∥ -> + (forall B, ∥Σ;;; Γ ⊢ A ⇝ B∥ -> A = B) -> + (forall B, ∥Σ ;;; Γ |- f : B∥ -> ∥Σ ;;; Γ ⊢ A ≤ B∥) -> + ~ ∥ isArity A ∥ -> + ∥ Σ;;; Γ |- A : tSort u ∥ -> + ~ is_propositional u -> + ~ ∥ Extract.isErasable Σ Γ f ∥. +Proof. + intros wfΣ Hlocal Hf Hnf Hprinc Harity Hfu Hu [[T [HT []]]]; sq. + - eapply Harity; sq. + eapply EArities.arity_type_inv in i as [T' [? ?]]; eauto. + eapply Hnf in H. subst; eauto. + - destruct s as [s [? ?]]. eapply Hu. + specialize (Hprinc _ (sq HT)). + pose proof (Hs := i). sq. + eapply PCUICElimination.unique_sorting_equality_propositional in Hprinc; eauto. + rewrite Hprinc; eauto. +Qed. From 34c831e73af5661e5b3ae2bd6c24cd056fd66eba Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Mon, 16 Oct 2023 11:01:24 +0200 Subject: [PATCH 64/65] fix Makefile --- Makefile | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 31e6a96fc..cae917e41 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: printconf template-coq pcuic safechecker erasure erasure-plugin +all: printconf template-coq pcuic safechecker erasure erasure-plugin -include Makefile.conf @@ -26,7 +26,7 @@ else endif endif -install: all translations +install: all $(MAKE) -C utils install $(MAKE) -C common install $(MAKE) -C template-coq install @@ -37,7 +37,6 @@ install: all translations $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install $(MAKE) -C erasure-plugin install - $(MAKE) -C translations install uninstall: $(MAKE) -C utils uninstall @@ -177,7 +176,7 @@ cleanplugins: ci-local-noclean: ./configure.sh local - $(MAKE) all test-suite TIMED=pretty-timed + $(MAKE) all translations test-suite TIMED=pretty-timed ci-local: ci-local-noclean $(MAKE) clean From 97911f233561cd7ad60f2d3f28af8a3c00ccf20b Mon Sep 17 00:00:00 2001 From: Yannick Forster Date: Mon, 16 Oct 2023 17:09:39 +0200 Subject: [PATCH 65/65] Remove nix --- .../workflows/nix-action-coq-dev-macos.yml | 187 ------------------ .../workflows/nix-action-coq-dev-ubuntu.yml | 187 ------------------ 2 files changed, 374 deletions(-) delete mode 100644 .github/workflows/nix-action-coq-dev-macos.yml delete mode 100644 .github/workflows/nix-action-coq-dev-ubuntu.yml diff --git a/.github/workflows/nix-action-coq-dev-macos.yml b/.github/workflows/nix-action-coq-dev-macos.yml deleted file mode 100644 index ed523bc63..000000000 --- a/.github/workflows/nix-action-coq-dev-macos.yml +++ /dev/null @@ -1,187 +0,0 @@ -jobs: - coq: - needs: [] - runs-on: macos-latest - concurrency: - group: ${{ github.workflow }}-MacOS-coq-${{ github.event_name }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - steps: - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ - \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ - \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ - \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ - \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ - \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v4 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v23 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup metacoq - uses: cachix/cachix-action@v12 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq, coq-community - name: metacoq - - id: stepCheck - name: Checking presence of CI target coq - run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ - \ bundle \"coq-dev\" --argstr job \"coq\" \\\n --dry-run 2>&1 > /dev/null)\n\ - echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ - \ \"built:\" | sed \"s/.*/built/\")\n" - - if: steps.stepCheck.outputs.status == 'built' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "coq" - equations: - needs: - - coq - runs-on: macos-latest - concurrency: - group: ${{ github.workflow }}-MacOS-equations-${{ github.event_name }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - steps: - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ - \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ - \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ - \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ - \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ - \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v4 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v23 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup metacoq - uses: cachix/cachix-action@v12 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq, coq-community - name: metacoq - - id: stepCheck - name: Checking presence of CI target equations - run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ - \ bundle \"coq-dev\" --argstr job \"equations\" \\\n --dry-run 2>&1 > /dev/null)\n\ - echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ - \ \"built:\" | sed \"s/.*/built/\")\n" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "coq" - - if: steps.stepCheck.outputs.status == 'built' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "equations" - metacoq: - needs: - - coq - - equations - runs-on: macos-latest - concurrency: - group: ${{ github.workflow }}-MacOS-metacoq-${{ github.event_name }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - steps: - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ - \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ - \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ - \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ - \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ - \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v4 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v23 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup metacoq - uses: cachix/cachix-action@v12 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq, coq-community - name: metacoq - - id: stepCheck - name: Checking presence of CI target metacoq - run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ - \ bundle \"coq-dev\" --argstr job \"metacoq\" \\\n --dry-run 2>&1 > /dev/null)\n\ - echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ - \ \"built:\" | sed \"s/.*/built/\")\n" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "coq" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: equations' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "equations" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-utils' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-utils" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-common' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-common" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-template-coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-template-coq" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-pcuic' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-pcuic" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-safechecker' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-safechecker" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-template-pcuic' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-template-pcuic" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-erasure' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-erasure" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-quotation' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-quotation" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-safechecker-plugin' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-safechecker-plugin" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-erasure-plugin' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-erasure-plugin" - - if: steps.stepCheck.outputs.status == 'built' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq" -name: Nix CI for bundle coq-dev -'on': - pull_request: - paths: - - .github/workflows/** - pull_request_target: - types: - - opened - - synchronize - - reopened - push: - branches: - - main - - coq-dev diff --git a/.github/workflows/nix-action-coq-dev-ubuntu.yml b/.github/workflows/nix-action-coq-dev-ubuntu.yml deleted file mode 100644 index 324b24726..000000000 --- a/.github/workflows/nix-action-coq-dev-ubuntu.yml +++ /dev/null @@ -1,187 +0,0 @@ -jobs: - coq: - needs: [] - runs-on: ubuntu-latest - concurrency: - group: ${{ github.workflow }}-Ubuntu-coq-${{ github.event_name }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - steps: - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ - \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ - \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ - \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ - \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ - \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v4 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v23 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup metacoq - uses: cachix/cachix-action@v12 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq, coq-community - name: metacoq - - id: stepCheck - name: Checking presence of CI target coq - run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ - \ bundle \"coq-dev\" --argstr job \"coq\" \\\n --dry-run 2>&1 > /dev/null)\n\ - echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ - \ \"built:\" | sed \"s/.*/built/\")\n" - - if: steps.stepCheck.outputs.status == 'built' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "coq" - equations: - needs: - - coq - runs-on: ubuntu-latest - concurrency: - group: ${{ github.workflow }}-Ubuntu-equations-${{ github.event_name }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - steps: - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ - \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ - \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ - \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ - \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ - \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v4 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v23 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup metacoq - uses: cachix/cachix-action@v12 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq, coq-community - name: metacoq - - id: stepCheck - name: Checking presence of CI target equations - run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ - \ bundle \"coq-dev\" --argstr job \"equations\" \\\n --dry-run 2>&1 > /dev/null)\n\ - echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ - \ \"built:\" | sed \"s/.*/built/\")\n" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "coq" - - if: steps.stepCheck.outputs.status == 'built' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "equations" - metacoq: - needs: - - coq - - equations - runs-on: ubuntu-latest - concurrency: - group: ${{ github.workflow }}-Ubuntu-metacoq-${{ github.event_name }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - steps: - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ - \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ - \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ - \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ - \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ - \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v4 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v23 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup metacoq - uses: cachix/cachix-action@v12 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq, coq-community - name: metacoq - - id: stepCheck - name: Checking presence of CI target metacoq - run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ - \ bundle \"coq-dev\" --argstr job \"metacoq\" \\\n --dry-run 2>&1 > /dev/null)\n\ - echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ - \ \"built:\" | sed \"s/.*/built/\")\n" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "coq" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: equations' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "equations" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-utils' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-utils" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-common' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-common" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-template-coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-template-coq" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-pcuic' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-pcuic" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-safechecker' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-safechecker" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-template-pcuic' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-template-pcuic" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-erasure' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-erasure" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-quotation' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-quotation" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-safechecker-plugin' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-safechecker-plugin" - - if: steps.stepCheck.outputs.status == 'built' - name: 'Building/fetching previous CI target: metacoq-erasure-plugin' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq-erasure-plugin" - - if: steps.stepCheck.outputs.status == 'built' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" - --argstr job "metacoq" -name: Nix CI for bundle coq-dev -'on': - pull_request: - paths: - - .github/workflows/** - pull_request_target: - types: - - opened - - synchronize - - reopened - push: - branches: - - main - - coq-dev