Commit e462ec11 authored by Jacques-Henri Jourdan's avatar Jacques-Henri Jourdan

Copy-paste and customize heap_lang in this repo.

Side effects : use a specific Val constructor for values (many simplifications), native machine integers.
parent ab4583c1
......@@ -103,7 +103,7 @@ Important modules are highlighted.
#### Generic translation and “tick”
The basic properties of the translation are proven in `Translation.v` (for
example, `translation_subst` and `translation_of_val`).
example, `translation_subst`).
In `Simulation.v`:
......
-Q theories iris_time
-arg -w -arg -notation-overridden
-arg -w -arg -notation-overridden,-redundant-canonical-projection
theories/heap_lang/lang.v
theories/heap_lang/adequacy.v
theories/heap_lang/lifting.v
theories/heap_lang/notation.v
theories/heap_lang/proofmode.v
theories/heap_lang/tactics.v
theories/heap_lang/lib/assert.v
theories/Auth_mnat.v
theories/Auth_nat.v
theories/MachineIntegers.v
theories/ClockIntegers.v
theories/Examples.v
theories/Misc.v
......
From iris.heap_lang Require Import proofmode notation.
From iris_time Require Import TimeReceipts MachineIntegers.
From iris_time.heap_lang Require Import proofmode notation.
From iris_time Require Import TimeReceipts.
From stdpp Require Import numbers.
Open Scope Z_scope.
......@@ -13,28 +13,32 @@ Section clock_int.
Context `{timeReceiptHeapG Σ}.
Context (nmax : nat).
Context `(nmax max_int).
Context `(nmax max_mach_int).
Definition is_clock_int (n : nat) : iProp Σ :=
TR n.
Definition is_clock_int (n : Z) : iProp Σ :=
(0 n TR (Z.to_nat n))%I.
(* Clock integers support addition, which consumes its arguments: *)
Lemma clock_int_add_spec n1 n2 :
Lemma clock_int_add_spec (n1 n2 : mach_int) :
TR_invariant nmax -
{{{ is_clock_int n1 is_clock_int n2 }}}
machine_int_add #n1 #n2
{{{ RET #(n1+n2) ; is_clock_int (n1+n2) }}}.
{{{ is_clock_int (`n1) is_clock_int (`n2) }}}
#n1 + #n2
{{{ H, RET #(LitMachInt ((`n1+`n2) H)) ; is_clock_int (`n1+`n2) }}}.
Proof.
iIntros "#Htrinv" (Φ) "!# (H1 & H2) Post".
iAssert (TR (n1+n2)) with "[H1 H2]" as "H" ; first by (rewrite TR_plus ; iFrame).
iDestruct (TR_lt_nmax with "Htrinv H") as ">(H & %)" ; first done.
wp_apply (machine_int_add_spec n1 n2 with "[] [H Post]") .
{
iPureIntro. unfold min_int in *. lia.
}
{
iNext ; iIntros "%". iApply "Post". iFrame "H".
}
iIntros "#Htrinv" (Φ) "!# ([% H1] & [% H2]) Post".
iAssert (TR (Z.to_nat (`n1+`n2))) with "[H1 H2]" as "H".
{ rewrite Z2Nat.inj_add // TR_plus. iFrame. }
iDestruct (TR_lt_nmax with "Htrinv H") as ">(H & Hnmax)" ; [done|].
iDestruct "Hnmax" as %Hnmax.
assert (`n1 + `n2 < max_mach_int).
{ rewrite -(Nat2Z.id nmax) in Hnmax. apply Z2Nat.inj_lt in Hnmax; lia. }
assert (bool_decide (mach_int_bounded (`n1 + `n2))).
{ apply bool_decide_pack. split; [|done].
(* FIXME : why isn't lia able to do this directly? *)
trans 0. unfold min_mach_int; lia. lia. }
wp_op.
{ by rewrite /bin_op_eval /= /to_mach_int /mach_int_bounded decide_left. }
iApply "Post". iIntros "{$H} /= !%". lia.
Qed.
End clock_int.
......@@ -48,54 +52,62 @@ Section snapclock_int.
Context `{timeReceiptHeapG Σ}.
Context (nmax : nat).
Context `(nmax max_int).
Context `(nmax max_mach_int).
Definition is_snapclock_int (n : nat) : iProp Σ :=
TRdup n.
Definition is_snapclock_int (n : Z) : iProp Σ :=
(0 n TRdup (Z.to_nat n))%I.
(* Snapclock integers are persistent (in particular they are duplicable): *)
Lemma snapclock_int_persistent (n : nat) :
Lemma snapclock_int_persistent (n : Z) :
Persistent (is_snapclock_int n).
Proof. exact _. Qed.
(* Snapclock integers support incrementation: *)
Lemma snapclock_int_incr_spec n1 :
Lemma snapclock_int_incr_spec (n1 : mach_int) :
TR_invariant nmax -
{{{ is_snapclock_int n1 }}}
tick #() ;; machine_int_add #n1 #1
{{{ RET #(n1+1) ; is_snapclock_int (n1+1) }}}.
{{{ is_snapclock_int (`n1) }}}
tick #() ;; #n1 + #mach_int_1
{{{ H, RET #(LitMachInt ((`n1+1) H)) ; is_snapclock_int (`n1+1) }}}.
Proof.
iIntros "#Htrinv" (Φ) "!# H1 Post".
iIntros "#Htrinv" (Φ) "!# [% H1] Post".
wp_apply (tick_spec_simple nmax #() with "Htrinv H1"). iIntros "(_ & H)".
iDestruct (TRdup_lt_nmax with "Htrinv H") as ">(H & %)" ; first done.
wp_seq.
wp_apply (machine_int_add_spec n1 1 with "[] [H Post]") .
{
iPureIntro. unfold min_int in *. lia.
}
{
iNext ; iIntros "%". iApply "Post". iFrame "H".
}
iDestruct (TRdup_lt_nmax with "Htrinv H") as ">(H & Hnmax)" ; first done.
iDestruct "Hnmax" as %Hnmax. wp_seq.
assert (`n1 + 1 < max_mach_int).
{ rewrite -(Nat2Z.id nmax) (_:1%nat = Z.to_nat 1) // -Z2Nat.inj_add // in Hnmax.
apply Z2Nat.inj_lt in Hnmax; lia. }
assert (bool_decide (mach_int_bounded (`n1 + 1))).
{ apply bool_decide_pack. split; [|done].
(* FIXME : why isn't lia able to do this directly? *)
trans 0. unfold min_mach_int; lia. lia. }
wp_op.
{ by rewrite /bin_op_eval /= /to_mach_int /mach_int_bounded decide_left. }
iApply "Post". iSplit. auto with lia.
by rewrite Z2Nat.inj_add //.
Qed.
(* Snapclock integers also support a limited form of addition: *)
Lemma snapclock_int_add_spec n1 n2 m :
Lemma snapclock_int_add_spec (n1 n2 : mach_int) (m : Z) :
TR_invariant nmax -
{{{ is_snapclock_int n1 is_snapclock_int n2
is_snapclock_int m n1+n2 m }}}
machine_int_add #n1 #n2
{{{ RET #(n1+n2) ; is_snapclock_int (n1+n2) }}}.
{{{ is_snapclock_int (`n1) is_snapclock_int (`n2)
is_snapclock_int m `n1+`n2 m }}}
#n1 + #n2
{{{ H, RET #(LitMachInt ((`n1+`n2) H)) ; is_snapclock_int (`n1+`n2) }}}.
Proof.
iIntros "#Htrinv" (Φ) "!# (_ & _ & Hm & %) Post".
iDestruct (TRdup_lt_nmax with "Htrinv Hm") as ">(Hm & %)" ; first done.
iDestruct (TRdup_weaken m (n1 + n2) with "Hm") as "H" ; first lia.
wp_apply (machine_int_add_spec n1 n2 with "[] [H Post]") .
{
iPureIntro. unfold min_int in *. lia.
}
{
iNext ; iIntros "%". iApply "Post". iFrame "H".
}
iIntros "#Htrinv" (Φ) "!# ([% _] & [% _] & [% Hm] & %) Post".
iDestruct (TRdup_lt_nmax with "Htrinv Hm") as ">(Hm & Hnmax)" ; first done.
iDestruct "Hnmax" as %Hnmax.
assert (m < max_mach_int).
{ rewrite -(Nat2Z.id nmax) in Hnmax. apply Z2Nat.inj_lt in Hnmax; lia. }
iDestruct (TRdup_weaken (Z.to_nat m) (Z.to_nat (`n1 + `n2)) with "Hm") as "H".
{ apply Z2Nat.inj_le; lia. }
assert (bool_decide (mach_int_bounded (`n1 + `n2))).
{ apply bool_decide_pack. split; [|lia].
(* FIXME : why isn't lia able to do this directly? *)
trans 0. unfold min_mach_int; lia. lia. }
wp_op.
{ by rewrite /bin_op_eval /= /to_mach_int /mach_int_bounded decide_left. }
iApply "Post". iSplit; [|done]. auto with lia.
Qed.
End snapclock_int.
(* code taken from the Iris tutorial *)
From iris.heap_lang Require Import proofmode notation.
From iris_time.heap_lang Require Import proofmode notation.
From iris.program_logic Require Import adequacy.
From iris_time Require Import TimeCredits Reduction.
......@@ -120,27 +120,23 @@ Proof.
Qed.
Lemma sum_list_translation_spec `{!timeCreditHeapG Σ} (l : list Z) (v : val) :
TC_invariant -
{{{ is_list_tr l v TC (3 + 10 * length l) }}} « sum_list v » {{{ RET #(sum_list_coq l) ; is_list_tr l v }}}.
{{{ is_list_tr l v TC (4 + 13 * length l) }}} « sum_list v » {{{ RET #(sum_list_coq l) ; is_list_tr l v }}}.
Proof.
iIntros "#Htickinv !#" (Φ) "[Hl Htc] Post".
iInduction l as [|x l] "IH" forall (v Φ).
- simpl.
rewrite !translation_of_val.
iDestruct "Hl" as %->.
wp_tick_rec. wp_tick_match.
by iApply "Post".
- replace (3 + 10 * length (x :: l))%nat with (13 + 10 * length l)%nat by (simpl ; lia).
simpl.
rewrite !translation_of_val. setoid_rewrite translation_of_val.
- replace (4 + 13 * length (x :: l))%nat with (17 + 13 * length l)%nat by (simpl ; lia).
iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
wp_tick_rec.
wp_tick_match.
wp_tick_rec. wp_tick_match.
wp_tick_load. wp_tick_proj. wp_tick_let.
wp_tick_load. wp_tick_proj. wp_tick_let.
iDestruct "Htc" as "[Htc1 Htc]".
wp_apply ("IH" with "Hl Htc"). iIntros "Hl".
wp_tick_op.
iApply "Post". eauto with iFrame.
iApply "Post". simpl. eauto with iFrame.
Qed.
Definition make_list : val :=
......@@ -162,37 +158,33 @@ Lemma make_list_spec `{!heapG Σ} (n : nat) :
Proof.
iIntros (Φ) "_ Post".
iInduction n as [|n'] "IH" forall (Φ) ; simpl.
- wp_rec. wp_op. wp_if.
- wp_rec. wp_op. wp_if. wp_inj.
by iApply "Post".
- wp_rec. wp_op. wp_if.
wp_op.
assert (Z.of_nat n' = Z.of_nat (S n') - 1) as Eq by lia ; simpl in Eq ; destruct Eq.
wp_apply "IH". iIntros (v') "Hl".
change (Z.pos $ Pos.of_succ_nat n') with (Z.of_nat $ S n').
wp_alloc p.
wp_alloc p. wp_inj.
iApply "Post". eauto with iFrame.
Qed.
Lemma make_list_translation_spec `{!timeCreditHeapG Σ} (n : nat) :
TC_invariant -
{{{ TC (3+5*n) }}} «make_list #n» {{{ v', RET v' ; is_list (make_list_coq n) v' }}}.
{{{ TC (4+7*n) }}} «make_list #n» {{{ v', RET v' ; is_list (make_list_coq n) v' }}}.
Proof.
iIntros "#Htickinv !#" (Φ) "Htc Post".
iInduction n as [|n'] "IH" forall (Φ).
- simpl.
rewrite !translation_of_val.
wp_tick_rec. wp_tick_op. wp_tick_if.
- wp_tick_rec. wp_tick_op. wp_tick_if. wp_tick_inj.
by iApply "Post".
- replace (3 + 5 * S n')%nat with (8 + 5 * n')%nat by lia.
simpl.
rewrite !translation_of_val.
- replace (4 + 7 * S n')%nat with (11 + 7 * n')%nat by lia.
wp_tick_rec. wp_tick_op. wp_tick_if.
wp_tick_op.
assert (Z.of_nat n' = Z.of_nat (S n') - 1) as Eq by lia ; simpl in Eq ; destruct Eq.
iDestruct "Htc" as "[Htc1 Htc]".
iDestruct "Htc" as "[? [? [? Htc]]]".
wp_apply ("IH" with "Htc"). iIntros (v') "Hl".
change (Z.pos $ Pos.of_succ_nat n') with (Z.of_nat $ S n').
wp_tick_alloc p.
iApply "Post". eauto with iFrame.
wp_tick_pair. wp_tick_alloc p. wp_tick_inj.
iApply "Post". simpl. eauto with iFrame.
Qed.
Definition prgm (n : nat) : expr :=
......@@ -236,18 +228,14 @@ Proof.
Qed.
Lemma prgm_translation_spec `{!timeCreditHeapG Σ} (n : nat) :
TC_invariant -
{{{ TC (6+15*n) }}} «prgm n» {{{ v, RET v ; v = #(n*(n+1)/2) }}}.
{{{ TC (8+20*n) }}} «prgm n» {{{ v, RET v ; v = #(n*(n+1)/2) }}}.
Proof.
iIntros "#Htickinv !#" (Φ) "Htc Post".
unfold prgm.
change « sum_list (make_list (LitV n)) » with ((tick «sum_list») «make_list #n»).
rewrite !translation_of_val.
replace (6+15*n)%nat with ((3+5*n) + (3+10*n))%nat by lia ;
replace (8+20*n)%nat with ((4+7*n) + (4+13*n))%nat by lia ;
rewrite TC_plus ; iDestruct "Htc" as "[Htc_make Htc_sum]".
unfold prgm. simpl_trans.
wp_apply (make_list_translation_spec with "Htickinv Htc_make"). iIntros (v) "Hl".
iDestruct (is_list_translation with "Hl") as "[Hl ->]".
rewrite - !translation_of_val.
change (« sum_list » (tick « v »)) with « sum_list v ».
wp_apply (sum_list_translation_spec with "Htickinv [Hl Htc_sum]"). {
rewrite - is_list_tr_is_list_translation.
erewrite length_make_list_coq. iFrame.
......@@ -257,11 +245,10 @@ Qed.
Lemma prgm_timed_spec (n : nat) (σ : state) `{!timeCreditHeapPreG Σ} :
adequate NotStuck (prgm n) σ (λ v _, v = #(n*(n+1)/2))
bounded_time (prgm n) σ (6 + 15 * n)%nat.
bounded_time (prgm n) σ (8 + 20 * n)%nat.
Proof.
apply (spec_tctranslation__adequate_and_bounded' (Σ:=Σ)).
- by intros _ ->.
- rewrite !andb_True ; repeat split ; apply is_closed_of_val.
- intros HtcHeapG. apply prgm_translation_spec.
- assumption.
Qed.
From iris.heap_lang Require Import proofmode notation.
Open Scope Z_scope.
Definition w : nat := 64.
Definition max_int : Z := 1 (w-1).
Definition min_int : Z := - max_int.
Definition max_uint : Z := 2 * max_int.
(*
* Bare machine integers can overflow.
*)
Section machine_int.
Context `{heapG Σ}.
Definition is_machine_int (n : Z) : iProp Σ :=
min_int n < max_int%I.
Definition machine_int_add : val :=
λ: "x" "y",
("x" + "y" + #max_int) `rem` #max_uint - #max_int.
(* Machine addition does not overflow when some inequality is met: *)
Lemma machine_int_add_spec n1 n2 :
{{{ is_machine_int n1 is_machine_int n2 min_int n1+n2 < max_int }}}
machine_int_add #n1 #n2
{{{ RET #(n1+n2) ; is_machine_int (n1+n2) }}}.
Proof.
iIntros (Φ) "(_ & _ & %) Post". repeat (wp_pure _).
(* boring arithmetic proof: *)
assert ((n1 + n2 + max_int) `rem` max_uint - max_int = n1 + n2) as ->. {
assert ((n1 + n2 + max_int) `rem` max_uint = n1 + n2 + max_int). {
apply Z.rem_small. unfold min_int, max_uint in *. lia.
}
lia.
}
by iApply "Post".
Qed.
End machine_int.
From iris.heap_lang Require Import lang notation.
From iris.heap_lang Require Import adequacy.
From iris_time.heap_lang Require Import lang notation.
From iris_time.heap_lang Require Import adequacy.
From stdpp Require Import relations fin_maps gmap.
From iris_time Require Import Misc Tactics.
......@@ -20,18 +20,19 @@ Implicit Type m n : nat.
Section Reduction.
Definition bounded_time e σ m : Prop :=
t2 σ2 n, nsteps step n ([e], σ) (t2, σ2) (n m)%nat.
t2 σ2 n, nsteps erased_step n ([e], σ) (t2, σ2) (n m)%nat.
Inductive prim_exec (e1 : expr) (σ1 : state) : expr state list expr Prop :=
| prim_exec_nil :
prim_exec e1 σ1 e1 σ1 []
| prim_exec_cons (e2 : expr) (σ2 : state) (efs2 : list expr) e3 σ3 efs3 :
prim_step e1 σ1 e2 σ2 efs2
| prim_exec_cons (κ : list Empty_set)
(e2 : expr) (σ2 : state) (efs2 : list expr) e3 σ3 efs3 :
prim_step e1 σ1 κ e2 σ2 efs2
prim_exec e2 σ2 e3 σ3 efs3
prim_exec e1 σ1 e3 σ3 (efs2 ++ efs3).
Lemma prim_exec_cons_nofork e1 σ1 e2 σ2 e3 σ3 efs3 :
prim_step e1 σ1 e2 σ2 []
Lemma prim_exec_cons_nofork e1 σ1 κ e2 σ2 e3 σ3 efs3 :
prim_step e1 σ1 κ e2 σ2 []
prim_exec e2 σ2 e3 σ3 efs3
prim_exec e1 σ1 e3 σ3 efs3.
Proof.
......@@ -54,8 +55,8 @@ Section Reduction.
intros. change efs3 with ([] ++ efs3). by eapply prim_exec_transitive.
Qed.
Lemma thread_pool_grows_after_step t1 σ1 t2 σ2 :
step (t1, σ1) (t2, σ2)
Lemma thread_pool_grows_after_step t1 σ1 κ t2 σ2 :
step (t1, σ1) κ (t2, σ2)
(length t1 length t2)%nat.
Proof.
intros [e1 σ1_ e2 σ2_ efs t t' E1 E2 Hstep] ;
......@@ -63,14 +64,14 @@ Section Reduction.
repeat rewrite ? app_length ? cons_length. lia.
Qed.
Lemma thread_pool_grows_after_exec t1 σ1 t2 σ2 :
rtc step (t1, σ1) (t2, σ2)
rtc erased_step (t1, σ1) (t2, σ2)
(length t1 length t2)%nat.
Proof.
make_eq (t1, σ1) as config1 E1.
make_eq (t2, σ2) as config2 E2.
intros Hsteps.
revert t1 σ1 E1 ;
induction Hsteps as [ config | config1 (t3, σ3) config2 Hstep _ IHsteps ] ;
induction Hsteps as [ config | config1 (t3, σ3) config2 [κ Hstep] _ IHsteps ] ;
intros t1 σ1 E1.
- destruct E2 ; injection E1 as -> ->.
done.
......@@ -79,8 +80,8 @@ Section Reduction.
+ by eapply thread_pool_grows_after_step.
+ by eapply IHsteps.
Qed.
Lemma thread_pool_is_cons_after_step t1 σ1 t2 σ2 :
step (t1, σ1) (t2, σ2)
Lemma thread_pool_is_cons_after_step t1 σ1 κ t2 σ2 :
step (t1, σ1) κ (t2, σ2)
e2 t2', t2 = e2 :: t2'.
Proof.
intros Hstep.
......@@ -94,7 +95,7 @@ Section Reduction.
- eauto.
Qed.
Lemma thread_pool_is_cons_after_exec e1 t1' σ1 t2 σ2 :
rtc step (e1 :: t1', σ1) (t2, σ2)
rtc erased_step (e1 :: t1', σ1) (t2, σ2)
e2 t2', t2 = e2 :: t2'.
Proof.
destruct t2.
......@@ -102,10 +103,10 @@ Section Reduction.
- eauto.
Qed.
Lemma step_insert_in_thread_pool (n : nat) t t1 σ1 t2 σ2 :
Lemma step_insert_in_thread_pool (n : nat) t t1 σ1 κ t2 σ2 :
(n length t1)%nat
step (t1, σ1) (t2, σ2)
step (take n t1 ++ t ++ drop n t1, σ1) (take n t2 ++ t ++ drop n t2, σ2).
step (t1, σ1) κ (t2, σ2)
step (take n t1 ++ t ++ drop n t1, σ1) κ (take n t2 ++ t ++ drop n t2, σ2).
Proof.
intros I Hstep.
destruct Hstep as [e1 σ1_ e2 σ2_ efs ta tb E1 E2 Hprimstep] ; simpl in * ;
......@@ -129,26 +130,26 @@ Section Reduction.
Qed.
Lemma exec_insert_in_thread_pool (n : nat) t t1 σ1 t2 σ2 :
(n length t1)%nat
rtc step (t1, σ1) (t2, σ2)
rtc step (take n t1 ++ t ++ drop n t1, σ1) (take n t2 ++ t ++ drop n t2, σ2).
rtc erased_step (t1, σ1) (t2, σ2)
rtc erased_step (take n t1 ++ t ++ drop n t1, σ1) (take n t2 ++ t ++ drop n t2, σ2).
Proof.
make_eq (t1, σ1) as config1 E1.
make_eq (t2, σ2) as config2 E2.
intros I H.
revert t1 σ1 E1 I ;
induction H as [ config | config1 (t3, σ3) config2 Hstep _ IHsteps ] ;
induction H as [ config | config1 (t3, σ3) config2 [κ Hstep] _ IHsteps ] ;
intros t1 σ1 E1 I.
- destruct E2 ; injection E1 as -> ->.
apply rtc_refl.
- destruct E2, E1.
eapply rtc_l.
+ by eapply step_insert_in_thread_pool.
+ exists κ. by eapply step_insert_in_thread_pool.
+ by eapply IHsteps, le_trans, thread_pool_grows_after_step.
Qed.
Lemma exec_frame_thread_pool t1 σ1 t2 σ2 ta tb :
rtc step (t1, σ1) (t2, σ2)
rtc erased_step (t1, σ1) (t2, σ2)
let n := length t1 in
rtc step (ta ++ t1 ++ tb, σ1) (ta ++ take n t2 ++ tb ++ drop n t2, σ2).
rtc erased_step (ta ++ t1 ++ tb, σ1) (ta ++ take n t2 ++ tb ++ drop n t2, σ2).
Proof.
intros Hsteps n.
replace (t1 ++ tb) with (take n t1 ++ tb ++ drop n t1)
......@@ -156,29 +157,30 @@ Section Reduction.
apply (exec_insert_in_thread_pool 0 ta), (exec_insert_in_thread_pool n tb) ; first lia ; done.
Qed.
Lemma exec_frame_singleton_thread_pool e1 σ1 e2 t2 σ2 t t' :
rtc step ([e1], σ1) (e2 :: t2, σ2)
rtc step (t ++ e1 :: t', σ1) (t ++ e2 :: t' ++ t2, σ2).
rtc erased_step ([e1], σ1) (e2 :: t2, σ2)
rtc erased_step (t ++ e1 :: t', σ1) (t ++ e2 :: t' ++ t2, σ2).
Proof.
change (e1 :: t') with ([e1] ++ t').
apply exec_frame_thread_pool.
Qed.
Lemma prim_step_step e1 σ1 e2 σ2 efs :
prim_step e1 σ1 e2 σ2 efs
step ([e1], σ1) (e2 :: efs, σ2).
Lemma prim_step_step e1 σ1 κ e2 σ2 efs :
prim_step e1 σ1 κ e2 σ2 efs
step ([e1], σ1) κ (e2 :: efs, σ2).
Proof.
intros. by eapply step_atomic with _ _ _ _ _ [] [].
Qed.
Lemma prim_exec_exec e1 σ1 e2 σ2 efs :
prim_exec e1 σ1 e2 σ2 efs
rtc step ([e1], σ1) (e2 :: efs, σ2).
rtc erased_step ([e1], σ1) (e2 :: efs, σ2).
Proof.
unfold erased_step.
induction 1 ; econstructor ; eauto using prim_step_step, (exec_frame_singleton_thread_pool _ _ _ _ _ []).
Qed.
Lemma prim_step_fill K e1 σ1 e2 σ2 efs :
prim_step e1 σ1 e2 σ2 efs
prim_step (fill K e1) σ1 (fill K e2) σ2 efs.
Lemma prim_step_fill K e1 σ1 κ e2 σ2 efs :
prim_step e1 σ1 κ e2 σ2 efs
prim_step (fill K e1) σ1 κ (fill K e2) σ2 efs.
Proof.
intros [ K' e1' e2' -> -> Hheadstep ].
rewrite - 2! fill_app.
......@@ -199,9 +201,9 @@ Section Reduction.
intros <- <-. apply prim_exec_fill.
Qed.
Lemma step_fill K e1 t1' σ1 e2 t2' σ2 :
step (e1 :: t1', σ1) (e2 :: t2', σ2)
step (fill K e1 :: t1', σ1) (fill K e2 :: t2', σ2).
Lemma step_fill K e1 t1' σ1 κ e2 t2' σ2 :
step (e1 :: t1', σ1) κ (e2 :: t2', σ2)
step (fill K e1 :: t1', σ1) κ (fill K e2 :: t2', σ2).
Proof.
intros Hstep.
destruct Hstep as [ e1' ? e2' ? efs ta tb E1 E2 ] ;
......@@ -211,14 +213,14 @@ Section Reduction.
- by eapply step_atomic with _ _ _ _ _ (fill K e2 :: ta) tb.
Qed.
Lemma exec_fill K e1 t1' σ1 e2 t2' σ2 :
rtc step (e1 :: t1', σ1) (e2 :: t2', σ2)
rtc step (fill K e1 :: t1', σ1) (fill K e2 :: t2', σ2).
rtc erased_step (e1 :: t1', σ1) (e2 :: t2', σ2)
rtc erased_step (fill K e1 :: t1', σ1) (fill K e2 :: t2', σ2).
Proof.
make_eq (e1 :: t1', σ1) as config1 E1.
make_eq (e2 :: t2', σ2) as config2 E2.
intros Hsteps.
revert e1 t1' σ1 E1 ;
induction Hsteps as [ config | config1 (t3, σ3) config2 Hstep _ IHsteps ] ;
induction Hsteps as [ config | config1 (t3, σ3) config2 [κ Hstep] _ IHsteps ] ;
intros e1 t1' σ1 E1.
- destruct E2 ; injection E1 as -> -> ->.
apply rtc_refl.
......@@ -226,7 +228,7 @@ Section Reduction.
assert ( e3 t3', t3 = e3 :: t3') as (e3 & t3' & ->)
by by eapply thread_pool_is_cons_after_step.
eapply rtc_l.
+ by apply step_fill.
+ exists κ. by apply step_fill.
+ by apply IHsteps.
Qed.
......@@ -234,126 +236,38 @@ Section Reduction.
reducible e σ
reducible (fill K e) σ.
Proof.
intros (e' & σ' & efs & Hstep).
eexists _, _, _.
intros (κ & e' & σ' & efs & Hstep).
eexists _, _, _, _.
by apply prim_step_fill.
Qed.
End Reduction.
(*
* Closed expressions
*)
Section Closed.
Lemma is_closed_fill_inv xs K e :
is_closed xs (fill K e)
is_closed xs e.
Proof.
replace K with (rev (rev K)) by apply rev_involutive.
induction (rev K) as [ | [] revK' ] ; first done ;
rewrite /= fill_app /= ; naive_solver.
Qed.
Lemma is_closed_fill xs K e :
is_closed xs e
( e0, is_closed xs (fill K e0))
is_closed xs (fill K e).
Proof.
intros He [e0 HK] ; revert HK.
replace K with (rev (rev K)) by apply rev_involutive.
induction (rev K) as [ | [] revK' ] ; first done ;
rewrite /= !fill_app /= ; naive_solver.
Qed.
Lemma is_closed_head_step xs e1 σ1 e2 σ2 efs :
is_closed xs e1
head_step e1 σ1 e2 σ2 efs
is_closed xs e2 Forall (is_closed xs) efs.
Proof.
intros Hclosed Hstep.
destruct Hstep as
[ (* BetaS *) f x e1 e2 v2 e' σ Hval_e2 Hclosed_e1 ->
| | | | | | | | | | | | | | | ] ;
(split ; last auto) ;
rewrite_into_values ;
try (by apply is_closed_of_val) ;
try naive_solver.
(* BetaS f x e1 e2 v2 e' σ : *)
- apply is_closed_do_subst', is_closed_do_subst' ; try naive_solver. by apply is_closed_of_val.
Qed.
Lemma is_closed_prim_step xs e1 σ1 e2 σ2 efs :
is_closed xs e1
prim_step e1 σ1 e2 σ2 efs
is_closed xs e2 Forall (is_closed xs) efs.
Proof.
intros HKe1' [K e1' e2' -> -> Hstep] ; simpl in *.
eapply is_closed_head_step in Hstep as [??] ; last by eapply is_closed_fill_inv.
eauto using is_closed_fill.
Qed.
Lemma is_closed_step xs t1 σ1 t2 σ2 :
Forall (is_closed xs) t1
step (t1, σ1) (t2, σ2)
Forall (is_closed xs) t2.
Proof.
intros Hclosed Hstep.
destruct Hstep as [e1 σ1_ e2 σ2_ efs tl tr E1 E2 Hstep] ;
injection E1 as -> <- ; injection E2 as -> <- ;
simpl.
rewrite -> ? Forall_app, ? Forall_cons in Hclosed. repeat (destruct Hclosed as [? Hclosed]).
eapply is_closed_prim_step in Hstep as [??] ; last eassumption.
repeat (rewrite ? Forall_app ? Forall_cons ; repeat split) ; assumption.
Qed.
Lemma is_closed_exec xs t1 σ1 t2 σ2 :
Forall (is_closed xs) t1
rtc step (t1, σ1) (t2, σ2)
Forall (is_closed xs) t2.
Proof.
make_eq (t1, σ1) as config1 E1.
make_eq (t2, σ2) as config2 E2.
intros Hclosed Hsteps.
revert t1 σ1 E1 Hclosed ;
induction Hsteps as [ config | config1 (t3, σ3) config2 Hstep _ IHsteps ] ;
intros t1 σ1 E1 Hclosed.
- destruct E2 ; injection E1 as -> _.
done.
- destruct E2, E1.
eapply is_closed_step in Hstep ; last done.
by eapply IHsteps.
Qed.
End Closed.
(*
* Fresh locations
*)
Section FreshLocation.
Lemma loc_fresh_in_dom_head_step e1 σ1 e2 σ2 efs :
Lemma loc_fresh_in_dom_head_step e1 σ1 κ e2 σ2 efs :
σ2 !! = None
head_step e1 σ1 e2 σ2 efs
head_step e1 σ1 κ e2 σ2 efs
σ1 !! = None.
Proof.
intros H H ; destruct H ; try done ;
by apply lookup_insert_None in H as [ H _ ].
Qed.
Lemma loc_fresh_in_dom_prim_step e1 σ1 e2 σ2 efs :
Lemma loc_fresh_in_dom_prim_step e1 σ1 κ e2 σ2 efs :
σ2 !! = None
prim_step e1 σ1 e2 σ2 efs
prim_step e1 σ1 κ e2 σ2 efs
σ1 !! = None.
Proof.
intros H H ; destruct H ;
by eapply loc_fresh_in_dom_head_step.
Qed.
Lemma loc_fresh_in_dom_step t1 σ1 t2 σ2 :
Lemma loc_fresh_in_dom_step t1 σ1 κ t2 σ2 :
σ2 !! = None
step (t1, σ1) (t2, σ2)
step (t1, σ1<