(*+ 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).
Definition pequiv (P Q : pred) := forall m, P m <-> Q m.
Infix " == " := pequiv (at level 50, no associativity).
Definition subheap m o := exists n, join m n o.
Definition precise (R : pred) : Prop := forall o m1 m2,
m1 |= R -> m2 |= R ->
subheap m1 o -> subheap m2 o -> eqmap m1 m2.
Definition mapsto x v : pred := fun m => forall n, m n = if eq_nat_dec x n then Some v else None.
Definition mapsto_ x : pred := fun m => forall n, if eq_nat_dec x n then m n <> None else m n = None.
(*+ Oracular semantics *)
(** Single-thread oracular semantics: each thread assumes that the oracle provides maps satisfying the invariants, but the thread also have to give back maps that satisfy those invariants. *)
Record globals := mkglobals
{ resinvs : nat -> pred (* resource invariant for each lock *) ;
funspecs : string -> option pred (* precondition of each function *)
}.
Reserved Notation " c1 ---> c2 " (at level 50).
Definition oracle := list map.
Inductive step : Rel (globals * oracle * map * C) :=
(* | step_halted G oracle m : (G, oracle, m, nil) ---> (G, oracle, m, nil) *)
| step_core G oracle c c' m m' :
corestep c m c' m' ->
(G, oracle, m, normal c) --->
(G, oracle, m', normal c')
| step_release G oracle m mlock m' l p :
mlock |= resinvs G l ->
join m' mlock m ->
(G, oracle, m, release l p) --->
(G, oracle, m', p)
| step_acquire G oracle m mlock m' l p :
mlock |= resinvs G l ->
join m mlock m' ->
(G, mlock :: oracle, m, acquire l p) --->
(G, oracle, m', p)
| step_acquire_wrong_oracle G oracle m mlock l p :
~(mlock |= resinvs G l /\ joins m mlock) ->
(G, mlock :: oracle, m, acquire l p) --->
(G, mlock :: oracle, m, acquire l p)
| step_acquire_empty_oracle G m l p :
(G, nil, m, acquire l p) --->
(G, nil, m, acquire l p)
(* | step_spawn G PRE oracle m mspawned m' f p : funspecs G f = Some PRE -> mspawned |= PRE -> join m' mspawned m -> (G, oracle, m, spawn f :: p) ---> (G, oracle, m', p) *)
where
" c1 ---> c2 " := (step  c1 c2).
(* oh wait that was supposed to be defined in terms of safety  MAYBE prove jsafeN => safety wrt these steps AND THEN => safety of the machine  *)
Hint Constructors step.
(*+ Concurrent machine *)
(** Semantics of the collection of all threads. Thread and locked locks each have their own map. *)
Definition schedule := list nat.
Definition threads := list (map * C).
Definition lockpool := val -> option map.
Definition functions := string -> option C.
Definition config := (schedule * functions * globals * threads * lockpool)%type.
Reserved Notation " c1 ===> c2 " (at level 50).
(** reasons for having a list of threads rather than a function nat -> option thread ? 1) It's a bit more deterministic and hence slighlty easier to prove sound.  2) We can always allocate new threads. 3) people prefer that, apparently *)
Inductive machine : Rel config :=
| machine_outofschedule F G thd pool :
(nil, F, G, thd, pool) ===>
(nil, F, G, thd, pool)
| machine_scheduleoutofbound i sch F G thd pool :
nth thd i = None ->
(i :: sch, F, G, thd, pool) ===>
(sch, F, G, thd, pool)
| machine_core i sch F G thd c c' m m' pool :
corestep c m c' m' ->
nth thd i = Some (m, normal c) ->
(i :: sch, F, G, thd, pool) ===>
(i :: sch, F, G, nth_upd thd i (m', normal c'), pool)
| machine_release i sch F G thd m mlock m' l p pool :
nth thd i = Some (m, release l p) ->
mlock |= resinvs G l ->
join m' mlock m ->
(i :: sch, F, G, thd, pool) ===>
(sch, F, G, nth_upd thd i (m', p), upd pool l (Some mlock))
| machine_acquire_failure i sch F G thd m l p pool :
nth thd i = Some (m, acquire l p) ->
pool l = None (* locked *) ->
(i :: sch, F, G, thd, pool) ===>
(sch, F, G, thd, pool)
| machine_acquire_success i sch F G thd m mlock m' l p pool :
nth thd i = Some (m, acquire l p) ->
pool l = Some mlock (* unlocked *) ->
join m mlock m' ->
(i :: sch, F, G, thd, pool) ===>
(i :: sch, F, G, nth_upd thd i (m', p), upd pool l None)
(* | machine_halted i sch F G thd m pool : nth thd i = Some (m, nil) -> (i :: sch, F, G, thd, pool) ===> (sch, F, G, thd, pool) | machine_spawn i sch F G PRE thd m mspawned prog m' f p pool : nth thd i = Some (m, spawn f :: p) -> funspecs G f = Some PRE -> mspawned |= PRE -> F f = Some prog -> join m' mspawned m -> (i :: sch, F, G, thd, pool) ===> (sch, F, G, nth_upd thd i (m', p) ++ (mspawned, prog) :: nil, pool) *)
where
" c1 ===> c2 " := (machine c1 c2).
(** Note that we do not consume the schedule in machine_set, machine_assert and machine_aquire_success.  We could, which would make the semantics more fine-grained (the proofs below are not affected at all by this change) *)
Hint Constructors machine.
(*+ Collection of disjoint maps *)
(** For the proof of composition of safety, we need to maintain the invariants "all the maps are disjoint*" which is why we need this section.  * pairwise-disjointness is equivalent to arbitrary disjointness because the permissions are "set-theoretical" *)
Definition selfjoins {A} (maps : A -> map) :=
forall i j, i <> j -> joins (maps i) (maps j).
Definition sameperms (m n : map) := forall x, m x = None <-> n x = None.
Hint Resolve sameperms_refl sameperms_sym sameperms_trans.
Hint Resolve sameperms_updatemap.
Definition swapped {A} (m1 m2 : A -> map) i j a b c d :=
m1 i = a /\
m1 j = b /\
m2 i = c /\
m2 j = d /\
forall k, k <> i -> k <> j -> m1 k = m2 k.
Definition reindex (thd:threads) pool : _ -> map :=
fun x : nat + nat =>
match x with
| inl n =>
match nth thd n with
| Some (m, _) => m
| None => emptymap
end
| inr n =>
match pool n with
| Some m => m
| None => emptymap
end
end.

Lemma natnateqdec (x y : nat + nat) : {x=y}+{x<>y}. repeat decide equality. Defined.