(*+ Reasoning about oracular safety *)
(* In this file, we use the same notion as safety as in the rest of VST and we define oracular specifications (specifications that can reason about the oracle) to simulate, in term of safety, the bad/good oracle rules, through the WITH variable (x, below).  Because those are too complicated to reason about in the program logic, we also define "clean" specifications (that require nothing about the oracle).  Because the "dirty" specifications are only using the oracle in a "optimist" way, oracular safety is actually easier to prove, which can be stated through the theorem "clean safety => dirty safety". (which one should read as "safety for oracular-aware specifications" is less strong than regular safety) *)
Definition val := nat.
Variable C' : Set.
Inductive C : Set :=
| acquire : val -> C -> C
| release : val -> C -> C
| normal : C' -> C.
Definition M := val -> option nat.
Variable corestep : C' -> M -> C' -> M -> Prop.
Variable islock : val -> (M -> Prop) -> M -> Prop.
Variable islock_inj : forall v R1 R2 m, islock v R1 m -> islock v R2 m -> R1 = R2.
Definition Z := list M.
Record ext : Type := mkext {
ext_type : Type;
Pre : ext_type -> Z -> M -> Prop;
Post : ext_type -> Z -> M -> Prop
}.
Definition good_oracle (Ω : list M) (R : M -> Prop) := exists m Ω', Ω = cons m Ω' /\ R m.
Definition good_oracle_old (Ω : list M) (m : M) (v : val) :=
exists R, islock v R m /\ exists mlock Ω', Ω = cons mlock Ω' /\ R mlock.
Definition tail {A} (l : list A) := match l with nil => None | cons _ l => Some l end.
(*+ "Oracular" specifications of acquire/release *)
Definition acquire_spec_old l : ext :=
mkext
(Prop * val * list M * (M -> Prop))
(fun x Ω m =>
match x with
| (okx, lx, Ωx, Rx) =>
lx = l /\
islock l Rx m /\
(match Ω with
| nil => ~okx
| cons mlock Ω' => Ω' = Ωx /\ (Rx mlock <-> okx)
end)
end)
(fun x Ω m =>
match x with
| (okx, lx, Ωx, Rx) =>
Ω = Ωx /\
okx /\
islock lx Rx m
end).
Definition acquire_spec l : ext :=
mkext
(val * list M * (M -> Prop))
(fun x Ω m =>
match x with
| (lx, Ωx, Rx) =>
lx = l /\
islock l Rx m /\
Ω = Ωx
end)
(fun x Ω m =>
match x with
| (lx, Ωx, Rx) =>
(match Ωx with
| nil => False
| cons phi Ωx' => Ω = Ωx' /\ Rx phi
end) /\
islock lx Rx m
end).
Definition release_spec l : ext :=
mkext
(val * list M * (M -> Prop))
(fun x Ω m =>
match x with
| (lx, Ωx, Rx) =>
lx = l /\
islock l Rx m /\
Ω = Ωx
end)
(fun x Ω m =>
match x with
| (lock, Ωx, Rx) =>
Ω = Ωx /\
islock lock Rx m
end).
(*+ Definition of safety *)
Definition oracle_at_ext_old : C -> option ext :=
fun c =>
match c with
| acquire l _ => Some (acquire_spec_old l)
| release l _ => Some (release_spec l)
| _ => None
end.
Definition oracle_at_ext : C -> option ext :=
fun c =>
match c with
| acquire l _ => Some (acquire_spec l)
| release l _ => Some (release_spec l)
| _ => None
end.
Definition after_external : C -> option C :=
fun c =>
match c with
| acquire _ k => Some k
| release _ k => Some k
| _ => None
end.
Variable Hrel : nat -> M -> M -> Prop.
Variable Hrel_islock : forall n m m' R v, Hrel n m m' -> islock v R m -> islock v R m'.
Inductive safeN_ (at_ext : C -> option ext) : nat -> Z -> C -> M -> Prop :=
safeN_0 : forall (z : Z) (c : C) (m : M), safeN_ at_ext 0 z c m
| safeN_step : forall (n : nat) (z : Z) (c c' : C') (m m' : M),
corestep c m c' m' ->
safeN_ at_ext n z (normal c') m' ->
safeN_ at_ext (S n) z (normal c) m
| safeN_external : forall (n : nat) (z : Z) (c : C) (m : M) (e : ext) (x : ext_type e),
at_ext c = Some e ->
Pre e x z m ->
(forall (m' : M) (z' : Z) (n' : nat),
n' <= n ->
Hrel n' m m' ->
Post e x z' m' ->
exists c' : C,
after_external c = Some c' /\
safeN_ at_ext n' z' c' m') ->
safeN_ at_ext (S n) z c m.
(*+ New way of writing specs *)
(*+ Intuition of "good oracle" rule *)
(*+ Intuition of "bad oracle" rule *)
(*+ "Clean" specifications not mentioning oracle *)
Definition clean_acquire_spec l : ext :=
mkext
(val * (M -> Prop))
(fun x Ω m =>
match x with
| (lx, Rx) =>
lx = l /\
islock l Rx m
end)
(fun x Ω m =>
match x with
| (lx, Rx) =>
islock lx Rx m
end).
Definition clean_release_spec l : ext :=
mkext
(val * (M -> Prop))
(fun x Ω m =>
match x with
| (lx, Rx) =>
lx = l /\
islock l Rx m
end)
(fun x Ω m =>
match x with
| (lock, Rx) =>
islock lock Rx m
end).
Definition clean_at_ext : C -> option ext :=
fun c =>
match c with
| acquire l _ => Some (clean_acquire_spec l)
| release l _ => Some (clean_release_spec l)
| _ => None
end.
(*+ Proof that clean safety => dirty safety *)
Open Scope list_scope.
(* no need for excluded middle thanks to the trick in the spec (ok <-> R mlock instead of doing the case analysis (e.g. ok = true <-> R mlock) *)
(*+ Parallel composition of safety *)
(*+ BELOW, THE OTHER FILE *)
(*+ Small concurrent stack *)
(** In this file: - a single-theaded semantics (with oracle and invariants) - a multi-thread concurrent machine (with schedule and invariants) - proof that the safety of all threads implies the safety of the machine - a hoare logic implying safety in the oracle semantics - a small example yielding safety of the corresponding machine *)
(* we can remove the need for functional extensionality, at the expense of heavier definitions and proofs, with [m |= P] defined as [forall m', eqmap m m' -> P m'] instead of [P m] *)
(*+ Syntax *)
Definition instruction := C.
(*+ General results about safety *)
Definition Rel X := X -> X -> Prop.
Inductive star {X} (R : Rel X) : Rel X :=
| star_refl x : star R x x
| star_cons x y z : R x y -> star R y z -> star R x z.
Definition safe {X} (R : Rel X) x := forall y, star R x y -> exists z, R y z.
(*! Indexed version of safety (not needed here) *)
Inductive iter {X} (R : Rel X) : nat -> Rel X :=
| iter_O x : iter R O x x
| iter_S n x y z : R x y -> iter R n y z -> iter R (S n) x z.
Definition safe_ n {X} (R : Rel X) x := forall y m, m < n -> iter R m x y -> exists z, R y z.
(*+ Stdlib: some list functions *)
Fixpoint nth {A} (l : list A) i :=
match l with
| nil => None
| x :: l =>
match i with
| O => Some x
| S i => nth l i
end
end.
Fixpoint nth_upd {A} (l : list A) i x :=
match l with
| nil => nil
| y :: l =>
match i with
| O => x :: l
| S i => y :: nth_upd l i x
end
end.
Ltac ifeq :=
match goal with
[ H : context [ eq_nat_dec ?x ?x ] |- _ ] => destruct (eq_nat_dec x x) as [_|]; [|congruence]
| [ |- context [ eq_nat_dec ?x ?x ] ] => destruct (eq_nat_dec x x) as [_|]; [|congruence]
| [ H : context [ eq_nat_dec ?x ?y ] |- _ ] => destruct (eq_nat_dec x y)
| [ |- context [ eq_nat_dec ?x ?y ] ] => destruct (eq_nat_dec x y)
end.
(*+ Memory maps *)
Definition map := M.
Definition emptymap : map := fun _ => None.
Definition eqmap (m m' : map) := forall x, m x = m' x.
Instance eqmap_equiv : Equivalence eqmap.
Definition upd {A} (m : nat -> A) x e :=
fun y => if eq_nat_dec x y then e else m y.
Definition updatemap (m : map) (x e : nat) : option map :=
match m x with Some _ => Some (upd m x (Some e)) | None => None end.
Definition assertmap (m : map) (x : nat) : Prop :=
match m x with Some (S _) => True | _ => False end.
Definition joincell (a b : option nat) : option (option nat) :=
match a, b with
| None, None => Some None
| Some a, None | None, Some a => Some (Some a)
| Some _, Some _ => None
end.
Definition join (m n o : map) : Prop := forall x, joincell (m x) (n x) = Some (o x).
Definition joins (m n : map) : Prop := exists o, join m n o.
Add Parametric Morphism : join with signature eqmap ==> eqmap ==> eqmap ==> iff as join_morphism.
Definition joincell_split {a b ab c abc} :
joincell a b = Some ab -> joincell ab c = Some abc ->
{ bc | joincell b c = Some bc /\ joincell a bc = Some abc }.
Hint Resolve
join_emptymap_l
join_emptymap_r
joins_emptymap_l
joins_emptymap_r
join_comm
joins_sym.
Definition empty (m : map) : Prop := forall x, m x = None.
Definition nonempty (m : map) : Prop := exists x, m x <> None.
(*+ Predicates *)
Definition pred := map -> Prop.
Definition sat (m : map) (P : pred) : Prop := P m.
(* Definition sat (m : map) (P : pred) : Prop := forall n, eqmap m n -> P n. *)
Infix " |= " := sat (at level 40).
Definition emp : pred := fun m => forall n, m n = None.
Definition TT : pred := fun m => True.
Definition FF : pred := fun m => False.
Definition imp (P Q : pred) : Prop := forall m, m |= P -> m |= Q.
Definition sepcon (P Q : pred) : pred :=
fun m => exists m1 m2, join m1 m2 m /\ P m1 /\ Q m2.
Infix "**" := sepcon (at level 30).

Lemma imp_sepcon P Q F : imp P Q -> imp (P ** F) (Q ** F).