Module RML := Rmaps_Lemmas R.
Export RML. Export R.
Instance Cross_rmap : Cross_alg rmap := Cross_rmap_simple (fun _ => I).
Obligation Tactic := idtac.
(******  MAPSTO AND RELATED OPERATORS *****)
Program Definition mapsto (v1 v2: adr) : pred rmap :=
fun w => forall i,
if eq_dec i v1 then w @ i = YES pfullshare (VAL v2) NoneP else identity (w @ i).
Next Obligation.
intros. intros ? ? ? ?.
intro i; specialize (H0 i).
destruct (eq_dec i v1).
apply (age1_YES _ _ _ _ _ H); auto.
destruct (identity_resource (a @ i)) as [? _]. specialize (H1 H0).
apply identity_resource.
generalize (age1_resource_at _ _ H i (a @ i)); intro.
generalize (resource_at_approx a i); intro.
destruct (a @ i); try contradiction.
rewrite H2; simpl in *; auto.
rewrite H2; simpl in *; auto.
Qed.
Definition singleton_rmap  (v v': adr) (m: rmap) : rmap :=
proj1_sig
(make_rmap (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP  else core m @ i )
I (level m) (singleton_rmap_OK _ _ m)).
Local Open Scope pred.
Definition assert := env -> pred rmap.
Bind Scope pred with assert.
(****** PROGRAM SAFETY AS A SEPARATION-LOGIC PREDICATE *)
Program Definition cohere (concrete: heap) : pred rmap :=
fun w =>
forall p v, heap_get (concrete) p = Some v  <->
w @ p = YES pfullshare (VAL v) NoneP.
Next Obligation.
unfold hereditary; intros.
rewrite H0.
apply age1_YES; auto.
Qed.
Program Definition assert_safe
(p: program) (vars: varset) (ctl: control) : assert :=
fun s w => forall s' h, varcompat vars s' ->
locals2env s' = s -> cohere h w -> safeN p (s',h,ctl) (level w).
Next Obligation.
unfold hereditary; intros.
eapply safeN_less; [ | apply H0]; auto. subst.
apply age_level in H.   rewrite H. change R.rmap with rmap. omega.
clear - H H3. hnf in H3|-*. intros. rewrite H3.
generalize (age1_YES _ _ p pfullshare (VAL v) H); intros.
intuition.
Qed.
(******* FUNASSERT, MAKE_WORLD ********************)
Definition funspec := (list var * assert)%type.
Definition funspecs := table adr funspec.
Definition unpack (P: list adr -> pred rmap) (vl: listprod (@cons Type (list adr) nil)):  pred rmap := P (fst vl).
Definition call (P: list var * assert) (vl: list adr) : pred rmap :=
(!! (length vl = length (fst P)) && snd P (arguments (fst P) vl)).
Program Definition cont (nP: funspec)  (v: adr) : pred rmap :=
fun w => w @ v = PURE (FUN (fst nP)) (preds_fmap (approx (level w)) (SomeP (list adr::nil)
(unpack (call nP)))).
Next Obligation.
intros; intro; intros.
apply (age1_resource_at a a' H v (PURE (FUN (fst nP)) _));   simpl; auto.
Qed.
Definition funassert (G: funspecs) : pred rmap :=
(ALL  i:_, ALL P:_,  !! (table_get G i = Some P) --> cont P i)  &&
(ALL  i:_, ALL P:_,  cont P i --> !! exists P', table_get G i = Some P').
Definition make_world_aux (G: funspecs) (h: heap) (n: nat) (a: adr) : resource :=
match table_get G a with
| Some P => PURE (FUN (fst P))
(preds_fmap (approx n)
(SomeP (@cons Type (list adr) nil) (unpack (call P))))
| None => match heap_get h a with
| Some v => YES pfullshare (VAL v) NoneP
| None => NO
end
end.
Definition make_world (G: funspecs) (h: heap) (n: nat) : rmap :=
proj1_sig (make_rmap (make_world_aux G h n) I n (make_world_aux_OK _ _ _)).
Inductive match_specs: forall (p: program) (G: funspecs), Prop :=
| match_specs_nil: match_specs nil nil
| match_specs_cons: forall i vars f p' P G',
not (In i (map (@fst _ _) p')) ->
match_specs p' G' ->
typecheck vars f = true ->
match_specs ((i,(vars,f))::p') ((i,P)::G').
(**************** ALLOCPOOL ***************************)
Program Definition allocpool (b: adr) : pred rmap :=
fun w => b>0 /\ forall i, if lt_dec i b then identity (w @ i) else w @ i = YES pfullshare (VAL 0) NoneP.
Next Obligation.
intros. intro; intros.
destruct H0; split; auto.
intro i; specialize (H1 i).
destruct (lt_dec i b).
eapply age1_resource_at_identity; eauto.
apply (age1_YES _ _ _ _ _ H); auto.
Qed.
Require msl.seplog msl.alg_seplog.
Definition mpred : Type := predicates_hered.pred rmap.
Instance Nm: seplog.NatDed mpred := alg_seplog.algNatDed rmap.
Instance Sm: seplog.SepLog mpred := alg_seplog.algSepLog rmap.
Instance Cm: seplog.ClassicalSep mpred := alg_seplog.algClassicalSep rmap.
Instance Im: seplog.Indir mpred := alg_seplog.algIndir rmap.
Instance Rm: alg_seplog.RecIndir mpred := alg_seplog.algRecIndir rmap.
Instance SIm: seplog.SepIndir mpred := alg_seplog.algSepIndir rmap.
Instance SRm: alg_seplog.SepRec mpred := alg_seplog.algSepRec rmap.
Definition guard (p: program) (G: funspecs) (vars: varset) (P : assert) (k: control) : pred nat :=
ALL s:env, P s && funassert G >=> assert_safe p vars k s.
Record semaxArg :Type := SemaxArg {
sa_vars: varset;
sa_P: assert;
sa_c: control
}.
Definition believe (semax: semaxArg -> pred nat)
(p: program) (P: funspec) (f: adr) : pred nat :=
EX k: list var * control,
!!(table_get p f = Some k /\ length (fst k) = length (fst P) /\ list_norepet (fst k)) &&
|> semax (SemaxArg (fst k) (fun s => call P (map s (fst k))) (snd k)).
Definition believe_all (semax: semaxArg -> pred nat) (G: funspecs) (p: program) (G': funspecs) : pred nat :=
ALL v:adr, ALL args: list var, ALL P: assert,
!! (table_get G' v = Some (args,P)) -->
believe semax p (args, fun s => P s && funassert G) v.
Definition semax_ (semax: semaxArg -> pred nat) (a: semaxArg) : pred nat :=
match a with SemaxArg vars P c =>
ALL p: program, ALL G: funspecs, believe_all semax G p G --> guard p G vars P c
end.

Lemma HOcontractive_semax_ : HOcontractive semax_.