Commit 0d4e3210 authored by Robbert's avatar Robbert

Merge branch 'robbert/locations_meta' into 'master'

Add ghost data to locations

See merge request iris/iris!249
parents 31bf88ff 48628616
Pipeline #17321 failed with stage
in 11 minutes and 58 seconds
......@@ -49,6 +49,7 @@ Changes in heap_lang:
"administrative" reductions in the operational semantics of the language.
* heap_lang now has support for allocating, accessing and reasoning about arrays
(continuously allocated regions of memory).
* One can now assign "meta" data to heap_lang locations.
Changes in Coq:
......
......@@ -36,6 +36,7 @@ theories/algebra/coPset.v
theories/algebra/deprecated.v
theories/algebra/proofmode_classes.v
theories/algebra/ufrac.v
theories/algebra/namespace_map.v
theories/bi/notation.v
theories/bi/interface.v
theories/bi/derived_connectives.v
......
This diff is collapsed.
This diff is collapsed.
......@@ -32,7 +32,7 @@ Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
Notation "l ↦ -" := (l {1} -)%I (at level 20) : bi_scope.
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)
(at level 20, format "l ↦∗ vs") : bi_scope.
......@@ -218,7 +218,7 @@ Lemma array_singleton l v : l ↦∗ [v] ⊣⊢ l ↦ v.
Proof. by rewrite /array /= right_id loc_add_0. Qed.
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.
rewrite /array big_sepL_app.
setoid_rewrite Nat2Z.inj_add.
......@@ -234,70 +234,82 @@ Proof.
Qed.
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.
iIntros "Hvs".
iInduction vs as [|v vs] "IH" forall (l); simpl.
{ by rewrite big_opM_empty /array big_opL_nil. }
iIntros "Hvs". iInduction vs as [|v vs] "IH" forall (l); simpl.
{ by rewrite /array. }
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;
apply loc_add_inj in Hjl; lia. }
rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
rewrite array_cons.
rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]".
by iApply "IH".
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 *)
Lemma wp_allocN s E v n :
0 < n
{{{ 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.
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.
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.
rewrite replicate_length Z2Nat.id; auto with lia. }
iModIntro; iSplit; auto.
iFrame. iApply "HΦ".
by iApply heap_array_to_array.
iModIntro; iSplit; first done. iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
- by iApply heap_array_to_array.
- iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed.
Lemma twp_allocN s E v n :
0 < n
[[{ 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.
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 (κ 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.
rewrite replicate_length Z2Nat.id; auto with lia. }
iModIntro; iSplit; auto.
iFrame; iSplit; auto. iApply "HΦ".
by iApply heap_array_to_array.
iModIntro; do 2 (iSplit; first done). iFrame "Hσ Hκs". iApply "HΦ". iSplitL "Hl".
- by iApply heap_array_to_array.
- iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed.
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.
iIntros (Φ) "_ HΦ".
iApply wp_allocN; auto with lia.
iNext; iIntros (l) "H".
iApply "HΦ".
by rewrite array_singleton.
iIntros (Φ) "_ HΦ". iApply wp_allocN; auto with lia.
iIntros "!>" (l) "/= (? & ? & _)".
rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
Qed.
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.
iIntros (Φ) "_ HΦ".
iApply twp_allocN; auto with lia.
iIntros (l) "H".
iApply "HΦ".
by rewrite array_singleton.
iIntros (Φ) "_ HΦ". iApply twp_allocN; auto with lia.
iIntros (l) "/= (? & ? & _)".
rewrite array_singleton loc_add_0. iApply "HΦ"; iFrame.
Qed.
Lemma wp_load s E l q v :
......
......@@ -189,7 +189,7 @@ Proof.
rewrite -wp_bind. eapply wand_apply; first exact: wp_allocN.
rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
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.
Lemma tac_twp_allocN Δ s E j K v n Φ :
0 < n
......@@ -203,7 +203,7 @@ Proof.
rewrite -twp_bind. eapply wand_apply; first exact: twp_allocN.
rewrite left_id. apply forall_intro=> l.
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.
Lemma tac_wp_alloc Δ Δ' s E j K v Φ :
......@@ -217,7 +217,7 @@ Proof.
rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc.
rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
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.
Lemma tac_twp_alloc Δ s E j K v Φ :
( l, Δ',
......@@ -229,7 +229,7 @@ Proof.
rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc.
rewrite left_id. apply forall_intro=> l.
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.
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