Section permMapDefs.
Definition empty_map : access_map :=
(fun z => None, Maps.PTree.empty (Z -> option permission)).
intros. unfold empty_map, Maps.PMap.get.
rewrite Maps.PTree.gempty; reflexivity.
Qed.
Definition permission_at (m : mem) (b : block) (ofs : Z) (k : perm_kind) :=
Maps.PMap.get b (Mem.mem_access m) ofs k.
(** Coherence between permissions. This is used for the relation between data and lock permissions*)
(** Note: p1 should be data permission and p2 lock permission*)
Definition perm_coh (p1 p2 : option permission) :=
match p1 with
| Some Freeable | Some Writable | Some Readable =>
match p2 with
| None => True
| _ => False
end
| Some Nonempty | None =>
match p2 with
| Some Freeable => False
| _ => True
end
end.
destruct res; simpl; auto.
- apply perm_coh_empty_1.
- destruct k; try apply perm_coh_empty_1; simpl.
destruct (perm_of_sh (Share.glb Share.Rsh sh)) eqn: ?; auto.
destruct p0; auto.
eapply perm_of_glb_not_Freeable; eauto.
Qed.
Definition permMapCoherence (pmap1 pmap2 : access_map) :=
forall b ofs, perm_coh (pmap1 !! b ofs) (pmap2 !! b ofs).
intros r H b ofs.
rewrite empty_map_spec.
specialize (H b ofs).
apply perm_coh_empty_2; assumption.
Qed.
(* Some None represents the empty permission. None is used for permissions that conflict/race. *)
Definition perm_union (p1 p2 : option permission) : option (option permission) :=
match p1,p2 with
| None, _ => Some p2
| _, None => Some p1
| Some p1', Some p2' =>
match p1', p2' with
| Freeable, _ => None
| _, Freeable => None
| Nonempty, _ => Some p2
| _, Nonempty => Some p1
| Writable, _ => None
| _, Writable => None
| Readable, Readable => Some (Some Readable)
end
end.
Inductive not_racy : option permission -> Prop :=
| empty : not_racy None.
Inductive racy : option permission -> Prop :=
| freeable : racy (Some Freeable).
Definition perm_max (p1 p2 : option permission) : option permission :=
match p1,p2 with
| Some Freeable, _ => p1
| _, Some Freeable => p2
| Some Writable, _ => p1
| _, Some Writable => p2
| Some Readable, _ => p1
| _, Some Readable => p2
| Some Nonempty, _ => p1
| _, Some Nonempty => p2
| None, None => None
end.
intros a b c H1 H2.
destruct a, b; try solve[inversion H2];
try solve[exists c; reflexivity].
simpl in H2.
destruct H1 as [k H1].
inversion H2; subst.
- exists k; assumption.
- destruct c; inversion H1.
exists (Some p0); reflexivity.
- destruct c; inversion H1.
destruct p; inversion H0.
exists (Some Readable); reflexivity.
- exists (Some Readable); reflexivity.
- destruct c; inversion H1;
try solve[exists (Some Nonempty); reflexivity].
destruct p; inversion H0; try(destruct p0; inversion H3);
try solve[exists (Some Nonempty); reflexivity];
try solve[exists (Some Readable); reflexivity];
try solve[exists (Some Writable); reflexivity].
Qed.
(* Lemma join_sh_permDisjoint: forall rsh1 rsh2 rsh3 (sh1 sh2 sh3: pshare), join rsh1 rsh2 rsh3 -> join sh1 sh2 sh3 -> permDisjoint (perm_of_sh (Share.glb Share.Rsh sh1))) (perm_of_sh (Share.glb Share.Rsh sh1))). *)
(*The new version of the above*)
Ltac if_simpl:=
repeat match goal with
| [ H: ?X = true |- context[if ?X then _ else _] ] => rewrite H; simpl
| [ H: ?X = false |- context[if ?X then _ else _] ] => rewrite H; simpl
| [ H: ?X = left _ |- context[match ?X with left _ => _ | right _ => _ end] ]=>
rewrite H; simpl
| [ H: ?X = right _ |- context[match ?X with left _ => _ | right _ => _ end] ]=>
rewrite H; simpl
| [ H: (@is_left _ _ ?X) = true |-
context [match ?X with left _ => _ | right _ => _ end ]] => destruct X; inversion H
| [ H: (@is_left _ _ ?X) = false |-
context [match ?X with left _ => _ | right _ => _ end ]] => destruct X; inversion H
end.
Ltac permDisj_solve:= eexists; simpl; reflexivity.
Ltac joins_sh_contradiction_onside:=
match goal with
| [ H: joins ?sh1 ?sh2,
W1: writable0_share ?sh1,
W2: writable0_share ?sh2 |- _ ] =>
exfalso; eapply writable0_not_join_writable0; eassumption
| [ H: joins ?sh1 ?sh2,
W1: writable0_share ?sh1,
W2: readable_share ?sh2 |- _ ] =>
exfalso; eapply writable0_not_join_readable; eassumption
| [ H: joins Share.top ?sh2,
H0: ?sh2 <> Share.bot |- _ ] =>
exfalso; eapply H0; eapply only_bot_joins_top; eassumption
end.
Ltac joins_sh_contradiction:=
first[ joins_sh_contradiction_onside |
match goal with
| [ H: joins ?sh1 ?sh2 |- _ ] =>
eapply joins_comm in H
end; joins_sh_contradiction_onside].
Ltac glb_contradictions:=
repeat match goal with
| [ H: writable0_share_dec _ = _ |- _ ] => clear H
end;
match goal with
| [ H:  Share.glb Share.Rsh ?sh = Share.top  |- _ ] =>
exfalso; eapply glb_Rsh_not_top; eassumption
| [ H: writable0_share (Share.glb Share.Rsh ?sh) |- _ ] =>
eapply writable0_right in H
end; join_sh_contradiction.
(*Lemma permDisjoint_sub: forall r1 r2 p, join_sub r2 r1 -> permDisjoint (perm_of_res r1) p -> permDisjoint (perm_of_res r2) p.  Lemma permMapsDisjoint_permDisjoint: forall r1 r2 b ofs, permMapsDisjoint r1 r2 -> permDisjoint (r1 !! b ofs) (r2 !! b ofs). intros. destruct  (H b ofs) as [k H']. exists k; assumption. Qed.  Lemma empty_disjoint': forall pmap, permMapsDisjoint empty_map pmap. intros pmap b ofs. exists (pmap !! b ofs). rewrite empty_map_spec; reflexivity. Qed. Lemma empty_disjoint: permMapsDisjoint empty_map empty_map. unfold permMapsDisjoint. unfold empty_map; intros; simpl. unfold Maps.PMap.get; simpl. rewrite Maps.PTree.gempty; simpl. exists None; reflexivity. Qed.  Lemma permMapsDisjoint_comm : forall pmap1 pmap2 (Hdis: permMapsDisjoint pmap1 pmap2), permMapsDisjoint pmap2 pmap1.  Lemma permMapsDisjoint2_comm: forall pmaps pmaps', permMapsDisjoint2 pmaps pmaps' <-> permMapsDisjoint2 pmaps' pmaps.  Lemma disjoint_norace: forall (mi mj : mem) (b : block) (ofs : Z) (Hdisjoint: permMapsDisjoint (getCurPerm mi) (getCurPerm mj)) (Hpermj: Mem.perm mj b ofs Cur Readable) (Hpermi: Mem.perm mi b ofs Cur Writable), False.  Definition isCanonical (pmap : access_map) := pmap.1 = fun _ => None. Import Maps. Definition TreeMaxIndex {A} (t:Maps.PTree.t A): positive:= compcert.lib.Coqlib.list_fold_left (fun a => [eta Pos.max a.1]) 1%positive (Maps.PTree.elements t) . Lemma fold_max_monoton: forall  {A} (ls: seq.seq (positive * A)), forall i, (Coqlib.list_fold_left (fun a => [eta Pos.max a.1]) i ls >= i)%positive. Lemma fold_max_monoton': forall  {A} (ls: seq.seq (positive * A)), forall i j, (i >= j)%positive -> (compcert.lib.Coqlib.list_fold_left (fun a => [eta Pos.max a.1]) i ls >= compcert.lib.Coqlib.list_fold_left (fun a => [eta Pos.max a.1]) j ls)%positive. Lemma TreeMaxIndex_help: forall {A} (ls: seq.seq (positive * A)), forall i v, In (i, v) ls -> (compcert.lib.Coqlib.list_fold_left (fun a => [eta Pos.max a.1]) 1%positive ls >= i)%positive.  Lemma max_works: forall A (t:PTree.t A) m, (m > TreeMaxIndex t)%positive -> t ! m = None.  Lemma Cur_isCanonical: forall m, isCanonical (getCurPerm m). unfold isCanonical. intros. pose (BigNumber:= Pos.max (Pos.succ( TreeMaxIndex (getCurPerm m).2) ) (Mem.nextblock m)). assert (HH: (BigNumber >= (Pos.succ ( TreeMaxIndex (getCurPerm m).2)))%positive ) by (unfold BigNumber; apply Pos.le_ge; apply Pos.le_max_l). apply Pos.ge_le in HH; apply Pos.le_succ_l in HH. apply Pos.lt_gt in HH; eapply max_works in HH. extensionality x. pose (property:= Mem.nextblock_noaccess m BigNumber x Cur). rewrite <- property. - replace ((Mem.mem_access m) !! BigNumber x Cur) with (permission_at m BigNumber x Cur); try reflexivity. rewrite <- getCurPerm_correct. unfold PMap.get. rewrite HH. reflexivity. - apply Pos.le_nlt. unfold BigNumber. apply Pos.le_max_r. Qed.  Lemma Max_isCanonical: forall m, isCanonical (getMaxPerm m). unfold isCanonical. intros. pose (BigNumber:= Pos.max (Pos.succ( TreeMaxIndex (getMaxPerm m).2) ) (Mem.nextblock m)). assert (HH: (BigNumber >= (Pos.succ ( TreeMaxIndex (getMaxPerm m).2)))%positive ) by (unfold BigNumber; apply Pos.le_ge; apply Pos.le_max_l). apply Pos.ge_le in HH; apply Pos.le_succ_l in HH. apply Pos.lt_gt in HH; eapply max_works in HH. extensionality x. pose (property:= Mem.nextblock_noaccess m BigNumber x Max). rewrite <- property. - replace ((Mem.mem_access m) !! BigNumber x Max) with (permission_at m BigNumber x Max); try reflexivity. rewrite <- getMaxPerm_correct. unfold PMap.get. rewrite HH. reflexivity. - apply Pos.le_nlt. unfold BigNumber. apply Pos.le_max_r. Qed.  Definition permMapLt (pmap1 pmap2 : access_map) : Prop := forall b ofs, Mem.perm_order'' (Maps.PMap.get b pmap2 ofs) (Maps.PMap.get b pmap1 ofs).  Lemma empty_LT: forall pmap, permMapLt empty_map pmap. intros pmap b ofs. rewrite empty_map_spec. destruct (pmap !! b ofs); simpl; exact I. Qed.  Lemma canonical_lt : forall p' m (Hlt: permMapLt p' (getMaxPerm m)), isCanonical p'.  Lemma invalid_block_empty: forall pmap m (Hlt: permMapLt pmap (getMaxPerm m)), forall b, ~ Mem.valid_block m b -> forall ofs, pmap !! b ofs = None.  Definition setPerm (p : option permission) (b : block) (ofs : Z) (pmap : access_map) : access_map := Maps.PMap.set b (fun ofs' => if compcert.lib.Coqlib.zeq ofs ofs' then p else Maps.PMap.get b pmap ofs') pmap.  Fixpoint setPermBlock (p : option permission) (b : block) (ofs : Z) (pmap : access_map) (length: nat): access_map := match length with 0 => pmap | S len => setPerm p b (ofs + (Z_of_nat len))%Z (setPermBlock p b ofs pmap len) end.  Lemma setPermBlock_same: forall p b ofs ofs' pmap sz (Hofs: (ofs <= ofs' < ofs + (Z.of_nat sz))%Z), (Maps.PMap.get b (setPermBlock p b ofs pmap sz)) ofs' = p.  Lemma setPermBlock_other_1: forall p b ofs ofs' pmap sz (Hofs: (ofs' < ofs)%Z \/ (ofs' >= ofs + (Z.of_nat sz))%Z), (Maps.PMap.get b (setPermBlock p b ofs pmap sz)) ofs' = Maps.PMap.get b pmap ofs'.  Lemma setPermBlock_other_2: forall p b b' ofs ofs' pmap sz, b <> b' -> (Maps.PMap.get b' (setPermBlock p b ofs pmap sz)) ofs' = Maps.PMap.get b' pmap ofs'.  Lemma setPermBlock_or: forall p b ofs sz pmap b' ofs', (setPermBlock p b ofs pmap sz) !! b' ofs' = p \/ (setPermBlock p b ofs pmap sz) !! b' ofs' = pmap !! b' ofs'.  Fixpoint setPermBlock_var (fp : nat -> option permission) (b : block) (ofs : Z) (pmap : access_map) (length: nat): access_map := match length with 0 => pmap | S len => setPerm (fp length) b (ofs + (Z_of_nat len))%Z (setPermBlock_var fp b ofs pmap len) end.  Lemma setPermBlock_var_other_2: forall p b b' ofs ofs' pmap sz, b <> b' -> (Maps.PMap.get b' (setPermBlock_var p b ofs pmap sz)) ofs' = Maps.PMap.get b' pmap ofs'.  Lemma setPermBlock_var_other_1: forall p b ofs ofs' pmap sz (Hofs: (ofs' < ofs)%Z \/ (ofs' >= ofs + (Z.of_nat sz))%Z), (Maps.PMap.get b (setPermBlock_var p b ofs pmap sz)) ofs' = Maps.PMap.get b pmap ofs'.  Lemma setPermBlock_var_same: forall p b ofs ofs' pmap sz (Hofs: (ofs <= ofs' < ofs + (Z.of_nat sz))%Z), (Maps.PMap.get b (setPermBlock_var p b ofs pmap sz)) ofs' = p (Z.to_nat (ofs' - ofs +1)).  Lemma setPermBlock_setPermBlock_var: forall b ofs sz pmap p, setPermBlock p b ofs pmap sz = setPermBlock_var (fun _ => p) b ofs pmap sz.  Lemma setPermBlock_range_perm: forall (m1 : mem) (b : block) (ofs : Z) (n : nat) perm perm_map, permMapLt (setPermBlock (Some perm) b ofs perm_map n) (getMaxPerm m1) -> Mem.range_perm m1 b ofs (ofs + Z.of_nat n) Max perm.  (*Lemma setPermBlock_var_or: forall p b ofs sz pmap b' ofs', (setPermBlock_var p b ofs pmap sz) !! b' ofs' = p \/ (setPermBlock_var p b ofs pmap sz) !! b' ofs' = pmap !! b' ofs'.    Lemma permMapCoherence_increase: forall pmap pmap' b ofs sz_nat sz (Hsz: sz = Z.of_nat (sz_nat)) (Hcoh: permMapCoherence pmap pmap') (Hreadable: forall ofs', Intv.In ofs' (ofs, ofs + sz)%Z -> Mem.perm_order' (pmap' !! b ofs') Readable), permMapCoherence pmap (setPermBlock (Some Writable) b ofs pmap' sz_nat).  (*setPermBlock with a function*)
Fixpoint setPermBlockFunc (fp : Z -> option permission) (b : block)
(ofs : Z) (pmap : access_map) (length: nat): access_map :=
match length with
0 => pmap
| S len =>
setPerm (fp (ofs + (Z_of_nat len))%Z) b (ofs + (Z_of_nat len))%Z (setPermBlockFunc fp b ofs pmap len)
end.
(** Apply a [delta_map] to an [access_map]*)
Definition computeMap (pmap : access_map) (delta : delta_map) : access_map :=
(pmap.1,
@Maps.PTree.combine (Z -> option permission)
(Z -> option (option permission))
(Z -> option permission)
(fun p1 pd => match pd, p1 with
| Some pd', Some p1' =>
Some (fun z => match pd' z with
Some pd'' => pd''
| _ => p1' z
end)
| Some pd', None =>
Some (fun z => match pd' z with
Some pd'' => pd''
| _ => pmap.1 z
end)
| None, _ => p1
end)
pmap.2 delta).
Definition maxF (f : Z -> perm_kind -> option permission) :=
fun ofs k => match k with
| Max => Some Freeable
| Cur => f ofs k
end.
Definition allF (f : Z -> perm_kind -> option permission) :=
fun (_ : Z) (_ : perm_kind) => Some Freeable.
Fixpoint PList (f : (Z -> perm_kind -> option permission) ->
Z -> perm_kind -> option permission)
l m : list (positive * (Z -> perm_kind -> option permission)) :=
match l with
| nil => nil
| x :: l =>
(Pos.of_nat x, f (PMap.get (Pos.of_nat x) m)) :: (PList f l m)
end.
Fixpoint canonicalPTree (l : list (positive * (Z -> perm_kind -> option permission))) :=
match l with
| nil => PTree.empty _
| x :: l =>
PTree.set (fst x) (snd x) (canonicalPTree l)
end.
Definition canonicalPMap fn n m : Maps.PMap.t (Z -> perm_kind -> option permission) :=
let l := mkBlockList n in
(fun _ _ => None, canonicalPTree (PList fn l m)).

Lemma canonicalPMap_sound :
forall k n m fn
(Hk : k > 0)
(Hkn : k < n),
fn (m !! (Pos.of_nat k)) = (canonicalPMap fn n m) !! (Pos.of_nat k).