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.
(* subsumed is different than sub_map: submap is that the STRUCTURE of the tree is the same subsumed is that it can join to it: subsumed x y: exists z. x + z = y. *)
Inductive subsumed: option permission -> option permission -> Prop:=
| subsumedNone: forall x, subsumed None x
| subsumedNENE: subsumed (Some Nonempty) (Some Nonempty)
| subsumedNER: subsumed (Some Nonempty) (Some Readable)
| subsumedNEW: subsumed (Some Nonempty) (Some Writable)
| subsumedRR: subsumed (Some Readable) (Some Readable)
| subsumedRW: subsumed (Some Readable) (Some Writable).
Inductive option_join :
option (option permission) ->
option permission ->
option permission -> Prop :=
| NoneJoin: forall l c,
subsumed l c -> (* why subsumed? *)
option_join None l c
| SomeJoin: forall a b c,
permjoin_def.permjoin a b c ->
option_join (Some a) b c.
Definition delta_map_join
(A: delta_map)
(B: access_map)
(C: access_map):=
forall b ofs,
option_join (dmap_get A b ofs)
(B !! b ofs)
(C !! b ofs).
Definition delta_map_join_pair:= pair3_prop delta_map_join.
Hint Unfold delta_map_join_pair: pair.
Definition deltaMapLt2 (dmap: delta_map) (pmap : access_map) : Prop :=
forall b ofs,
opt_rel
Mem.perm_order''
(Some (Maps.PMap.get b pmap ofs))
(dmap_get dmap b ofs).
Definition almost_perfect_image mu (max a1 a2: access_map):=
forall b1 b2 delt,
mu b1 = Some (b2, delt) ->
forall ofs, at_least_Some (max !! b1 ofs) ->
a1 !! b1 ofs = a2 !! b2 (ofs + delt).
Definition dmap_vis_filtered (dmap:delta_map) (m:mem) :=
forall b ofs p,
dmap_get dmap b ofs = Some p ->
Mem.perm m b ofs Max Nonempty.
(*deltaMapLt2 A1 (getMaxPerm m) -> permMapLt B1  (getMaxPerm m) -> *)
(* perm_perfect_image f C1 C2 -> *)
Definition deltaMapLt2_pair1:= pair21_prop deltaMapLt2.
Hint Unfold deltaMapLt2_pair1: pair.
Definition dmap_vis_filtered_pair:= pair21_prop dmap_vis_filtered.
Hint Unfold dmap_vis_filtered_pair: pair.
Definition almost_perfect_image_pair f max_perm:=
pair2_prop (almost_perfect_image f max_perm).
Hint Unfold almost_perfect_image_pair: pair.
(*deltaMapLt2_pair1 A1 (getMaxPerm m) -> permMapLt_pair1 B1 (getMaxPerm m) -> *)
Definition isCanonical' {A} (pmap: PMap.t (Z-> option A)):=
fst pmap = (fun _ : Z => None).
Definition option_implication_dmap_access (dmap:delta_map)(map: access_map) :=
forall b ofs, option_implication (dmap_get dmap b ofs) (map !! b ofs).
Definition option_implication_dmap_access_pair :=
pair21_prop option_implication_dmap_access.
Hint Unfold option_implication_dmap_access_pair: pair.
Definition option_implication_access (a1 a2: access_map) :=
forall b ofs, option_implication (a1 !! b ofs) (a2 !! b ofs).
Definition option_implication_access_pair :=
pair21_prop option_implication_access.
Hint Unfold option_implication_access_pair: pair.
Definition dmap_valid (m:mem) (dm:delta_map) :=
forall b ofs p,
dmap_get dm b ofs = Some p ->
Mem.valid_block m b.
Definition dmap_valid_pair m:=
pair1_prop (dmap_valid m).
Hint Unfold dmap_valid_pair: pair.
Definition map_valid (m:mem) (am:access_map) :=
forall b ofs p,
am !! b ofs = Some p ->
Mem.valid_block m b.
Definition map_valid_pair m:= pair1_prop (map_valid m).
Hint Unfold map_valid_pair: pair.
Record perm_perfect_virtue f (angel1 angel2:virtue):=
{ permp: perm_perfect_image_pair f (virtueLP angel1) (virtueLP angel2);
pperm_dmap: perm_perfect_image_dmap_pair
f (virtueThread angel1) (virtueThread angel2)
}.
Admitted.

Lemma inject_almost_perfect_pair
: forall (f : meminj) (m1 m2 : mem)
p11 p12 p21 p22 Hlt11 Hlt12 Hlt21 Hlt22,
Mem.inject f (@restrPermMap p12 m1 Hlt12) (@restrPermMap p22 m2 Hlt22) ->
Mem.inject f (@restrPermMap p11 m1 Hlt11) (@restrPermMap p21 m2 Hlt21) ->
almost_perfect_image_pair f (getMaxPerm m1) (p11,p12) (p21,p22).