Ltac unify_injection:=
match goal with
[H: ?mu ?x = _,H0: ?mu ?x = _ |- _] =>
match type of mu with
| meminj => rewrite H in H0; invert H0
| block -> option (block * Z) => rewrite H in H0; invert H0
end
end.
Local Ltac unify_mapping:=
match goal with
[H: ?a !! ?x ?y = Some _ ,
H0: ?a !! ?x ?y = _ |- _] => rewrite H in H0
| [H: ?a !! ?x ?y = None ,
H0: ?a !! ?x ?y = _ |- _] => rewrite H in H0
| [H: ?a !! ?x ?y = Some _ ,
H0: _ = ?a !! ?x ?y |- _] => rewrite H in H0
| [H: ?a !! ?x ?y = None ,
H0: _ = ?a !! ?x ?y |- _] => rewrite H in H0
end.
Definition inject_lock' size mu (b_lock:block) (ofs_lock: Z) (m1 m2:mem):=
exists b_lock' delt,
mu b_lock = Some (b_lock', delt) /\
( forall ofs0,
Intv.In ofs0 (ofs_lock, (ofs_lock + size)%Z) ->
memval_inject mu
(ZMap.get ofs0 (Mem.mem_contents m1) !! b_lock)
(ZMap.get (ofs0 + delt)%Z
(Mem.mem_contents m2) !! b_lock')).
Definition inject_lock := inject_lock' LKSIZE.
Instance inject_lock_morphism:
Proper (Logic.eq ==> Logic.eq ==> Logic.eq ==>
content_equiv ==> content_equiv ==> iff) inject_lock.
Definition option_implication {A B} (oa:option A) (ob: option B):=
match oa, ob with | Some _, None => False | _, _ => True end.
Definition map_option_implication {A B} (m1:PTree.t A) (m2:PTree.t B):=
forall b, option_implication (m1 ! b) (m2 ! b).
Definition at_least_Some {A} (x:option A):=
option_implication (Some tt) x.
Definition perm_image (f:meminj) (a1: access_map): Prop:=
forall b1 ofs, at_least_Some (a1 !! b1 ofs) ->
exists b2 delta, f b1 = Some (b2, delta).
Instance proper_perm_image:
Proper (Logic.eq ==> access_map_equiv ==> iff) perm_image.
(* The injection maps to every visible location *)
Definition perm_surj (mu:meminj) (a1 a2: access_map):=
forall b2 ofs_delt,
at_least_Some (a2 !! b2 ofs_delt) ->
exists b1 ofs delt, mu b1 = Some (b2, delt) /\
ofs_delt = ofs + delt /\
a2 !! b2 ofs_delt = a1 !! b1 ofs.
(* The injection maps all visible locations*)
Definition access_map_injected (f:meminj) (pmap1 pmap2: access_map):=
forall (b1 b2 : block) (delt ofs: Z),
f b1 = Some (b2, delt) ->
Mem.perm_order'' (pmap2 !! b2 (ofs+delt)%Z) (pmap1 !! b1 ofs).
intros. intros ?????.
do 2 rewrite getMaxPerm_correct.
destruct (permission_at m1 b1 ofs Max) eqn:HH.
- rewrite <- mem_lemmas.po_oo.
eapply Mem.mi_perm; eauto.
+ apply H.
+ unfold Mem.perm.
unfold permission_at in HH; rewrite HH.
simpl. apply perm_refl.
- apply event_semantics.po_None.
Qed.
intros. intros ?????.
do 2 rewrite getCurPerm_correct.
destruct (permission_at m1 b1 ofs Cur) eqn:HH.
- rewrite <- mem_lemmas.po_oo.
eapply Mem.mi_perm; eauto.
+ apply H.
+ unfold Mem.perm.
unfold permission_at in HH;
rewrite HH.
simpl.
apply perm_refl.
- apply event_semantics.po_None.
Qed.
(* bounded_maps*)
(* New permissions*)
(* Permissions *)
Global Instance perm_preimage_setoid:
Proper (Logic.eq ==> access_map_equiv ==>
access_map_equiv ==> iff) perm_surj.
Instance access_map_injected_morphism:
Proper (Logic.eq ==> access_map_equiv  ==> access_map_equiv ==> Logic.iff)
access_map_injected.
Definition mi_memval_perm (f:meminj) (perm1:access_map) cont1 cont2:=
forall b1 b2 delta ofs,
f b1 = Some (b2, delta) ->
Mem.perm_order' (perm1 !! b1 ofs) Readable ->
memval_inject f (ZMap.get ofs cont1 !! b1)
(ZMap.get (ofs + delta) cont2 !! b2).
Instance proper_mi_memval_perm:
Proper (Logic.eq ==> access_map_equiv ==>
Logic.eq ==> Logic.eq ==> iff)
mi_memval_perm.
Definition mi_perm_inv_perm f perm1 perm2 m1:=
forall (b1 : block) (ofs : Z) (b2 : block)
(delta : Z) (p : permission),
f b1 = Some (b2, delta) ->
Mem.perm_order' (perm2 !! b2 (ofs + delta)) p ->
Mem.perm_order' (perm1 !! b1 ofs) p
\/ ~ Mem.perm m1 b1 ofs Max Nonempty.
Instance proper_mi_perm_inv_perm:
Proper (Logic.eq ==> access_map_equiv ==> access_map_equiv ==>
Max_equiv ==> iff) mi_perm_inv_perm.
(* HERE no overlap *)
Definition maps_no_overlap {A} (f:meminj) (p1 p2: PMap.t (Z -> option A)):=
forall (b1 b1' : block) (delta1 : Z) (b2 b2' : block) (delta2 ofs1 ofs2 : Z),
b1 <> b2 ->
f b1 = Some (b1', delta1) ->
f b2 = Some (b2', delta2) ->
at_least_Some (p1 !! b1 ofs1) ->
at_least_Some  (p2 !! b2 ofs2) ->
b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2.
Definition map_no_overlap {A} (f:meminj) p:=
@maps_no_overlap A f p p.
Definition map_no_overlap_range (f:meminj) (perm: access_map):=
forall (b1 b1' : block) (delta1 : Z) (b2 b2' : block) (delta2 ofs1 ofs2 SZ : Z),
0 < SZ ->
b1 <> b2 ->
f b1 = Some (b1', delta1) ->
f b2 = Some (b2', delta2) ->
Mem.perm_order' (perm !! b1 ofs1) Nonempty ->
(forall ofs2', 0 <= ofs2' < SZ ->
Mem.perm_order' (perm !! b2 (ofs2 + ofs2')) Nonempty) ->
b1' <> b2' \/ ~ Intv.In (ofs1 + delta1) (ofs2 + delta2, ofs2 + delta2 + SZ).
Record virtue:=
{ virtueThread:
PTree.t (Z -> option (option permission)) *
PTree.t (Z -> option (option permission));
virtueLP: access_map * access_map }.
Definition pair21 {A B C} (f: A -> B -> C) (aa:Pair A) (b: B): Pair C :=
pair1 (fun a => f a b) aa.
Hint Unfold pair21: pair.
Definition pair21_prop {A B} (f: A -> B -> Prop) (aa:Pair A) (b: B):Prop :=
pair1_prop (fun a => f a b) aa.
Hint Unfold pair21_prop: pair.
Definition permMapLt_pair1:= pair21_prop permMapLt.
Hint Unfold permMapLt_pair1: pair.
(*Take just the tree*)
Definition sub_map_snd {A A' B} (a:A'* _) b:=
@sub_map A B (snd a) b.
Record sub_map_virtue (v:virtue)(m:access_map):=
{ virtueThread_sub_map:
pair21_prop sub_map (virtueThread v) (snd m);
virtueLP_sub_map:
map_empty_def (fst (virtueLP v)) /\
map_empty_def (snd (virtueLP v)) /\
pair21_prop sub_map_snd (virtueLP v) (snd m)
}.
Definition sub_map_pair {A B} :=
(pair21_prop (@sub_map A B)).
(*  *)
Definition writable_lock b ofs perm1 m1:=
permMapLt (setPermBlock (Some Writable) b ofs perm1 LKSIZE_nat) (getMaxPerm m1).
Hint Resolve LKSIZE_nat_pos.
Instance writable_lock_proper:
Proper (Logic.eq ==> Logic.eq ==>
access_map_equiv ==> Max_equiv ==> iff) writable_lock.
Definition permMapJoin_pair:= pair3_prop permMapJoin.
Hint Unfold permMapJoin_pair: pair.
Definition is_empty_map (am:access_map):=
forall b ofs, am !! b ofs = None.
Definition empty_doublemap:=
pair1_prop is_empty_map.
Hint Unfold empty_doublemap: pair.
Definition perm_inj (f:meminj) (a1 a2: access_map): Prop:=
forall b1 ofs, at_least_Some (a1 !! b1 ofs) ->
(* Mem.perm_order' (a1 !! b1 ofs) (Nonempty) -> *)
exists b2 delta,
f b1 = Some (b2, delta) /\
a1 !! b1 ofs = a2 !! b2 (ofs + delta).
Definition perfect_image (f:meminj) (a1 a2: access_map): Prop:=
forall b1 b2 delt,
f b1 = Some (b2, delt) ->
forall ofs, a1 !! b1 ofs = a2 !! b2 (ofs + delt).
(* TODO: change the names perm_inj -> perm_inj perm_surj -> perm_surj pimage -> pimage p_image -> prem_inj ppre_perfect_image -> prem_surj *)
Record perm_perfect_image mu a1 a2:=
{ (* pimage: perfect_image mu a1 a2; *) (* Too strong*)
p_image: perm_inj mu a1 a2;
ppre_perfect_image: perm_surj mu a1 a2}.
(*Arguments pimage {_ _ _}. *)
Arguments p_image {_ _ _}.
Arguments ppre_perfect_image {_ _ _}.
Local Ltac exploit_p_image H:=
let b:=fresh "b" in
let delt:=fresh "delt" in
let Hinj:=fresh "Hinj" in
destruct
(p_image H _ _ ltac:(eapply at_least_Some_trivial; eauto))
as (b&delt&Hinj&?); subst.
Local Ltac exploit_ppre_image H:=
let b:=fresh "b" in
let ofs:=fresh "ofs" in
let delt:=fresh "delt" in
let Hinj:=fresh "Hinj" in
destruct
(ppre_perfect_image H _ _ ltac:(eapply at_least_Some_trivial; eauto))
as (b&ofs&delt&Hinj&?&?); subst.
Local Ltac exploit_perfect_image H:=
first [exploit_p_image H | exploit_ppre_image H]. (*
progress (try (exploit_p_image H); try (exploit_ppre_image H)). *)
Local Ltac exploit_no_overlap_perm H:=
(* TODO: remove coqlib*)
( eapply no_overlapp_iff in H;
exploit H;
try (eapply at_least_Some_trivial; eauto);
eauto;
intros ?; destruct_and; subst
).
Definition perm_perfect_image_pair mu:=
pair2_prop (perm_perfect_image mu).
Hint Unfold perm_perfect_image_pair: pair.
Definition maps_no_overlap_pair {A} mu:=
pair2_prop (@maps_no_overlap A mu).
Hint Unfold maps_no_overlap_pair: pair.
Definition permMapLt_pair2:= pair2_prop permMapLt.
Hint Unfold permMapLt_pair2: pair.
Definition permMapLt_pair pp1 p2:=
permMapLt_pair2 pp1 (pair0 p2).
Hint Unfold permMapLt_pair: pair.
Instance permMapLt_pair_proper :
Proper (Logic.eq ==> access_map_equiv ==> iff) permMapLt_pair.

Lemma permMapLt_trans:
transitive _ permMapLt.