You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

311 lines
9.3 KiB

This file contains ambiguous Unicode characters!

This file contains ambiguous Unicode characters that may be confused with others in your current locale. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to highlight these characters.

From stdpp Require Import gmap base relations.
From iris Require Import prelude.
From semantics.lib Require Import maps.
From semantics.ts.systemf_mu Require Import lang notation.
Lemma contextual_ectx_step_case K e e' :
contextual_step (fill K e) e'
( e'', e' = fill K e'' contextual_step e e'') is_val e.
Proof.
destruct (to_val e) as [ v | ] eqn:Hv.
{ intros _. right. apply is_val_spec. eauto. }
intros Hcontextual. left.
inversion Hcontextual as [K' e1' e2' Heq1 Heq2 Hstep]; subst.
eapply step_by_val in Heq1 as (K'' & ->); [ | done | done].
rewrite <-fill_comp.
eexists _. split; [done | ].
rewrite <-fill_comp in Hcontextual.
apply contextual_step_ectx_inv in Hcontextual; done.
Qed.
(** ** Deterministic reduction *)
Record det_step (e1 e2 : expr) := {
det_step_safe : reducible e1;
det_step_det e2' :
contextual_step e1 e2' e2' = e2
}.
Record det_base_step (e1 e2 : expr) := {
det_base_step_safe : base_reducible e1;
det_base_step_det e2' :
base_step e1 e2' e2' = e2
}.
Lemma det_base_step_det_step e1 e2 : det_base_step e1 e2 det_step e1 e2.
Proof.
intros [Hp1 Hp2]. split.
- destruct Hp1 as (e2' & ?).
eexists e2'. by apply base_contextual_step.
- intros e2' ?%base_reducible_contextual_step; [ | done]. by apply Hp2.
Qed.
(** *** Pure execution lemmas *)
Local Ltac inv_step :=
repeat match goal with
| H : to_val _ = Some _ |- _ => apply of_to_val in H
| H : base_step ?e ?e2 |- _ =>
try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
and should thus better be avoided. *)
inversion H; subst; clear H
end.
Local Ltac solve_exec_safe := intros; subst; eexists; econstructor; eauto.
Local Ltac solve_exec_detdet := simpl; intros; inv_step; try done.
Local Ltac solve_det_exec :=
subst; intros; apply det_base_step_det_step;
constructor; [solve_exec_safe | solve_exec_detdet].
Lemma det_step_beta x e e2 :
is_val e2
det_step (App (@Lam x e) e2) (subst' x e2 e).
Proof. solve_det_exec. Qed.
Lemma det_step_tbeta e :
det_step ((Λ, e) <>) e.
Proof. solve_det_exec. Qed.
Lemma det_step_unpack e1 e2 x :
is_val e1
det_step (unpack (pack e1) as x in e2) (subst' x e1 e2).
Proof. solve_det_exec. Qed.
Lemma det_step_unop op e v v' :
to_val e = Some v
un_op_eval op v = Some v'
det_step (UnOp op e) v'.
Proof. solve_det_exec. by simplify_eq. Qed.
Lemma det_step_binop op e1 v1 e2 v2 v' :
to_val e1 = Some v1
to_val e2 = Some v2
bin_op_eval op v1 v2 = Some v'
det_step (BinOp op e1 e2) v'.
Proof. solve_det_exec. by simplify_eq. Qed.
Lemma det_step_if_true e1 e2 :
det_step (if: #true then e1 else e2) e1.
Proof. solve_det_exec. Qed.
Lemma det_step_if_false e1 e2 :
det_step (if: #false then e1 else e2) e2.
Proof. solve_det_exec. Qed.
Lemma det_step_fst e1 e2 :
is_val e1
is_val e2
det_step (Fst (e1, e2)) e1.
Proof. solve_det_exec. Qed.
Lemma det_step_snd e1 e2 :
is_val e1
is_val e2
det_step (Snd (e1, e2)) e2.
Proof. solve_det_exec. Qed.
Lemma det_step_casel e e1 e2 :
is_val e
det_step (Case (InjL e) e1 e2) (e1 e).
Proof. solve_det_exec. Qed.
Lemma det_step_caser e e1 e2 :
is_val e
det_step (Case (InjR e) e1 e2) (e2 e).
Proof. solve_det_exec. Qed.
Lemma det_step_unroll e :
is_val e
det_step (unroll (roll e)) e.
Proof. solve_det_exec. Qed.
(** ** n-step reduction *)
(** Reduce in n steps to an irreducible expression.
(this is ⇝^n from the lecture notes)
*)
Definition red_nsteps (n : nat) (e e' : expr) := nsteps contextual_step n e e' irreducible e'.
Lemma det_step_red e e' e'' n :
det_step e e'
red_nsteps n e e''
1 n red_nsteps (n - 1) e' e''.
Proof.
intros [Hprog Hstep] Hred.
inversion Hprog; subst.
destruct Hred as [Hred Hirred].
destruct n as [ | n].
{ inversion Hred; subst.
exfalso; eapply not_reducible; done.
}
inversion Hred; subst. simpl.
apply Hstep in H as ->. apply Hstep in H1 as ->.
split; first lia.
replace (n - 0) with n by lia. done.
Qed.
Lemma contextual_step_red_nsteps n e e' e'' :
contextual_step e e'
red_nsteps n e' e''
red_nsteps (S n) e e''.
Proof.
intros Hstep [Hsteps Hirred].
split; last done.
by econstructor.
Qed.
Lemma nsteps_val_inv n v e' :
red_nsteps n (of_val v) e' n = 0 e' = of_val v.
Proof.
intros [Hred Hirred]; cbn in *.
destruct n as [ | n].
- inversion Hred; subst. done.
- inversion Hred; subst. exfalso. eapply val_irreducible; last done.
rewrite to_of_val. eauto.
Qed.
Lemma nsteps_val_inv' n v e e' :
to_val e = Some v
red_nsteps n e e' n = 0 e' = of_val v.
Proof. intros Ht. rewrite -(of_to_val _ _ Ht). apply nsteps_val_inv. Qed.
Lemma red_nsteps_fill K k e e' :
red_nsteps k (fill K e) e'
j e'', j k
red_nsteps j e e''
red_nsteps (k - j) (fill K e'') e'.
Proof.
intros [Hsteps Hirred].
induction k as [ | k IH] in e, e', Hsteps, Hirred |-*.
- inversion Hsteps; subst.
exists 0, e. split_and!; [done | split | ].
+ constructor.
+ by eapply irreducible_fill.
+ done.
- inversion Hsteps as [ | n e1 e2 e3 Hstep Hsteps' Heq1 Heq2 Heq3]. subst.
destruct (contextual_ectx_step_case _ _ _ Hstep) as [(e'' & -> & Hstep') | Hv].
+ apply IH in Hsteps' as (j & e3 & ? & Hsteps' & Hsteps''); last done.
eexists (S j), _. split_and!; [lia | | done].
eapply contextual_step_red_nsteps; done.
+ exists 0, e. split_and!; [ lia | | ].
* split; [constructor | ].
apply val_irreducible. by apply is_val_spec.
* simpl. by eapply contextual_step_red_nsteps.
Qed.
(** Additionally useful stepping lemmas *)
Lemma app_step_r (e1 e2 e2': expr) :
contextual_step e2 e2' contextual_step (e1 e2) (e1 e2').
Proof. by apply (fill_contextual_step [AppRCtx _]). Qed.
Lemma app_step_l (e1 e1' e2: expr) :
contextual_step e1 e1' is_val e2 contextual_step (e1 e2) (e1' e2).
Proof.
intros ? (v & Hv)%is_val_spec.
rewrite <-(of_to_val _ _ Hv).
by apply (fill_contextual_step [AppLCtx _]).
Qed.
Lemma app_step_beta (x: string) (e e': expr) :
is_val e' is_closed [x] e contextual_step ((λ: x, e) e') (lang.subst x e' e).
Proof.
intros Hval Hclosed. eapply base_contextual_step, BetaS; eauto.
Qed.
Lemma unroll_roll_step (e: expr) :
is_val e contextual_step (unroll (roll e)) e.
Proof.
intros ?; by eapply base_contextual_step, UnrollS.
Qed.
Lemma fill_reducible K e :
reducible e reducible (fill K e).
Proof.
intros (e' & Hstep).
exists (fill K e'). eapply fill_contextual_step. done.
Qed.
Lemma reducible_contextual_step_case K e e' :
contextual_step (fill K e) (e')
reducible e
e'', e' = fill K e'' contextual_step e e''.
Proof.
intros [ | Hval]%contextual_ectx_step_case Hred; first done.
exfalso. apply is_val_spec in Hval as (v & Hval).
apply reducible_not_val in Hred. congruence.
Qed.
(** Contextual lifting lemmas for deterministic reduction *)
Tactic Notation "lift_det" uconstr(ctx) :=
intros;
let Hs := fresh in
match goal with
| H : det_step _ _ |- _ => destruct H as [? Hs]
end;
simplify_val; econstructor;
[intros; by eapply (fill_reducible ctx) |
intros ? (? & -> & ->%Hs)%(reducible_contextual_step_case ctx); done ].
Lemma det_step_pair_r e1 e2 e2' :
det_step e2 e2'
det_step (e1, e2)%E (e1, e2')%E.
Proof. lift_det [PairRCtx _]. Qed.
Lemma det_step_pair_l e1 e1' e2 :
is_val e2
det_step e1 e1'
det_step (e1, e2)%E (e1', e2)%E.
Proof. lift_det [PairLCtx _]. Qed.
Lemma det_step_binop_r e1 e2 e2' op :
det_step e2 e2'
det_step (BinOp op e1 e2)%E (BinOp op e1 e2')%E.
Proof. lift_det [BinOpRCtx _ _]. Qed.
Lemma det_step_binop_l e1 e1' e2 op :
is_val e2
det_step e1 e1'
det_step (BinOp op e1 e2)%E (BinOp op e1' e2)%E.
Proof. lift_det [BinOpLCtx _ _]. Qed.
Lemma det_step_if e e' e1 e2 :
det_step e e'
det_step (If e e1 e2)%E (If e' e1 e2)%E.
Proof. lift_det [IfCtx _ _]. Qed.
Lemma det_step_app_r e1 e2 e2' :
det_step e2 e2'
det_step (App e1 e2)%E (App e1 e2')%E.
Proof. lift_det [AppRCtx _]. Qed.
Lemma det_step_app_l e1 e1' e2 :
is_val e2
det_step e1 e1'
det_step (App e1 e2)%E (App e1' e2)%E.
Proof. lift_det [AppLCtx _]. Qed.
Lemma det_step_snd_lift e e' :
det_step e e'
det_step (Snd e)%E (Snd e')%E.
Proof. lift_det [SndCtx]. Qed.
Lemma det_step_fst_lift e e' :
det_step e e'
det_step (Fst e)%E (Fst e')%E.
Proof. lift_det [FstCtx]. Qed.
#[global]
Hint Resolve app_step_r app_step_l app_step_beta unroll_roll_step : core.
#[global]
Hint Extern 1 (is_val _) => (simpl; fast_done) : core.
#[global]
Hint Immediate is_val_of_val : core.
#[global]
Hint Resolve det_step_beta det_step_tbeta det_step_unpack det_step_unop det_step_binop det_step_if_true det_step_if_false det_step_fst det_step_snd det_step_casel det_step_caser det_step_unroll : core.
#[global]
Hint Resolve det_step_pair_r det_step_pair_l det_step_binop_r det_step_binop_l det_step_if det_step_app_r det_step_app_l det_step_snd_lift det_step_fst_lift : core.
#[global]
Hint Constructors nsteps : core.
#[global]
Hint Extern 1 (is_val _) => simpl : core.
(** Prove a single deterministic step using the lemmas we just proved *)
Ltac do_det_step :=
match goal with
| |- nsteps det_step _ _ _ => econstructor 2; first do_det_step
| |- det_step _ _ => simpl; solve[eauto 10]
end.