Require Export VST.veric.base.
Local Open Scope Z_scope.
Local Open Scope pred.
Program Definition kind_at (k: kind) (l: address) : pred rmap :=
fun m => exists rsh, exists sh, exists pp, m @ l = YES rsh sh k pp.
Next Obligation.
try intro; intros.
destruct H0 as [rsh [sh [pp ?]]].
generalize (eq_sym (resource_at_approx a l)); intro.
generalize (age1_resource_at a a'  H l (a@l) H1); intro.
rewrite H0 in H2. simpl in H2. eauto.
Qed.
Definition spec : Type :=  forall (sh: Share.t) (l: AV.address), pred rmap.
Program Definition yesat_raw (pp: preds) (k: kind)
(sh: share) (rsh: readable_share sh) (l: address) : pred rmap :=
fun phi => phi @ l = YES sh rsh k (preds_fmap (approx (level phi)) (approx (level phi)) pp).
Next Obligation.
try intro; intros.
apply (age1_resource_at a a' H l (YES sh rsh k pp) H0).
Qed.
Obligation Tactic := idtac.
Program Definition yesat (pp: preds) (k: kind) : spec :=
fun (sh: share) (l: AV.address) (m: rmap) =>
exists rsh, yesat_raw pp k sh rsh l m.
Next Obligation.
intros; intro; intros.
destruct H0 as [p ?]; exists p.
apply pred_hereditary with a; auto.
Qed.
Program Definition pureat (pp: preds) (k: kind) (l: AV.address): pred rmap :=
fun phi => phi @ l = PURE k (preds_fmap (approx (level phi)) (approx (level phi)) pp).
Next Obligation.
intros; intro; intros.
apply (age1_resource_at a a' H l (PURE k pp) H0).
Qed.
Ltac do_map_arg :=
match goal with |- ?a = ?b =>
match a with context [map ?x _] =>
match b with context [map ?y _] => replace y with x; auto end end end.
(* NOT TRUE, because the shares might not match Lemma extensionally_yesat: forall pp k sh l, extensionally (yesat pp k sh l) = yesat pp k sh l. *)
Program Definition noat (l: AV.address) : pred rmap :=
fun m => identity (m @ l).
Next Obligation.
intros; intro; intros.
apply (age1_resource_at_identity _ _ l H); auto.
Qed.
Definition resource_share (r: resource) : option share :=
match r with
| YES sh _ _ _ => Some sh
| NO sh _ => Some sh
| PURE _ _ => None
end.
Definition nonlock (r: resource) : Prop :=
match r with
| YES _ _ k _ => isVAL k \/ isFUN k
| NO _ _ => True
| PURE _ _ => False
end.
Program Definition nonlockat (l: AV.address): pred rmap :=
fun m => nonlock (m @ l).
Next Obligation.
intros; intro; intros.
unfold resource_share in *.
destruct (a @ l) eqn:?H.
+ rewrite (necR_NO a a' l _ n) in H1 by (constructor; auto).
rewrite H1; assumption.
+ eapply necR_YES in H1; [ | constructor; eassumption].
rewrite H1; assumption.
+ eapply necR_PURE in H1; [ | constructor; eassumption].
rewrite H1; assumption.
Qed.
Program Definition shareat (l: AV.address) (sh: share): pred rmap :=
fun m => resource_share (m @ l) = Some sh.
Next Obligation.
intros; intro; intros.
unfold resource_share in *.
destruct (a @ l) eqn:?H.
+ rewrite (necR_NO a a' l _ n) in H1 by (constructor; auto).
rewrite H1; assumption.
+ eapply necR_YES in H1; [ | constructor; eassumption].
rewrite H1; assumption.
+ inv H0.
Qed.
Program Definition jam {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A} {B: Type} {S': B -> Prop} (S: forall l, {S' l}+{~ S' l}) (P Q: B -> pred A) : B -> pred A :=
fun (l: B) m => if S l then P l m else Q l m.
Next Obligation.
intros; intro; intros.
if_tac; try (eapply pred_hereditary; eauto).
Qed.
Definition is_resource_pred (p: address -> pred rmap) (q: resource -> address -> nat -> Prop) :=
forall l w, (p l) w = q (w @ l) l (level w).
Definition resource_stable (p: address -> pred rmap) :=
forall l w w', w @ l = w' @ l -> level w = level w' -> (p l) w = (p l) w'.
Program Definition noghost : pred rmap := fun m => identity (ghost_of m).
Next Obligation.
Definition spec_parametric (Q: address -> spec) : Prop :=
forall l l', exists pp, exists ok,
forall sh m,
Q l sh l' m =
(exists p, exists k, ok k /\ m @ l' =
YES sh p k (preds_fmap (approx (level m)) (approx (level m)) pp)).
(****** Specific specs  ****************)
(* Memory predicates need to explicitly not capture any ghost state. *)
Definition VALspec : spec :=
fun (sh: Share.t) (l: address) =>
allp (jam (eq_dec l)
(fun l' => EX v: memval,
yesat NoneP (VAL v) sh l')
noat) && noghost.
Definition VALspec_range (n: Z) : spec :=
fun (sh: Share.t) (l: address) =>
andp (allp (jam (adr_range_dec l n)
(fun l' => EX v: memval,
yesat NoneP (VAL v) sh l')
noat)) noghost.
Definition nonlock_permission_bytes (sh: share) (a: address) (n: Z) : pred rmap :=
andp (allp (jam (adr_range_dec a n) (fun i => shareat i sh && nonlockat i) noat)) noghost.
Definition nthbyte (n: Z) (l: list memval) : memval :=
nth (Z.to_nat n) l Undef.
(*  Unfortunately address_mapsto_old, while a more elegant definition than address_mapsto, is not quite right.  For example, it doesn't uniquely determine v *)
Definition address_mapsto_old (ch: memory_chunk) (v: val) : spec :=
fun (sh: Share.t) (l: AV.address)  =>
allp (jam (adr_range_dec l (size_chunk ch))
(fun l' => yesat NoneP (VAL (nthbyte (snd l' - snd l) (encode_val ch v))) sh l')
noat).
Definition address_mapsto (ch: memory_chunk) (v: val) : spec :=
fun (sh: Share.t) (l: AV.address) =>
EX bl: list memval,
!! (length bl = size_chunk_nat ch  /\ decode_val ch bl = v /\ (align_chunk ch | snd l))  &&
(allp (jam (adr_range_dec l (size_chunk ch))
(fun loc => yesat NoneP (VAL (nth (Z.to_nat (snd loc - snd l)) bl Undef)) sh loc)
noat)) && noghost.
Definition LKspec lock_size (R: pred rmap) : spec :=
fun (sh: Share.t) (l: AV.address)  =>
allp (jam (adr_range_dec l lock_size)
(fun l' => yesat (SomeP Mpred (fun _ => R)) (LK lock_size (snd l' - snd l)) sh l')
noat) && noghost.
(*Lenb: moved to veric/seplog.v Definition packPQ {A: rmaps.TypeTree} (P Q: forall ts, dependent_type_functor_rec ts (AssertTT A) (pred rmap)): forall ts, dependent_type_functor_rec ts (SpecTT A) (pred rmap) := fun ts a b => if b then P ts a else Q ts a. *)
Definition TTat (l: address) : pred rmap := TT.
(* Definition FUNspec (fml: funsig) cc (A: TypeTree) (P Q: forall ts, dependent_type_functor_rec ts (AssertTT A) (pred rmap)) (l: address): pred rmap := allp (jam (eq_dec l) (pureat (SomeP (SpecTT A) (packPQ P Q)) (FUN fml cc)) TTat).  Definition fun_assert (fml: funsig) cc (A: TypeTree) (P Q: forall ts, dependent_type_functor_rec ts (AssertTT A) (pred rmap)) (v: val)  : pred rmap := (EX b : block, !! (v = Vptr b Int.zero) && FUNspec fml cc A P Q (b, 0))%pred. *)
(***********)
(*Lenb: dead? Lemma ewand_lem1x: forall S P: mpred, S |-- P * TT -> S |-- P * (ewand P S).  Lemma address_mapsto_old_parametric: forall ch v, spec_parametric (fun l sh l' => yesat NoneP (VAL (nthbyte (snd l' - snd l) (encode_val ch v))) sh l').  Lemma VALspec_parametric: spec_parametric (fun l sh l' => EX v: memval,  yesat NoneP (VAL v) sh l').  Lemma LKspec_parametric lock_size: forall R: pred rmap, spec_parametric (fun l sh l' => yesat (SomeP Mpred (fun _ => R)) (LK lock_size (snd l' - snd l)) sh l').  (* Lemma FUNspec_parametric: forall fml cc A P Q, spec_parametric (fun l sh => yesat (SomeP (SpecTT A) (packPQ P Q)) (FUN fml cc) sh). *)
Definition val2address (v: val) : option AV.address :=
match v with Vptr b ofs => Some (b, Ptrofs.signed ofs) | _ => None end.
(* The converse is not quite true, because "readable" does constraint to NoneP *)
(* NOT TRUE, because of CompCert_AV.valid problems. Lemma jam_con: forall A (S: A -> Prop) P Q, allp (jam S P Q) |-- allp (jam S P (fun _ => emp)) * (allp (jam S (fun _ => emp) Q)). *)
(*  NOT TRUE, because readable doesn't constraint NoneP ... Lemma readable_VAL: forall w l, readable l (w_m w) <-> exists sh, (VALspec sh l * TT) w.  *)
Program Definition core_load (ch: memory_chunk) (l: address) (v: val): pred rmap :=
EX bl: list memval,
!!(length bl = size_chunk_nat ch /\ decode_val ch bl = v /\ (align_chunk ch | snd l)) &&
allp (jam (adr_range_dec l (size_chunk ch))
(fun l' phi => exists sh, exists rsh, phi @ l'
= YES sh rsh (VAL (nth (Z.to_nat (snd l' - snd l)) bl Undef)) NoneP)
(fun _ _ => True)).
Next Obligation.
intros; intro; intros.
destruct H0 as [sh [rsh ?]]; exists sh, rsh.
apply (age1_YES a a'); auto.
Qed.
Next Obligation.     intros; intro; intros. auto.
Qed.
Program Definition core_load' (ch: memory_chunk) (l: address) (v: val) (bl: list memval)
: pred rmap :=
!!(length bl = size_chunk_nat ch /\ decode_val ch bl = v /\ (align_chunk ch | snd l)) &&
allp (jam (adr_range_dec l (size_chunk ch))
(fun l' phi => exists sh, exists rsh, phi @ l'
= YES sh rsh (VAL (nth (Z.to_nat (snd l' - snd l)) bl Undef)) NoneP)
(fun _ _ => True)).
Next Obligation.
intros; intro; intros.
destruct H0 as [sh [rsh ?]]; exists sh, rsh.
apply (age1_YES a a'); auto.
Qed.
Next Obligation.     intros; intro; intros. auto.
Qed.
Hint Resolve VALspec_range_0: normalize.

Lemma is_resource_pred_YES_VAL sh:
is_resource_pred
(fun l' => EX  v: memval, yesat NoneP (VAL v) sh l')
(fun r _ n => (exists b0 rsh, r = YES sh rsh (VAL b0)
(SomeP (ConstType unit) (fun _ => tt)))).