433 lines
10 KiB
Coq
433 lines
10 KiB
Coq
Require Import List.
|
|
Require Import MyList.
|
|
Require Import MyTactics.
|
|
Require Export Autosubst.Autosubst.
|
|
Require Export AutosubstExtra.
|
|
Require Export Autosubst_EOS.
|
|
Require Export Autosubst_FreeVars.
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* Metal is a lambda-calculus where every lambda-abstractions must be closed.
|
|
It is equipped with pairs and projections. It is intended to serve as the
|
|
target of closure conversion. *)
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* Syntax. *)
|
|
|
|
Inductive metal :=
|
|
| MVar : var -> metal
|
|
| MLam : {bind metal} -> metal
|
|
| MApp : metal -> metal -> metal
|
|
| MLet : metal -> {bind metal} -> metal
|
|
| MPair : metal -> metal -> metal
|
|
| MPi : nat -> metal -> metal
|
|
.
|
|
|
|
Instance Ids_metal : Ids metal. derive. Defined.
|
|
Instance Rename_metal : Rename metal. derive. Defined.
|
|
Instance Subst_metal : Subst metal. derive. Defined.
|
|
Instance SubstLemmas_metal : SubstLemmas metal. derive. Qed.
|
|
|
|
Instance IdsLemmas_metal : IdsLemmas metal.
|
|
Proof. econstructor. intros. injections. eauto. Qed.
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* We equip the calculus with pairs, instead of general tuples, because
|
|
this makes life in Coq simpler -- we would otherwise have an occurrence
|
|
of [list metal] in the definition of [metal], and would need to ask for
|
|
a custom induction scheme. *)
|
|
|
|
(* Instead, we simulate tuples using nested pairs. This would of course be
|
|
inefficient in real life, but fur our purposes, should be fine. *)
|
|
|
|
Fixpoint MTuple ts :=
|
|
match ts with
|
|
| nil =>
|
|
(* A dummy value serves as the tail. *)
|
|
MLam (MVar 0)
|
|
| t :: ts =>
|
|
MPair t (MTuple ts)
|
|
end.
|
|
|
|
Fixpoint MProj i t :=
|
|
match i with
|
|
| 0 =>
|
|
(* Take the left pair component. *)
|
|
MPi 0 t
|
|
| S i =>
|
|
(* Take the right pair component and continue. *)
|
|
MProj i (MPi 1 t)
|
|
end.
|
|
|
|
Definition MLetPair t u :=
|
|
MLet (* x_0 = *) (MPi 0 t) (
|
|
MLet (* x_1 = *) (MPi 1 (lift 1 t))
|
|
u
|
|
).
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* [MMultiLet 0 ts u] is a sequence of [MLet] bindings. [n] variables, where
|
|
[n] is [length ts], are bound to the terms [ts] in the term [u]. The
|
|
recursive structure of the definition is such that the *last* term in the
|
|
list [ts] is bound *last*, hence is referred to as variable 0 in [u]. *)
|
|
|
|
Fixpoint MMultiLet i ts u :=
|
|
match ts with
|
|
| nil =>
|
|
u
|
|
| t :: ts =>
|
|
MLet (lift i t) (MMultiLet (i + 1) ts u)
|
|
end.
|
|
|
|
(* The auxiliary parameter [i] in [MMultiLet i ts u] is required for the
|
|
recursive definition to go through, but, as far as the end user is
|
|
concerned, is not very useful. It can be eliminated as follows. *)
|
|
|
|
Lemma MMultiLet_ij:
|
|
forall ts delta i j u,
|
|
i + delta = j ->
|
|
MMultiLet j ts u = MMultiLet i (map (fun t => lift delta t) ts) u.
|
|
Proof.
|
|
induction ts; intros; simpl; eauto.
|
|
f_equal.
|
|
{ asimpl. congruence. }
|
|
{ erewrite IHts. eauto. omega. }
|
|
Qed.
|
|
|
|
Lemma MMultiLet_i0:
|
|
forall i ts u,
|
|
MMultiLet i ts u = MMultiLet 0 (map (fun t => lift i t) ts) u.
|
|
Proof.
|
|
eauto using MMultiLet_ij with omega.
|
|
Qed.
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* [MVars n] is the list [MVar 0, ..., MVar (n-1)]. *)
|
|
|
|
Definition MVars (n : nat) : list metal :=
|
|
map MVar (nats n).
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* [MProjs n t] is the list [MProj n t, ..., MProj 1 t]. *)
|
|
|
|
Definition MProjs (n : nat) (t : metal) :=
|
|
map (fun i => MProj (i + 1) t) (rev_nats n).
|
|
|
|
(* This list has length [n]. *)
|
|
|
|
Lemma length_MProjs:
|
|
forall n t,
|
|
length (MProjs n t) = n.
|
|
Proof.
|
|
unfold MProjs. intros. rewrite map_length, length_rev_nats. eauto.
|
|
Qed.
|
|
|
|
Hint Rewrite length_MProjs : length.
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* Substitution (boilerplate lemmas). *)
|
|
|
|
Lemma subst_MVar:
|
|
forall x sigma,
|
|
(MVar x).[sigma] = sigma x.
|
|
Proof.
|
|
intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MLam:
|
|
forall t sigma,
|
|
(MLam t).[sigma] = MLam t.[up sigma].
|
|
Proof.
|
|
intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MApp:
|
|
forall t1 t2 sigma,
|
|
(MApp t1 t2).[sigma] = MApp t1.[sigma] t2.[sigma].
|
|
Proof.
|
|
intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MLet:
|
|
forall t1 t2 sigma,
|
|
(MLet t1 t2).[sigma] = MLet t1.[sigma] t2.[up sigma].
|
|
Proof.
|
|
intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MPair:
|
|
forall t1 t2 sigma,
|
|
(MPair t1 t2).[sigma] = MPair t1.[sigma] t2.[sigma].
|
|
Proof.
|
|
intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MPi:
|
|
forall i t sigma,
|
|
(MPi i t).[sigma] = MPi i t.[sigma].
|
|
Proof.
|
|
intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MTuple:
|
|
forall ts sigma,
|
|
(MTuple ts).[sigma] = MTuple (map (subst sigma) ts).
|
|
Proof.
|
|
induction ts; intros; asimpl; [ | rewrite IHts ]; reflexivity.
|
|
Qed.
|
|
|
|
Lemma subst_MProj:
|
|
forall n t sigma,
|
|
(MProj n t).[sigma] = MProj n t.[sigma].
|
|
Proof.
|
|
induction n; intros; asimpl; [ | rewrite IHn ]; autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MLetPair:
|
|
forall t u sigma,
|
|
(MLetPair t u).[sigma] = MLetPair t.[sigma] u.[upn 2 sigma].
|
|
Proof.
|
|
unfold MLetPair. intros. autosubst.
|
|
Qed.
|
|
|
|
Lemma subst_MMultiLet:
|
|
forall ts i u sigma,
|
|
(MMultiLet i ts u).[upn i sigma] =
|
|
MMultiLet i (map (subst sigma) ts) u.[upn (length ts) (upn i sigma)].
|
|
Proof.
|
|
induction ts; intros; asimpl; f_equal.
|
|
{ erewrite plus_upn by tc. eauto. }
|
|
{ rewrite IHts.
|
|
repeat erewrite upn_upn by tc.
|
|
do 3 f_equal. omega. }
|
|
Qed.
|
|
|
|
Lemma subst_MMultiLet_0:
|
|
forall ts u sigma,
|
|
(MMultiLet 0 ts u).[sigma] =
|
|
MMultiLet 0 (map (subst sigma) ts) u.[upn (length ts) sigma].
|
|
Proof.
|
|
intros.
|
|
change sigma with (upn 0 sigma) at 1.
|
|
eapply subst_MMultiLet.
|
|
Qed.
|
|
|
|
Lemma subst_MVars:
|
|
forall n sigma,
|
|
map (subst sigma) (MVars n) = map sigma (nats n).
|
|
Proof.
|
|
intros. unfold MVars. rewrite map_map. reflexivity.
|
|
Qed.
|
|
|
|
Lemma subst_MProjs:
|
|
forall n t sigma,
|
|
map (subst sigma) (MProjs n t) = MProjs n t.[sigma].
|
|
Proof.
|
|
unfold MProjs. induction n; intros; simpl; eauto.
|
|
rewrite subst_MProj, IHn. eauto.
|
|
Qed.
|
|
|
|
Hint Rewrite
|
|
subst_MVar subst_MLam subst_MApp subst_MLet subst_MPair subst_MPi
|
|
subst_MTuple subst_MProj subst_MLetPair
|
|
subst_MMultiLet subst_MMultiLet_0
|
|
subst_MVars subst_MProjs
|
|
: subst.
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* Free variables (boilerplate lemmas). *)
|
|
|
|
Lemma fv_MVar:
|
|
forall x k,
|
|
fv k (MVar x) <-> x < k.
|
|
Proof.
|
|
eauto using fv_ids_eq.
|
|
Qed.
|
|
|
|
Ltac prove_fv :=
|
|
unfold fv; intros; asimpl;
|
|
split; intros; unpack; [ injections | f_equal ]; eauto.
|
|
|
|
Lemma fv_MLam:
|
|
forall t k,
|
|
fv k (MLam t) <-> fv (k + 1) t.
|
|
Proof.
|
|
prove_fv.
|
|
Qed.
|
|
|
|
Lemma fv_MApp:
|
|
forall t1 t2 k,
|
|
fv k (MApp t1 t2) <-> fv k t1 /\ fv k t2.
|
|
Proof.
|
|
prove_fv.
|
|
Qed.
|
|
|
|
Lemma fv_MLet:
|
|
forall t1 t2 k,
|
|
fv k (MLet t1 t2) <-> fv k t1 /\ fv (k + 1) t2.
|
|
Proof.
|
|
prove_fv.
|
|
Qed.
|
|
|
|
Lemma fv_MPair:
|
|
forall t1 t2 k,
|
|
fv k (MPair t1 t2) <-> fv k t1 /\ fv k t2.
|
|
Proof.
|
|
prove_fv.
|
|
Qed.
|
|
|
|
Lemma fv_MPi:
|
|
forall i t k,
|
|
fv k (MPi i t) <-> fv k t.
|
|
Proof.
|
|
prove_fv.
|
|
Qed.
|
|
|
|
Hint Rewrite fv_MVar fv_MLam fv_MApp fv_MLet fv_MPair fv_MPi : fv.
|
|
|
|
Lemma fv_MTuple:
|
|
forall k ts,
|
|
fv k (MTuple ts) <-> Forall (fv k) ts.
|
|
Proof.
|
|
induction ts; simpl; intros; fv; split; intros; unpack.
|
|
{ econstructor. }
|
|
{ omega. }
|
|
{ rewrite IHts in *. econstructor; eauto. }
|
|
{ rewrite IHts in *. pick Forall invert. eauto. }
|
|
Qed.
|
|
|
|
Lemma fv_MProj:
|
|
forall k n t,
|
|
fv k (MProj n t) <-> fv k t.
|
|
Proof.
|
|
induction n; intros; simpl; [ | rewrite IHn ]; fv; tauto.
|
|
Qed.
|
|
|
|
Lemma fv_MLetPair:
|
|
forall k t u,
|
|
fv k (MLetPair t u) <-> fv k t /\ fv (k + 2) u.
|
|
Proof.
|
|
intros. unfold MLetPair. fv; tc.
|
|
replace (k + 1 + 1) with (k + 2) by omega.
|
|
tauto.
|
|
Qed.
|
|
|
|
Local Lemma MLet_inj:
|
|
forall t1 u1 t2 u2,
|
|
MLet t1 u1 = MLet t2 u2 <-> t1 = t2 /\ u1 = u2.
|
|
Proof.
|
|
split; intros; injections; unpack; subst; eauto.
|
|
Qed.
|
|
|
|
Local Lemma cons_cons_eq:
|
|
forall {A} (x1 x2 : A) xs1 xs2,
|
|
x1 :: xs1 = x2 :: xs2 <->
|
|
x1 = x2 /\ xs1 = xs2.
|
|
Proof.
|
|
split; intros; injections; unpack; subst; eauto.
|
|
Qed.
|
|
|
|
Local Lemma MMultiLet_inj:
|
|
forall ts1 u1 ts2 u2 i,
|
|
length ts1 = length ts2 ->
|
|
MMultiLet i ts1 u1 = MMultiLet i ts2 u2 <->
|
|
ts1 = ts2 /\ u1 = u2.
|
|
Proof.
|
|
induction ts1; destruct ts2; intros; simpl;
|
|
try solve [ false; simpl in *; omega ].
|
|
{ tauto. }
|
|
{ rewrite MLet_inj.
|
|
rewrite lift_injn_eq.
|
|
rewrite IHts1 by (simpl in *; omega).
|
|
rewrite cons_cons_eq.
|
|
tauto. }
|
|
Qed.
|
|
|
|
Local Lemma map_inj:
|
|
forall {A} (f : A -> A) xs,
|
|
map f xs = xs <->
|
|
Forall (fun x => f x = x) xs.
|
|
Proof.
|
|
induction xs; simpl; intros; split; intros; eauto using Forall;
|
|
injections.
|
|
{ econstructor; tauto. }
|
|
{ pick Forall invert. f_equal; tauto. }
|
|
Qed.
|
|
|
|
Lemma fv_MMultiLet_0:
|
|
forall ts u k,
|
|
fv k (MMultiLet 0 ts u) <->
|
|
Forall (fv k) ts /\ fv (k + length ts) u.
|
|
Proof.
|
|
intros. unfold fv.
|
|
autorewrite with subst.
|
|
rewrite MMultiLet_inj by eauto using map_length.
|
|
rewrite upn_upn, Nat.add_comm.
|
|
rewrite map_inj.
|
|
tauto.
|
|
Qed.
|
|
|
|
Lemma fv_MVars:
|
|
forall n,
|
|
Forall (fv n) (MVars n) <->
|
|
True.
|
|
Proof.
|
|
split; [ eauto | intros _ ].
|
|
unfold MVars, nats.
|
|
eapply Forall_map.
|
|
eapply Forall_seq; intros.
|
|
fv. omega.
|
|
Qed.
|
|
|
|
Lemma fv_MProjs:
|
|
forall k n t,
|
|
fv k t -> (* not an equivalence, as [k] could be zero *)
|
|
Forall (fv k) (MProjs n t).
|
|
Proof.
|
|
unfold MProjs. induction n; simpl; intros;
|
|
econstructor; [ rewrite fv_MProj |]; eauto.
|
|
Qed.
|
|
|
|
Hint Rewrite
|
|
fv_MTuple fv_MProj fv_MLetPair fv_MMultiLet_0
|
|
fv_MVars
|
|
(* not fv_MProjs *)
|
|
: fv.
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* The following lemma is analogous to [fv_unaffected_regular], except it does
|
|
not have a regularity hypothesis, which makes it more pleasant to use. It is
|
|
proved by induction on terms, which is why we are unable to prove it in a
|
|
generic setting. *)
|
|
|
|
Lemma fv_unaffected:
|
|
forall t k sigma,
|
|
fv k t ->
|
|
t.[upn k sigma] = t.
|
|
Proof.
|
|
induction t; intros; fv; unpack; asimpl; repeat rewrite Nat.add_1_r in *;
|
|
try solve [ eauto using upn_k_sigma_x with typeclass_instances
|
|
| f_equal; eauto ].
|
|
Qed.
|
|
|
|
(* A corollary. *)
|
|
|
|
Lemma closed_unaffected:
|
|
forall t sigma,
|
|
closed t ->
|
|
t.[sigma] = t.
|
|
Proof.
|
|
unfold closed. intros.
|
|
rewrite <- (upn0 sigma).
|
|
eauto using fv_unaffected.
|
|
Qed.
|