Commit 55582283 by POTTIER Francois

Add the Coq formalization of the CPS transformation.

parent 79af3f8d
Require Import MyTactics.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusValues.
Require Import CPSDefinition.
(* This file contains a few lemmas about [substc]. *)
(* Two successive applications of [substc] can be fused. *)
Lemma substc_substc:
forall sigma1 sigma2 c,
substc sigma2 (substc sigma1 c) = substc (sigma1 >> sigma2) c.
Proof.
intros. destruct c; autosubst.
Qed.
(* Two successive applications of [liftc] can be fused. *)
Lemma liftc_liftc:
forall i j c,
liftc i (liftc j c) = liftc (i + j) c.
Proof.
intros i j c. destruct c; autosubst.
Qed.
(* [apply] commutes with substitutions. *)
Lemma apply_substitution:
forall c sigma c' v,
substc sigma c = c' ->
(apply c v).[sigma] = apply c' v.[sigma].
Proof.
intros. subst. destruct c; autosubst.
Qed.
(* [reify] commutes with substitutions. *)
Lemma reify_substitution:
forall c sigma c',
substc sigma c = c' ->
(reify c).[sigma] = reify c'.
Proof.
intros. subst. destruct c; reflexivity.
Qed.
(* As a special case, [reify] commutes with lifting. *)
Lemma lift_reify:
forall i c,
lift i (reify c) = reify (liftc i c).
Proof.
intros. destruct c; reflexivity.
Qed.
(* [substc] is preserved by [liftc]. *)
Lemma substc_liftc_liftc:
forall i c sigma c',
substc sigma c = c' ->
substc (upn i sigma) (liftc i c) = liftc i c'.
Proof.
intros. subst. destruct c; simpl.
{ rewrite lift_upn by tc. reflexivity. }
{ asimpl. erewrite plus_upn by tc. autosubst. }
Qed.
Hint Resolve substc_liftc_liftc : obvious.
(* As is the case for terms, lifting [c] by 1, then applying a substitution
of the form [v .: ids], yields [c] again. *)
Lemma substc_liftc_single:
forall c v,
substc (v .: ids) (liftc 1 c) = c.
Proof.
intros. destruct c; autosubst.
Qed.
Require Import MyTactics.
Require Import Sequences.
Require Import Relations.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusValues.
Require Import LambdaCalculusReduction.
Require Import LambdaCalculusStandardization.
Require Import CPSDefinition.
Require Import CPSSpecialCases.
Require Import CPSSimulation.
(* [cbv+ . pcbv] implies [pcbv*]. *)
Lemma technical_inclusion_0:
inclusion plus_cbv_pcbv (star pcbv).
Proof.
intros t1 t2. unfold composition. intros. unpack.
eauto 6 using cbv_subset_pcbv, plus_covariant with sequences.
Qed.
(* [(cbv+ . pcbv)*] implies [pcbv*]. *)
Lemma technical_inclusion_1:
inclusion (star plus_cbv_pcbv) (star pcbv).
Proof.
eapply inclusion_transitive; [| eapply inclusion_star_star ].
eapply star_covariant_inclusion.
eapply technical_inclusion_0.
Qed.
(* A simplified simulation diagram. *)
Lemma simulation_cbv_pcbv:
forall t t',
star cbv t t' ->
star pcbv (cps t init) (cps t' init).
Proof.
intros t t' Hred.
(* According to the simulation diagram (iterated), [cps t c] reduces to
[cps v c] via a series of [cbv] and [pcbv] steps. *)
destruct (star_diamond_left _ _ _ cps_init_simulation _ _ Hred _ eq_refl)
as (?&?&?). subst.
(* Thus, [cps t c] reduces to [cps t' c] via [pcbv*]. *)
eapply technical_inclusion_1. eauto.
Qed.
(* If [t] diverges, then [cps t init] diverges, too. *)
Lemma cps_preserves_divergence:
forall t,
infseq cbv t ->
infseq cbv (cps t init).
Proof.
intros.
eapply pcbv_preserves_divergence.
eapply infseq_simulation.
{ eapply cps_init_simulation. }
{ eauto. }
{ tauto. }
Qed.
(* If [t] converges to a value [v], then [cps t init] converges to a value [w].
Furthermore, [w] reduces to [cpsv v] via a number of parallel reduction
steps. *)
Lemma cps_preserves_convergence:
forall t v,
star cbv t v ->
is_value v ->
exists w,
star cbv (cps t init) w /\
is_value w /\
star pcbv w (cpsv v).
Proof.
intros ? ? Htv Hv.
(* [cps t init] reduces to [cps v init] via [pcbv*]. *)
generalize (simulation_cbv_pcbv _ _ Htv); intro Hred.
(* [cps v init] is [cpsv v]. *)
assert (Heq: cps v init = cpsv v).
{ cps. reflexivity. }
(* Thus, [cps t init] reduces to [cpsv v] via [pcbv*]. *)
rewrite Heq in Hred.
(* Bifurcate this reduction sequence. *)
forward1 crarys_lemma9. clear Hred.
(* This gives us the value [w] that we are looking for. *)
eexists. split. eauto. split.
{ eauto using
(star_implication_reversed _ ipcbv_preserves_values_reversed)
with obvious. }
{ eauto using star_covariant, ipcbv_subset_pcbv. }
Qed.
(* If [t] is stuck, then [cps t c] is stuck. Not a really interesting
property, but we prove it, just so that no stone is left unturned. *)
Lemma cps_preserves_stuck:
forall t,
stuck t ->
forall c,
stuck (cps t c).
Proof.
induction 1; intros.
(* StuckApp *)
{ rewrite cps_app_value_value by eauto.
eapply StuckAppL.
eapply StuckApp; [ obvious | obvious |].
(* Only [Lam] is translated to [Lam]. *)
intros. destruct v1.
{ cpsv. congruence. }
{ cpsv. false. congruence. }
{ obvious. }
{ obvious. }
}
(* StuckAppL *)
{ cps. eauto. }
(* StuckAppR *)
{ rewrite cps_app_value by eauto. eauto. }
(* StuckLetL *)
{ cps. eauto. }
Qed.
(* As a corollary, the property of going wrong is preserved by the CPS
transformation. *)
Lemma cps_preserves_going_wrong:
forall t,
goes_wrong t ->
goes_wrong (cps t init).
Proof.
intros ? [ t' [ Htt' ? ]].
(* [cps t init] reduces to [cps t' init] via [pcbv*]. *)
generalize (simulation_cbv_pcbv _ _ Htt'); intro Hred.
(* Bifurcate this reduction sequence. *)
forward1 crarys_lemma9. clear Hred.
(* This gives us the stuck term we are looking for. *)
eexists. split. eauto.
eauto using cps_preserves_stuck, reverse_star_ipcbv_preserves_stuck.
Qed.
Require Import MyTactics.
Require Import Sequences.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusValues.
Require Import LambdaCalculusReduction.
Require Import CPSDefinition.
(* The single-step simulation lemma in Danvy and Filinski's paper states that
if [t1] reduces to [t2], then [cps t1 c] reduces (in one or more steps) to
[cps t2 c]. Although this lemma is true in the pure lambda calculus, it
fails when the calculus is extended with [Let]. This file provides two
counter-examples. *)
(* Although Danvy and Filinski's paper does not claim that this lemma holds
when the calculus is extended with [Let], it does not indicate that the
lemma fails, either. *)
(* -------------------------------------------------------------------------- *)
(* The tactic [analyze] assumes that there is a hypothesis [star cbv t1 t2].
It checks that [t1] and [t2] are distinct and, if [t1] reduces to [t'1],
updates this hypothesis to [star cbv t'1 t2]. Repeating this tactic allows
proving that [t1] does *not* reduce to [t2]. *)
Ltac analyze :=
invert_star_cbv; repeat invert_cbv; compute in *; fold cbv_mask in *;
repeat match goal with h: True |- _ => clear h end.
Transparent cps cpsv. (* required by [compute] *)
(* -------------------------------------------------------------------------- *)
(* Consider the term [t1], defined as follows. In informal syntax, [t1]
is written (\z.let w = z in w) (\x.x). *)
Definition t1 :=
App (Lam (Let (Var 0) (Var 0))) (Lam (Var 0)).
(* The term [t1] reduces to [t2], which in informal syntax is written
let w = \x.x in w. *)
Definition t2 :=
Let (Lam (Var 0)) (Var 0).
Goal
cbv t1 t2.
Proof.
unfold t1, t2. obvious.
Qed.
(* The single-step simulation diagram is violated: [cps t1 init] does
*not* reduce (in any number of steps) to [cps t2 init]. *)
Goal
~ (star cbv (cps t1 init) (cps t2 init)).
Proof.
compute; fold cbv_mask. intro.
analyze.
analyze.
(* This point is the near miss:
[cps t1 init] has now reduced to a [Let] construct, whereas
[cps t2 init] is a similar-looking [Let] construct.
Both have the same value on the left-hand side of the [Let].
But the right-hand sides of the [Let] construct differ. *)
analyze.
analyze.
analyze.
Qed.
(* Let us summarize.
The term [t1] reduces in one step to [t2] as follows:
(\z.let w = z in w) (\x.x)
->
let w = \x.x in w
The term [cps t1 init], in informal notation, is as follows:
(\z.\k.let w = z in k w)
(\x.\k. k x)
(\w.w)
This term reduces in two steps to:
let w = \x.\k. k x in
(\w.w) w
But the term [cps t2 init], in informal notation, is:
let w = \x.\k. k x in
w
This is our near miss. Both terms are [let] constructs and both have
the same left-hand side, but the right-hand sides differ by a beta-v
reduction. Thus, [cps t1 init] does not reduce *in call-by-value* to
[cps t2 init]. In order to allow [cps u1 init] to join [cps u2 init],
we must allow beta-v reductions in the right-hand side of [let]
constructs (and, it turns out, under lambda-abstractions, too.)
This is visible in the proof of the [simulation] lemma in the file
CPSSimulation: there, we use the reduction strategy [pcbv], which
allows (parallel) beta-v reductions under arbitrary contexts. *)
(* This counter-example is one of two closed counter-examples of minimal size.
It has size 4 (counting [Lam], [App], and [Let] nodes) and involves only
one [Let] construct. There are no smaller counter-examples. An exhaustive
search procedure, coded in OCaml, was used to find it. *)
Require Import MyTactics.
Require Import Sequences.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusValues.
Require Import LambdaCalculusReduction.
Require Import CPSDefinition.
(* In a CPS term (i.e., a term produced by the CPS translation), the
right-hand side of every application is a value, and the left-hand
side of every [let] construct is a value. *)
Inductive is_cps : term -> Prop :=
| IsCPSVar:
forall x,
is_cps (Var x)
| IsCPSLam:
forall t,
is_cps t ->
is_cps (Lam t)
| IsCPSApp:
forall t1 t2,
is_cps t1 ->
is_cps t2 ->
is_value t2 ->
is_cps (App t1 t2)
| IsCPSLet:
forall t1 t2,
is_cps t1 ->
is_cps t2 ->
is_value t1 ->
is_cps (Let t1 t2)
.
(* To prove that the above invariant holds, we must also define what it means
for a continuation [c] to satisfy this invariant. *)
Inductive is_cps_continuation : continuation -> Prop :=
| IsCPSO:
forall k,
is_value k ->
is_cps k ->
is_cps_continuation (O k)
| IsCPSM:
forall K,
is_cps K ->
is_cps_continuation (M K).
Local Hint Constructors is_cps is_cps_continuation.
(* [is_cps] is preserved by renamings. *)
Lemma is_cps_renaming:
forall t,
is_cps t ->
forall sigma,
is_ren sigma ->
is_cps t.[sigma].
Proof.
induction 1; intros sigma Hsigma; asimpl;
try solve [ econstructor; obvious ].
(* Var *)
{ destruct Hsigma as [ xi ? ]. subst sigma. asimpl. econstructor. }
Qed.
Local Hint Resolve is_cps_renaming.
Lemma is_cps_continuation_renaming:
forall c i,
is_cps_continuation c ->
is_cps_continuation (liftc i c).
Proof.
induction 1; simpl; econstructor; obvious.
Qed.
Local Hint Resolve is_cps_continuation_renaming.
(* [is_cps] is preserved by substitution. *)
Lemma is_cps_substitution_aux:
forall sigma,
(forall x, is_cps (sigma x)) ->
(forall x, is_cps (up sigma x)).
Proof.
intros sigma H [|x]; asimpl.
{ econstructor. }
{ eapply is_cps_renaming; obvious. }
Qed.
Lemma is_cps_substitution:
forall K,
is_cps K ->
forall sigma,
(forall x, is_cps (sigma x)) ->
is_value_subst sigma ->
is_cps K.[sigma].
Proof.
induction 1; intros; asimpl; eauto;
econstructor; eauto using is_cps_substitution_aux with obvious.
Qed.
Lemma is_cps_substitution_0:
forall K v,
is_cps K ->
is_cps v ->
is_value v ->
is_cps K.[v/].
Proof.
intros. eapply is_cps_substitution; obvious.
intros [|x]; asimpl; eauto.
Qed.
(* Inversion lemmas for [is_cps]. *)
Lemma is_cps_Lam_inversion:
forall t,
is_cps (Lam t) ->
is_cps t.
Proof.
inversion 1; eauto.
Qed.
(* A CPS term reduces in the same manner in call-by-value and in call-by-name.
Thus, the CPS transformation produces terms that are "indifferent" to which
of these two reduction strategies is chosen. *)
Lemma cps_indifference_1:
forall t1, is_cps t1 ->
forall t2, cbv t1 t2 -> cbn t1 t2.
Proof.
induction 1; intros; invert_cbv; obvious.
Qed.
Lemma cps_indifference_2:
forall t1, is_cps t1 ->
forall t2, cbn t1 t2 -> cbv t1 t2.
Proof.
induction 1; intros; invert_cbn; obvious.
Qed.
(* [is_cps] is preserved by call-by-value and call-by-name reduction. *)
Lemma is_cps_cbv:
forall t,
is_cps t ->
forall t',
cbv t t' ->
is_cps t'.
Proof.
induction 1; intros; invert_cbv;
eauto using is_cps, is_cps_substitution_0, is_cps_Lam_inversion.
Qed.
Lemma is_cps_cbn:
forall t,
is_cps t ->
forall t',
cbn t t' ->
is_cps t'.
Proof.
induction 1; intros; invert_cbn;
eauto using is_cps, is_cps_substitution_0, is_cps_Lam_inversion.
Qed.
(* A CPS term reduces in the same manner in call-by-value and in call-by-name.
The statement is here generalized to a sequence of reduction steps. *)
Lemma cps_star_indifference_1:
forall t1 t2,
star cbv t1 t2 ->
is_cps t1 ->
star cbn t1 t2.
Proof.
induction 1; intros;
eauto using cps_indifference_1, is_cps_cbv with sequences.
Qed.
Lemma cps_star_indifference_2:
forall t1 t2,
star cbn t1 t2 ->
is_cps t1 ->
star cbv t1 t2.
Proof.
induction 1; intros;
eauto using cps_indifference_2, is_cps_cbn with sequences.
Qed.
(* The main auxiliary lemmas. *)
Lemma is_cps_apply:
forall c v,
is_cps_continuation c ->
is_cps v ->
is_value v ->
is_cps (apply c v).
Proof.
inversion 1; intros; simpl; eauto using is_cps_substitution_0.
Qed.
Lemma is_cps_reify:
forall c,
is_cps_continuation c ->
is_cps (reify c).
Proof.
inversion 1; simpl; eauto.
Qed.
Lemma is_value_reify:
forall c,
is_cps_continuation c ->
is_value (reify c).
Proof.
inversion 1; simpl; eauto.
Qed.
Local Hint Resolve is_cps_apply is_cps_reify is_value_reify.
(* The main lemma. *)
Lemma cps_form:
(
forall v,
is_value v ->
is_cps (cpsv v)
) /\ (
forall t c,
is_cps_continuation c ->
is_cps (cps t c)
).
Proof.
eapply mutual_induction.
(* [cpsv] *)
{ intros n IHcps v Hvn ?.
destruct v; [ | | false; obvious | false; obvious ].
{ cpsv; eauto. }
{ cpsv; eauto 6 with size. }
}
(* [cps] *)
{ intros n IHcpsv IHcps t c Htn Hc.
value_or_app_or_let t; cps.
(* Case: [t] is a value. *)
{ obvious. }
(* Case: [t] is an application. *)
{ eapply IHcps; [ size | econstructor ].
eapply IHcps; [ size | econstructor ].
econstructor; obvious. }
(* Case: [t] is a [let] construct. *)
{ eauto 8 with obvious. }
}
Qed.
Lemma cps_form_main:
forall t,
is_cps (cpsinit t).
Proof.
simpl. intros. eapply cps_form. unfold init. obvious.
Qed.
(* One property of CPS terms that we do not prove is that all applications are
in tail position, or, in other words, that there is no need for reduction
under a context. In fact, because a CPS-translated function expects two
arguments, there *is* a need for reduction under a context, but only under
a context of depth zero or one. *)
Require Import MyTactics.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusValues.
Require Import CPSDefinition.
Require Import CPSContextSubstitution.
Require Import CPSRenaming.
(* The [substitution] lemma in CPSSubstitution pushes a substitution
into [cps t k]. The substitution is pushed into both [t] and [k].
Because it is pushed into [t], this substitution must be of the
form [sigma >>> cpsv], so that, once pushed into [t], it becomes
just [sigma]. *)
(* Here, we prove another substitution lemma, where the substitution
need not be of the form [sigma >>> cpsv]. It can be an arbitrary
substitution. We require [sigma] to not affect the term [t], so
[sigma] is not pushed into [t]: it is pushed into [k] only. For
this reason, we refer to this lemma as the [kubstitution] lemma.
In order to express the idea that [sigma] does not affect a term,
more precisely, we write this term under the form [t.[theta]]
and we require that [theta] and [sigma] cancel out, that is,
theta >> sigma = ids
(This condition implies [is_ren theta], that is, [theta] must be
a renaming.) Then, we are able to prove the following result:
(cps t.[theta] (O k)).[sigma] = cps t (O k.[sigma])
That is, the substitution [sigma], when pushed into [t], meets [theta]
and they cancel out. *)
(* [apply] commutes with kubstitutions. *)
Lemma apply_kubstitution:
forall c theta sigma c' v,
theta >> sigma = ids ->
substc sigma c = c' ->
(apply c v.[theta]).[sigma] = apply c' v.
Proof.
intros. subst.
destruct c; asimpl; pick @eq ltac:(fun h => rewrite h); autosubst.
Qed.
Local Hint Resolve up_theta_sigma_ids : obvious.
(* The main result: [cpsv] and [cps] commute with kubstitutions. *)
Lemma kubstitution:
(
forall v theta sigma,
theta >> sigma = ids ->
(cpsv v.[theta]).[sigma] = cpsv v
) /\ (
forall t c theta sigma c',
theta >> sigma = ids ->
substc sigma c = c' ->
(cps t.[theta] c).[sigma] = cps t c'
).
Proof.
eapply mutual_induction.
(* [cpsv] *)
{ intros n IHcps v Hvn theta sigma Hid. clear IHcps.
rewrite <- cpsv_renaming by obvious.
asimpl. rewrite Hid.
asimpl. reflexivity. }
(* [cps] *)
{ intros n IHcpsv IHcps t c Htn theta sigma c' Hid Hkubstc. clear IHcpsv.
value_or_app_or_let t; asimpl; cps.
(* Case: [t] is a value. *)
{ rewrite <- cpsv_renaming by obvious.
eauto using apply_kubstitution. }
(* Case: [t] is an application. *)
{ eapply IHcps; obvious.
simpl. f_equal.
erewrite <- lift_up by tc.
eapply IHcps; obvious.
asimpl. do 2 f_equal.
rewrite lift_reify.
eapply reify_substitution.
subst. rewrite substc_substc.
reflexivity. }
(* Case: [t] is a [let] construct. *)
{ eapply IHcps; obvious.
simpl. do 2 f_equal.
rewrite fold_up_up.
rewrite up_sigma_up_ren by tc. simpl.
eapply IHcps; obvious. }
}
Qed.
(* The projections of the above result. *)
Definition cpsv_kubstitution := proj1 kubstitution.
Definition cps_kubstitution := proj2 kubstitution.
(* A corollary where the substitution [sigma] is [v .: ids], that is, a
substitution of the value [v] for the variable 0. *)
Lemma cps_kubstitution_0:
forall t c v,
(cps (lift 1 t) c).[v/] = cps t (substc (v .: ids) c).
Proof.
intros. eapply cps_kubstitution.
{ autosubst. }
{ reflexivity. }
Qed.
(* A corollary where the substitution [sigma] is [up (v .: ids)], that is, a
substitution of the value [v] for the variable 1. *)
Lemma cps_kubstitution_1:
forall t c v,