Commit a225790a authored by Robbert Krebbers's avatar Robbert Krebbers

Attach ghost data to locations.

parent 31bf88ff
This diff is collapsed.
...@@ -32,7 +32,7 @@ Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I ...@@ -32,7 +32,7 @@ Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
Notation "l ↦ -" := (l {1} -)%I (at level 20) : bi_scope. Notation "l ↦ -" := (l {1} -)%I (at level 20) : bi_scope.
Definition array `{!heapG Σ} (l : loc) (vs : list val) : iProp Σ := Definition array `{!heapG Σ} (l : loc) (vs : list val) : iProp Σ :=
([ list] i v vs, loc_add l i v)%I. ([ list] i v vs, (l + i) v)%I.
Notation "l ↦∗ vs" := (array l vs) Notation "l ↦∗ vs" := (array l vs)
(at level 20, format "l ↦∗ vs") : bi_scope. (at level 20, format "l ↦∗ vs") : bi_scope.
...@@ -218,7 +218,7 @@ Lemma array_singleton l v : l ↦∗ [v] ⊣⊢ l ↦ v. ...@@ -218,7 +218,7 @@ Lemma array_singleton l v : l ↦∗ [v] ⊣⊢ l ↦ v.
Proof. by rewrite /array /= right_id loc_add_0. Qed. Proof. by rewrite /array /= right_id loc_add_0. Qed.
Lemma array_app l vs ws : Lemma array_app l vs ws :
l ↦∗ (vs ++ ws) l ↦∗ vs (loc_add l (length vs)) ↦∗ ws. l ↦∗ (vs ++ ws) l ↦∗ vs (l + length vs) ↦∗ ws.
Proof. Proof.
rewrite /array big_sepL_app. rewrite /array big_sepL_app.
setoid_rewrite Nat2Z.inj_add. setoid_rewrite Nat2Z.inj_add.
...@@ -234,70 +234,82 @@ Proof. ...@@ -234,70 +234,82 @@ Proof.
Qed. Qed.
Lemma heap_array_to_array l vs : Lemma heap_array_to_array l vs :
([ map] i v heap_array l vs, i v)%I - l ↦∗ vs. ([ map] l' v heap_array l vs, l' v) - l ↦∗ vs.
Proof. Proof.
iIntros "Hvs". iIntros "Hvs". iInduction vs as [|v vs] "IH" forall (l); simpl.
iInduction vs as [|v vs] "IH" forall (l); simpl. { by rewrite /array. }
{ by rewrite big_opM_empty /array big_opL_nil. }
rewrite big_opM_union; last first. rewrite big_opM_union; last first.
{ apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _]. { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
intros (j&?&Hjl&_)%heap_array_lookup. intros (j&?&Hjl&_)%heap_array_lookup.
rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl; rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
apply loc_add_inj in Hjl; lia. }
rewrite array_cons. rewrite array_cons.
rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]".
by iApply "IH". by iApply "IH".
Qed. Qed.
Lemma heap_array_to_seq_meta l vs n :
length vs = n
([ map] l' _ heap_array l vs, meta_token l') -
[ list] i seq 0 n, meta_token (l + (i : nat)).
Proof.
iIntros (<-) "Hvs". iInduction vs as [|v vs] "IH" forall (l)=> //=.
rewrite big_opM_union; last first.
{ apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
intros (j&?&Hjl&_)%heap_array_lookup.
rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
rewrite loc_add_0 -fmap_seq big_sepL_fmap.
setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
setoid_rewrite <-loc_add_assoc.
rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
Qed.
(** Heap *) (** Heap *)
Lemma wp_allocN s E v n : Lemma wp_allocN s E v n :
0 < n 0 < n
{{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
{{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v }}}. {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v
[ list] i seq 0 (Z.to_nat n), meta_token (l + (i : nat)) }}}.
Proof. Proof.
iIntros (Hn Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (Hn Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs k) "[Hσ Hκs] !>"; iSplit; first by destruct n; auto with lia. iIntros (σ1 κ κs k) "[Hσ Hκs] !>"; iSplit; first by auto with lia.
iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_alloc_gen with "Hσ") as "[Hσ Hl]". iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
{ apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto. { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
rewrite replicate_length Z2Nat.id; auto with lia. } rewrite replicate_length Z2Nat.id; auto with lia. }
iModIntro; iSplit; auto. iModIntro; iSplit; first done. iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
iFrame. iApply "HΦ". - by iApply heap_array_to_array.
by iApply heap_array_to_array. - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed. Qed.
Lemma twp_allocN s E v n : Lemma twp_allocN s E v n :
0 < n 0 < n
[[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
[[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v }]]. [[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v
[ list] i seq 0 (Z.to_nat n), meta_token (l + (i : nat)) }]].
Proof. Proof.
iIntros (Hn Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; auto. iIntros (Hn Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs k) "[Hσ Hκs] !>"; iSplit; first by destruct n; auto with lia. iIntros (σ1 κs k) "[Hσ Hκs] !>"; iSplit; first by destruct n; auto with lia.
iIntros (κ v2 σ2 efs Hstep); inv_head_step. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_alloc_gen with "Hσ") as "[Hσ Hl]". iMod (@gen_heap_alloc_gen with "Hσ") as "(Hσ & Hl & Hm)".
{ apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto. { apply (heap_array_map_disjoint _ l (replicate (Z.to_nat n) v)); eauto.
rewrite replicate_length Z2Nat.id; auto with lia. } rewrite replicate_length Z2Nat.id; auto with lia. }
iModIntro; iSplit; auto. iModIntro; do 2 (iSplit; first done). iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
iFrame; iSplit; auto. iApply "HΦ". - by iApply heap_array_to_array.
by iApply heap_array_to_array. - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed. Qed.
Lemma wp_alloc s E v : Lemma wp_alloc s E v :
{{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l v }}}. {{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l v meta_token l }}}.
Proof. Proof.
iIntros (Φ) "_ HΦ". iIntros (Φ) "_ HΦ". iApply wp_allocN; auto with lia.
iApply wp_allocN; auto with lia. iIntros "!>" (l) "/= (? & ? & _)".
iNext; iIntros (l) "H". rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
iApply "HΦ".
by rewrite array_singleton.
Qed. Qed.
Lemma twp_alloc s E v : Lemma twp_alloc s E v :
[[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l v }]]. [[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l v meta_token l }]].
Proof. Proof.
iIntros (Φ) "_ HΦ". iIntros (Φ) "_ HΦ". iApply twp_allocN; auto with lia.
iApply twp_allocN; auto with lia. iIntros (l) "/= (? & ? & _)".
iIntros (l) "H". rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
iApply "HΦ".
by rewrite array_singleton.
Qed. Qed.
Lemma wp_load s E l q v : Lemma wp_load s E l q v :
......
...@@ -189,7 +189,7 @@ Proof. ...@@ -189,7 +189,7 @@ Proof.
rewrite -wp_bind. eapply wand_apply; first exact: wp_allocN. rewrite -wp_bind. eapply wand_apply; first exact: wp_allocN.
rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l. rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl. destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
by rewrite right_id HΔ'. apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
Qed. Qed.
Lemma tac_twp_allocN Δ s E j K v n Φ : Lemma tac_twp_allocN Δ s E j K v n Φ :
0 < n 0 < n
...@@ -203,7 +203,7 @@ Proof. ...@@ -203,7 +203,7 @@ Proof.
rewrite -twp_bind. eapply wand_apply; first exact: twp_allocN. rewrite -twp_bind. eapply wand_apply; first exact: twp_allocN.
rewrite left_id. apply forall_intro=> l. rewrite left_id. apply forall_intro=> l.
destruct (HΔ l) as (Δ'&?&HΔ'). rewrite envs_app_sound //; simpl. destruct (HΔ l) as (Δ'&?&HΔ'). rewrite envs_app_sound //; simpl.
by rewrite right_id HΔ'. apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
Qed. Qed.
Lemma tac_wp_alloc Δ Δ' s E j K v Φ : Lemma tac_wp_alloc Δ Δ' s E j K v Φ :
...@@ -217,7 +217,7 @@ Proof. ...@@ -217,7 +217,7 @@ Proof.
rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc. rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc.
rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l. rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl. destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
by rewrite right_id HΔ'. apply wand_intro_l. by rewrite (sep_elim_l (l v)%I) right_id wand_elim_r.
Qed. Qed.
Lemma tac_twp_alloc Δ s E j K v Φ : Lemma tac_twp_alloc Δ s E j K v Φ :
( l, Δ', ( l, Δ',
...@@ -229,7 +229,7 @@ Proof. ...@@ -229,7 +229,7 @@ Proof.
rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc. rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc.
rewrite left_id. apply forall_intro=> l. rewrite left_id. apply forall_intro=> l.
destruct (HΔ l) as (Δ'&?&HΔ'). rewrite envs_app_sound //; simpl. destruct (HΔ l) as (Δ'&?&HΔ'). rewrite envs_app_sound //; simpl.
by rewrite right_id HΔ'. apply wand_intro_l. by rewrite (sep_elim_l (l v)%I) right_id wand_elim_r.
Qed. Qed.
Lemma tac_wp_load Δ Δ' s E i K l q v Φ : Lemma tac_wp_load Δ Δ' s E i K l q v Φ :
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment