(* Gives us a logic over nats *)
Existing Instance ag_nat.
(* Build the logic over worlds.  We take tuples of a nat, a local env, and a memory.  The nat exists to let us define the |> operator and the Geodel Leob rule in the usual way.  We get a SA by the obvious combination of SAs on locals and mems with the trival SA on nats. *)
Definition world := (nat * (locals * mem))%type.
Definition world_sa : sepalg world :=
sa_prod (sa_equiv nat) (sa_prod locals_sa mem_sa).
Existing Instance world_sa.
Definition world_age : ageable world :=
ag_prod nat (locals * mem) ag_nat.
Existing Instance world_age.
Definition world_asa : ASA world :=
asa_prod nat (locals * mem) (sa_equiv nat) ag_nat (sa_prod locals_sa mem_sa) asa_nat.
Existing Instance world_asa.
(* Define the safey policy we use to build up the hoare tuple *)
Definition immed_safe (pu:program_unit) (st:state) :=
fst (fst st) = knil \/
exists st', step' pu st st'.
Fixpoint stepn (pu:program_unit) (n:nat) (st1 st2:state) {struct n} : Prop :=
match n with
| 0 => st1 = st2
| S n' => exists st', step' pu st1 st' /\ stepn pu n' st' st2
end.
Local Open Scope pred.
Program Definition safen (pu:program_unit) (k:ctl) : pred world :=
fun w => forall n', n' <= fst w ->
forall st', stepn pu n' ((k,fst (snd w)),snd (snd w)) st' -> immed_safe pu st'.
Next Obligation.
apply H0 with n'; auto.
hnf in H. destruct a; simpl in *; try discriminate.
destruct n. inv H. inv H. simpl in *. omega.
hnf in H. destruct a; simpl in *; try discriminate.
destruct n. inv H. inv H. simpl in *. auto.
Qed.
(* Lift a predicate on worlds to a pred on nats.  Then 'lift P' is true when P holds in all locals and memories. *)
Program Definition lift (P:pred world) : pred nat :=
fun n => forall rho m, P (n,(rho,m)).
Next Obligation.
eapply pred_hereditary with (a,(rho,m)); eauto.
hnf in *. simpl in *. rewrite H. auto.
apply H0.
Qed.
Obligation Tactic := idtac.
(* Expression evaluation.  Note this is not a tight formula. We will almost always use && rather than * to combine eval in to a larger formula. *)
Program Definition eval (e:expr) (v:val) : pred world :=
fun w => e (fst (snd w)) = Some v.
Next Obligation.
repeat intro.
destruct a. destruct n; inv H.
auto.
Qed.
Definition locpred := locals -> Prop.
Definition mempred := mem -> Prop.
(* Local i has value v *)
Definition hasval (i:ident) (v:val) : locpred :=
fun rho =>
LocalsMap.map_val i rho = Some v /\
LocalsMap.map_share i rho = Share.top /\
forall i', i <> i' -> LocalsMap.map_val i' rho = None.
Definition anylocals : locpred :=
fun rho => True.
(* Address a has value v with share sh. *)
Definition mapsto (a:addr) (sh:Share.t) (v:val) : mempred :=
fun m =>
MemMap.map_val a m = Some v /\
MemMap.map_share a m = sh /\
forall a', a <> a' -> MemMap.map_val a' m  = None.
(* Here we have coercions that turn flat predicates on locals or memories into hereditary predicates on worlds. *)
Program Definition lift_loc (P:locpred) : pred world :=
fun x => P (fst (snd x)) /\ identity (snd (snd x)).
Next Obligation.
repeat intro.
hnf in H. destruct a; destruct a'.
simpl in *. destruct n; simpl in *; try discriminate.
inv H. auto.
Qed.
Program Definition lift_mem (P:mempred) : pred world :=
fun x => P (snd (snd x)) /\ identity (fst (snd x)).
Next Obligation.
repeat intro.
hnf in H. destruct a; destruct a'.
simpl in *. destruct n; simpl in *; try discriminate.
inv H. auto.
Qed.
(* "unlifting" operation which requires empty locals and memories *)
Program Definition lift_nat (P:pred nat) : pred world :=
fun x => P (fst x) /\ identity (fst (snd x)) /\ identity (snd (snd x)).
Next Obligation.
repeat intro.
destruct a; destruct a'.
hnf in H. simpl in H.
destruct n; simpl in *; try discriminate.
inv H. intuition.
apply pred_hereditary with (S n0).
reflexivity.
auto.
Qed.
Coercion lift_loc : locpred >-> pred.
Coercion lift_mem : mempred >-> pred.
(* Local i has some unspecified value *)
Definition defined (i:ident) : pred world :=
EX v:val, hasval i v.
(* P is a precondition for running control k in program p. *)
Definition guards (pu:program_unit) (P:pred world) (k:ctl) : pred nat :=
lift (P --> safen pu k).
(* R is a precondition for returning into control k.  F is an additional frame.*)
Definition rguards (pu:program_unit) (R:val -> pred world) (F:pred world) (k:ctl) : pred nat :=
All e:expr, guards pu ((EX v:val, eval e v && R v) * F) (kseq (ret e) k).
(* The continuation-passing hoare tuple of partial correctness.  In short, the hoare tuple holds if, whenever the postconditions guard some continuation k, it is the case that the precondition guards (kseq c k). *)
Definition hoare_ (pu:program_unit) (R:val -> pred world) (P:pred world) (c:cmd) (Q:pred world) : pred nat :=
All k:ctl, All F:pred world,
(rguards pu R F k &&
guards pu (Q * F) k) -->
guards pu (P * F) (kseq c k).
(* We vefify programs by defining function specifications in the usual way, by defining pre and postconditions for each function.  We use an additional type 'fs_A' to allow information sharing between the pre and post.  At call sites, the verifier chooses some appropriate element of 'fs_A'.  To allow the pre and post to reasonably hold in the contexts of both the caller and the callee, they must not judge local variables directly, but rather take direct arguments representing the function actual arguments and return value. *)
Inductive fun_spec : Type :=
{ fs_A : Type
; fs_pre : fs_A -> list val -> pred world
; fs_post : fs_A -> val -> pred world
; fs_pre_empty_locals :
forall a vs w, fs_pre a vs w -> identity (fst (snd w))
; fs_post_empty_locals :
forall a v w, fs_post a v w -> identity (fst (snd w))
}.
(* A program spec defines specifications for some subset of the function identifiers. *)
Definition prog_spec := ident -> option fun_spec.
(* Given a function declaration and a list of actual arguments, this function constructs a formula in SL which describes the initial local variable environment of a function. *)
Definition func_start_locals (fd:fun_decl) (vs:list val) : pred world :=
let xs := combine (fnd_formals fd) vs ++ (fnd_locals fd) in
fold_right (fun iv P => hasval (fst iv) (snd iv) * P) emp xs.
(* The precondition for verifying function bodies.  It combines the function specification precondition with the local variables avaliable at the start of the function. *)
Definition func_pre (fd:fun_decl) (fs:fun_spec) (a:fs_A fs) : pred world :=
EX vs:list val, fs_pre fs a vs * func_start_locals fd vs.
(* The return postcondition for verifying function bodies.  *)
Definition func_post (fs:fun_spec) (a:fs_A fs) : val -> pred world :=
fun v => fs_post fs a v * anylocals.
(* We say a function 'i' satisfies a function spec in a program 'pu' provided the function has some declaration and that declaration (approximately) satifies a hoare tuple describing the expected behavior of the function body. *)
Definition satisfies_fun_spec (pu:program_unit) (i:ident) (fs:fun_spec) : pred nat :=
EX fd:fun_decl, !!(pu i = Some fd) &&
All a:(fs_A fs), |>hoare_ pu (func_post fs a) (func_pre fd fs a) (fnd_cmd fd) FF.
(* A program satisfies a program spec if each claimed function spec is satisfied. *)
Definition satisfies_spec (pu:program_unit) (ps:prog_spec) : pred nat :=
All i:ident, All fs:fun_spec, !!(ps i = Some fs) --> satisfies_fun_spec pu i fs.
(* The validate predicate represents a state of partial verification. We have assumed that ps holds for call sites, and we have proved under these assumptions that ps' holds.  Typically ps' is a subset of ps.  Validation is completed if ps = ps'. *)
Definition validate (ps:prog_spec) (pu:program_unit) (ps':prog_spec) :=
|>satisfies_spec pu ps |-- satisfies_spec pu ps'.
(* Some facts about evaluation.  Most importantly, Evaluation passes into larger worlds. *)
(* Simultaneous evaluation of a list of expressions *)
Fixpoint list_eval (es:list expr) (vs:list val) : pred world :=
match es, vs with
| e::es', v::vs' => eval e v && list_eval es' vs'
| nil, nil => TT
| _, _ => FF
end.
(** Proofs about validation. **)
(** Now we prove the hoare rules. **)
(** Now the main hoare rules **)

Lemma hoare_while_wp : forall ps R e c Q,
TT |-- hoare_ ps R
(EX I:pred world,
(lift_nat
(hoare_ ps R
(EX v:nat, eval e (int_val v) && !!(v <> 0) && I)
c
(EX v:nat, eval e (int_val v) && I))) *
(lift_nat (lift (eval e (int_val 0) && I --> Q))) *
(EX v:nat, eval e (int_val v) && I))
(while e c)
Q.