|
|
From stdpp Require Import gmap base relations.
|
|
|
From iris Require Import prelude.
|
|
|
From semantics.lib Require Export debruijn.
|
|
|
From semantics.ts.systemf Require Import lang notation types.
|
|
|
From Equations Require Import Equations.
|
|
|
|
|
|
(** * Big-step semantics *)
|
|
|
|
|
|
Implicit Types
|
|
|
(Δ : nat)
|
|
|
(Γ : typing_context)
|
|
|
(v : val)
|
|
|
(α : var)
|
|
|
(e : expr)
|
|
|
(A : type).
|
|
|
|
|
|
Inductive big_step : expr → val → Prop :=
|
|
|
| bs_lit (l : base_lit) :
|
|
|
big_step (Lit l) (LitV l)
|
|
|
| bs_lam (x : binder) (e : expr) :
|
|
|
big_step (λ: x, e)%E (λ: x, e)%V
|
|
|
| bs_binop e1 e2 v1 v2 v' op :
|
|
|
big_step e1 v1 →
|
|
|
big_step e2 v2 →
|
|
|
bin_op_eval op v1 v2 = Some v' →
|
|
|
big_step (BinOp op e1 e2) v'
|
|
|
| bs_unop e v v' op :
|
|
|
big_step e v →
|
|
|
un_op_eval op v = Some v' →
|
|
|
big_step (UnOp op e) v'
|
|
|
| bs_app e1 e2 x e v2 v :
|
|
|
big_step e1 (LamV x e) →
|
|
|
big_step e2 v2 →
|
|
|
big_step (subst' x (of_val v2) e) v →
|
|
|
big_step (App e1 e2) v
|
|
|
| bs_tapp e1 e2 v :
|
|
|
big_step e1 (TLamV e2) →
|
|
|
big_step e2 v →
|
|
|
big_step (e1 <>) v
|
|
|
| bs_tlam e :
|
|
|
big_step (Λ, e)%E (Λ, e)%V
|
|
|
| bs_pack e v :
|
|
|
big_step e v →
|
|
|
big_step (pack e)%E (pack v)%V
|
|
|
| bs_unpack e1 e2 v1 v2 x :
|
|
|
big_step e1 (pack v1)%V →
|
|
|
big_step (subst' x (of_val v1) e2) v2 →
|
|
|
big_step (unpack e1 as x in e2) v2
|
|
|
| bs_if_true e0 e1 e2 v :
|
|
|
big_step e0 #true →
|
|
|
big_step e1 v →
|
|
|
big_step (if: e0 then e1 else e2) v
|
|
|
| bs_if_false e0 e1 e2 v :
|
|
|
big_step e0 #false →
|
|
|
big_step e2 v →
|
|
|
big_step (if: e0 then e1 else e2) v
|
|
|
| bs_pair e1 e2 v1 v2 :
|
|
|
big_step e1 v1 →
|
|
|
big_step e2 v2 →
|
|
|
big_step (e1, e2) (v1, v2)
|
|
|
| bs_fst e v1 v2 :
|
|
|
big_step e (v1, v2) →
|
|
|
big_step (Fst e) v1
|
|
|
| bs_snd e v1 v2 :
|
|
|
big_step e (v1, v2) →
|
|
|
big_step (Snd e) v2
|
|
|
| bs_injl e v :
|
|
|
big_step e v →
|
|
|
big_step (InjL e) (InjLV v)
|
|
|
| bs_injr e v :
|
|
|
big_step e v →
|
|
|
big_step (InjR e) (InjRV v)
|
|
|
| bs_casel e e1 e2 v v' :
|
|
|
big_step e (InjLV v) →
|
|
|
big_step (e1 (of_val v)) v' →
|
|
|
big_step (Case e e1 e2) v'
|
|
|
| bs_caser e e1 e2 v v' :
|
|
|
big_step e (InjRV v) →
|
|
|
big_step (e2 (of_val v)) v' →
|
|
|
big_step (Case e e1 e2) v'
|
|
|
.
|
|
|
#[export] Hint Constructors big_step : core.
|
|
|
#[export] Hint Constructors base_step : core.
|
|
|
#[export] Hint Constructors contextual_step : core.
|
|
|
|
|
|
Lemma fill_rtc_contextual_step {e1 e2} K :
|
|
|
rtc contextual_step e1 e2 →
|
|
|
rtc contextual_step (fill K e1) (fill K e2).
|
|
|
Proof.
|
|
|
induction 1 as [ | x y z H1 H2 IH]; first done.
|
|
|
etrans; last apply IH.
|
|
|
econstructor 2; last constructor 1.
|
|
|
by apply fill_contextual_step.
|
|
|
Qed.
|
|
|
|
|
|
Lemma big_step_contextual e v :
|
|
|
big_step e v → rtc contextual_step e (of_val v).
|
|
|
Proof.
|
|
|
induction 1 as [ | | e1 e2 v1 v2 v' op H1 IH1 H2 IH2 Hop | e v v' op H1 IH1 Hop | e1 e2 x e v2 v H1 IH1 H2 IH2 H3 IH3 | e1 e2 v1 H1 IH1 H2 IH2 | | | e1 e2 v1 v2 x H1 IH1 H2 IH2 | e0 e1 e2 v H1 IH1 H2 IH2 | e0 e1 e2 v H1 IH1 H2 IH2| e1 e2 v1 v2 H1 IH1 H2 IH2 | e v1 v2 H IH | e v1 v2 H IH | e v H IH | e v H IH | e e1 e2 v v' H1 IH1 H2 IH2 | e e1 e2 v v' H1 IH1 H2 IH2 ].
|
|
|
- constructor.
|
|
|
- constructor.
|
|
|
- (* binop *)
|
|
|
etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (BinOpRCtx _ _ HoleCtx)). apply IH2. }
|
|
|
etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (BinOpLCtx _ HoleCtx _)). apply IH1. }
|
|
|
simpl.
|
|
|
etrans.
|
|
|
{ econstructor 2; last econstructor 1.
|
|
|
apply base_contextual_step. econstructor; last done.
|
|
|
all: apply to_of_val.
|
|
|
}
|
|
|
constructor.
|
|
|
- (* unop *)
|
|
|
etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (UnOpCtx _ HoleCtx)). apply IH1. }
|
|
|
simpl. etrans.
|
|
|
{ econstructor 2; last econstructor 1.
|
|
|
apply base_contextual_step. econstructor; last done.
|
|
|
all: apply to_of_val.
|
|
|
}
|
|
|
constructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (AppRCtx _ HoleCtx)). apply IH2. }
|
|
|
etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (AppLCtx HoleCtx _)). apply IH1. }
|
|
|
simpl. etrans.
|
|
|
{ econstructor 2; last econstructor 1.
|
|
|
apply base_contextual_step. constructor; [| reflexivity]. apply is_val_of_val.
|
|
|
}
|
|
|
apply IH3.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (TAppCtx HoleCtx)). apply IH1. }
|
|
|
etrans. { econstructor 2; last constructor. apply base_contextual_step. by constructor. }
|
|
|
done.
|
|
|
- constructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (PackCtx HoleCtx)). done. }
|
|
|
done.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (UnpackCtx x HoleCtx e2)). done. }
|
|
|
etrans.
|
|
|
{ econstructor 2; last constructor. apply base_contextual_step. simpl. constructor; last reflexivity.
|
|
|
apply is_val_spec. rewrite to_of_val. eauto.
|
|
|
}
|
|
|
done.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (IfCtx HoleCtx _ _)). done. }
|
|
|
etrans.
|
|
|
{ econstructor; last constructor. eapply base_contextual_step. econstructor. }
|
|
|
done.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (IfCtx HoleCtx _ _)). done. }
|
|
|
etrans.
|
|
|
{ econstructor; last constructor. eapply base_contextual_step. econstructor. }
|
|
|
done.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (PairRCtx e1 HoleCtx)). done. }
|
|
|
etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (PairLCtx HoleCtx v2)). done. }
|
|
|
econstructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (FstCtx HoleCtx)). done. }
|
|
|
econstructor.
|
|
|
{ eapply base_contextual_step. simpl. constructor; apply is_val_of_val. }
|
|
|
econstructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (SndCtx HoleCtx)). done. }
|
|
|
econstructor.
|
|
|
{ eapply base_contextual_step. simpl. constructor; apply is_val_of_val. }
|
|
|
econstructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (InjLCtx HoleCtx)). done. }
|
|
|
econstructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (InjRCtx HoleCtx)). done. }
|
|
|
econstructor.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (CaseCtx HoleCtx e1 e2)). done. }
|
|
|
simpl. econstructor.
|
|
|
{ eapply base_contextual_step. constructor. apply is_val_of_val. }
|
|
|
done.
|
|
|
- etrans.
|
|
|
{ eapply (fill_rtc_contextual_step (CaseCtx HoleCtx e1 e2)). done. }
|
|
|
simpl. econstructor.
|
|
|
{ eapply base_contextual_step. constructor. apply is_val_of_val. }
|
|
|
done.
|
|
|
Qed.
|
|
|
|
|
|
Lemma big_step_of_val e v :
|
|
|
e = of_val v →
|
|
|
big_step e v.
|
|
|
Proof.
|
|
|
intros ->.
|
|
|
induction v; simpl; eauto.
|
|
|
Qed.
|
|
|
|
|
|
Lemma big_step_val v v' :
|
|
|
big_step (of_val v) v' → v' = v.
|
|
|
Proof.
|
|
|
enough (∀ e, big_step e v' → e = of_val v → v' = v) by naive_solver.
|
|
|
intros e Hb.
|
|
|
induction Hb in v |-*; intros Heq; subst; destruct v; inversion Heq; subst; naive_solver.
|
|
|
Qed.
|
|
|
|
|
|
Lemma big_step_preserve_closed e v :
|
|
|
is_closed [] e → big_step e v → is_closed [] v.
|
|
|
Proof.
|
|
|
intros Hcl. induction 1; try done.
|
|
|
all: simpl in Hcl;
|
|
|
repeat match goal with
|
|
|
| H : Is_true (_ && _) |- _ => apply andb_True in H; destruct H
|
|
|
end; try naive_solver.
|
|
|
- (* binOP *)
|
|
|
destruct v1 as [[] | | | | | |], v2 as [[] | | | | | |]; simpl in H1; try congruence.
|
|
|
destruct op; simpl in H1; inversion H1; done.
|
|
|
- (* unop *)
|
|
|
destruct v as [[] | | | | | |]; destruct op; simpl in H0; inversion H0; done.
|
|
|
- (* app *)
|
|
|
apply IHbig_step3. apply is_closed_do_subst'; naive_solver.
|
|
|
- (* unpack *)
|
|
|
apply IHbig_step2. apply is_closed_do_subst'; naive_solver.
|
|
|
Qed.
|