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. *)
Require Import MyTactics.
Require Import FixExtra.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusValues.
(* This is a definition of the CPS transformation. *)
(* This CPS transformation is "one-pass" in the sense that it does not produce
any administrative redexes. (In other words, there is no need for a second
pass, whose purpose would be to remove administrative redexes.)
To achieve this, instead of defining [cps t k], where the continuation [k]
is a term, we define [cps t c], where the continuation [c] is either a term
(also known as an object-level continuation) or a term-with-a-hole [K]
(also known as a meta-level continuation).
This formulation of the CPS transformation is analogous to Danvy and
Filinski's higher-order formulation. Yet, it is still technically
first-order, because we represent a term-with-a-hole [K] as a term,
where the variable 0 denotes the hole. *)
(* This CPS transformation is defined by recursion on the size of terms. This
allows recursive calls of the form [cps (lift 1 t)], which would be illegal
if [cps] was defined by structural induction. Definitions by well-founded
recursion in Coq are somewhat tricky, requiring the use of the fixed point
combinator [Fix] and the tactic [refine]. For explanations, see the chapter
on general recursion in Chlipala's book at
http://adam.chlipala.net/cpdt/html/GeneralRec.html *)
(* The situation could be complicated by the fact that we wish to define two
functions simultaneously:
[cpsv v] is the translation of a value [v].
[cps t c] is the translation of a term [t] with continuation [c].
To avoid this problem, we follow Danvy and Filinski's approach, which is to
first define [cps] directly (as this does not cause much duplication), then
define [cpsv] in terms of [cps]. In the latter step, no case analysis is
required: [cpsv] is obtained by invoking [cps] with an identity meta-level
continuation.
Regardless of how [cps] and [cpsv] are defined, we prove that the they
satisfy the desired recurrence equations, so, in the end, everything is
just as if they had been defined in a mutually recursive manner. *)
(* -------------------------------------------------------------------------- *)
(* As explained above, a continuation [c] is
either [O k], where [k] is a term (in fact, a value)
(an object-level continuation)
or [M K], where [K] is term-with-a-hole
(a meta-level continuation).
A term-with-a-hole [K] is represented as a term where the variable 0 denotes
the hole (and, of course, all other variables are shifted up). *)
Inductive continuation :=
| O (k : term)
| M (K : term).
(* The term [apply c v] is the application of the continuation [c] to the
value [v]. If [c] is an object-level continuation [k] (that is, a term),
then it is just the object-level application [App k v]. If [c] is a
meta-level continuation [K], then it is the meta-level operation of filling
the hole with the value [v], which in fact is just a substitution,
[K.[v/]]. *)
Definition apply (c : continuation) (v : term) : term :=
match c with
| O k =>
App k v
| M K =>
K.[v/]
end.
(* The term [reify c] is the reification of the continuation [c] as an
object-level continuation (that is, a term). If [c] is an object-level
continuation [k], then it is just [k]. If [c] is a meta-level continuation
[K], then [reify c] is the term [\x.K x]. (This is usually known as a
two-level eta-expansion.) Because the hole is already represented by the
variable 0, filling the hole with the variable [x] is a no-op. Therefore,
it suffices to write [Lam K] to obtain the desired lambda-abstraction. *)
Definition reify (c : continuation) : term :=
match c with
| O k =>
k
| M K =>
Lam K
end.
(* The continuation [substc sigma c] is the result of applying the
substitution [sigma] to the continuation [c]. *)
Definition substc sigma (c : continuation) : continuation :=
match c with
| O k =>
O k.[sigma]
| M K =>
M K.[up sigma]
end.
(* [liftc i c] is the result of lifting the free names of the continuation [c]
up by [i]. The function [liftc] can be defined in terms of [substc]. *)
Notation liftc i c :=
(substc (ren (+i)) c).
(* -------------------------------------------------------------------------- *)
(* Here is the definition of [cps]. Because we must keep track of sizes and
prove that the recursive calls cause a decrease in the size, this
definition cannot be easily written as Coq terms. Instead, we switch to
proof mode and use the tactic [refine]. This allows us to write some of the
code, with holes [_] in it, and use proof mode to fill the holes. *)
(* [cps t c] is the CPS-translation of the term [t] with continuation [c]. *)
Definition cps : term -> continuation -> term.
Proof.
(* The definition is by well-founded recursion on the size of [t]. *)
refine (Fix smaller_wf_transparent (fun _ => continuation -> term) _).
(* We receive the arguments [t] and [c] as well as a function [cps_]
which we use for recursive calls. At every call to [cps_], there
is an obligation to prove that the size of the argument is less
than the size of [t]. *)
intros t cps_ c.
(* The definition is by cases on the term [t]. *)
destruct t as [ x | t | t1 t2 | t1 t2 ].
(* When [t] is a value, we return an application of the continuation [c]
to a value which will later be known as [cpsv t]. *)
(* Case: [Var x]. *)
{ refine (apply c (Var x)). }
(* Case: [Lam t]. *)
(* In informal notation, the term [\x.t] is transformed to an application of
[c] to [\x.\k.[cps t k]], where [k] is a fresh variable. Here, [k] is
represented by the de Bruijn index 0, and the term [t] must be lifted
because it is brought into the scope of [k]. *)
{ refine (apply c
(Lam (* x *) (Lam (* k *) (cps_ (lift 1 t) _ (O (Var 0)))))
); abstract size. }
(* Case: [App t1 t2]. *)
(* The idea is, roughly, to first obtain the value [v1] of [t1], then obtain
the value [v2] of [t2], then perform the application [v1 v2 c].
Two successive calls to [cps] are used to obtain [v1] and [v2]. In each
case, we avoid administrative redexes by using an [M] continuation.
Thus, [v1] and [v2] are represented by two holes, denoted by the
variables [Var 1] and [Var 0].
If [t1] is a value, then the first hole will be filled directly with (the
translation of) [t1]; otherwise, it will be filled with a fresh variable,
bound to the result of evaluating (the translation of) [t1]. The same
goes for [t2].
The application [v1 v2 c] does not directly make sense, since [c] is a
continuation, not a term. Instead of [c], we must use [reify c]. The
continuation [c] must turned into a term, so it can be used in this
term-level application.
A little de Bruijn wizardry is involved. The term [t2] must be lifted up
by 1 because it is brought into the scope of the first meta-level
continuation. Similarly, the first hole must be lifted by 1 because it is
brought into the scope of the second meta-level continuation: thus, it
becomes Var 1. Finally, the continuation [c] must be lifted up by [2]
because it is brought into the scope of both. Here, we have a choice
between [reify (liftc _ c)] and [lift _ (reify c)], which mean the same
thing. *)
{ refine (
cps_ t1 _ (M (
cps_ (lift 1 t2) _ (M (
App (App (Var 1) (Var 0)) (lift 2 (reify c))
))
))
);
abstract size.
}
(* Case: [Let x = t1 in t2]. *)
(* The idea is to first obtain the value [v1] of [t1]. This value is
represented by the hole [Var 0] in the [M] continuation. We bind
this value via a [Let] construct to the variable [x] (represented by the
index 0 in [t2]), then execute [t2], under the original continuation [c].
All variables in [t2] except [x] must lifted up by one because they are
brought in the scope of the meta-level continuation. The continuation [c]
must be lifted up by 2 because it is brought in the scope of the
meta-level continuation and in the scope of the [Let] construct. *)
{ refine (
cps_ t1 _ (M (
Let (Var 0) (
cps_ t2.[up (ren (+1))] _ (liftc 2 c)
)
))
);
abstract size.
}
Defined.
(* -------------------------------------------------------------------------- *)
(* The above definition can be used inside Coq to compute the image of a term
through the transformation. For instance, the image under [cps] of [\x.x]
with object-level continuation [k] (a variable) is [k (\x.\k.k x)]. *)
Goal
cps (Lam (Var 0)) (O (Var 0)) =
App (Var 0) (Lam (Lam (App (Var 0) (Var 1)))).
Proof.
compute. (* optional *)
reflexivity.
Qed.
(* The image of [(\x.x) y] with continuation [k] is [(\x.\k.k x) y k]. *)
Goal
cps (App (Lam (Var 0)) (Var 0)) (O (Var 1)) =
App (App (Lam (Lam (App (Var 0) (Var 1)))) (Var 0)) (Var 1).
Proof.
compute. (* optional *)
reflexivity.
Qed.
(* -------------------------------------------------------------------------- *)
(* The initial continuation is used when invoking [cps] at the top level. *)
(* We could use [O (Lam (Var 0))] -- that is, the identity function -- as
the initial continuation. Instead, we use [M (Var 0)], that is, the
empty context. This sometimes saves one beta-redex. *)
Definition init :=
M (Var 0).
Definition cpsinit t :=
cps t init.
(* -------------------------------------------------------------------------- *)
(* Now that [cps] is defined, we can define [cpsv] in terms of it. *)
(* We explicitly check whether [v] is a value, and if it is not, we return a
dummy closed value. [cpsv] is supposed to be applied only to values,
anyway. Using a dummy value allows us to prove that [cpsv v] is always a
value, without requiring that [v] itself be a value. *)
Definition cpsv (v : term) :=
if_value v
(cpsinit v)
(Lam (Var 0)).
(* -------------------------------------------------------------------------- *)
(* The function [cps] satisfies the expected recurrence equations. *)