(*+ 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 *)
Inductive instruction :=
| set (x e:nat)      (* mem[x] := e *)
| assert (x:nat)     (* assert mem[x]<>0 *)
| release (l:nat)    (* unlocking a lock *)
| acquire (l:nat)    (* locking a lock *)
| spawn (f:string) (* spawning function f *).
(** spawning could be replaced with  | spawn (p : list instruction)  and then when reaching it in the oracular semantics, the oracle says how the current map is split [NO! the oracle would say which map you're given when you do JOIN, but the safety of the thread has to provide which map to give away], and then the oracle itself is (interleaving)-split into two.  We could also write  | par (p1 p2 : list instruction)  and do the same.  We adopt the spawning with an ID instead because it's closer to the architecture of VST *)
(*+ 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 := nat -> option nat.
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 * list instruction) :=
| step_halted G oracle m :
(G, oracle, m, nil) --->
(G, oracle, m, nil)
| step_set G oracle m m' x e p :
updatemap m x e = Some m' ->
(G, oracle, m, set x e :: p) --->
(G, oracle, m', p)
| step_assert G oracle m x p :
assertmap m x ->
(G, oracle, m, assert x :: p) --->
(G, oracle, m, p)
| 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).
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 * list instruction).
Definition lockpool := nat -> option map.
Definition functions := string -> option (list instruction).
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_set i sch F G thd m m' x e p pool :
nth thd i = Some (m, set x e :: p) ->
updatemap m x e = Some m' ->
(i :: sch, F, G, thd, pool) ===>
(i :: sch, F, G, nth_upd thd i (m', p), pool)
| machine_assert i sch F G thd m x p pool :
nth thd i = Some (m, assert x :: p) ->
assertmap m x ->
(i :: sch, F, G, thd, pool) ===>
(i :: sch, F, G, nth_upd thd i (m, p), 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.