Commit 55582283 authored by POTTIER Francois's avatar 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. *)
This diff is collapsed.
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: