(*+ CSL to progress and preservation *)
(* In this file, we use the same notion of thread safety as in the rest of VST, which is defined using specifications for external functions. In the rest of VST, we derive safety of the concurrent (juicy) machine from [progress] and [preservation] of an invariant.  We give a toy version of those definitions and proofs here, simplifying greatly problems related to step indexing, external calls and spawning. *)
(* standard files distributed with Coq *)
(* local file *)
Definition interp_lock := resourcemaps.interp_lock.
Definition islock (l : nat) (R : map -> Prop) (m : map) :=
exists lock, m l = Some (inr lock) /\ interp_lock lock = R.
intros v R1 R2 m [lock1 [E1 H1]] [lock2 [E2 H2]].
congruence.
Qed.
(*+ Core steps *)
Variable C' : Set.
Variable corestep : C' -> map -> C' -> map -> Prop.
Variable corestep_fun : forall c m c1 m1 c2 m2,
corestep c m c1 m1 ->
corestep c m c2 m2 ->
c1 = c2 /\ m1 = m2.
Variable corestep_sameperms : forall c m c' m', corestep c m c' m' -> sameperms m m'.
Variable corestep_samelocks : forall c m c' m' l lock,
corestep c m c' m' -> (m l = Some (inr lock) <-> m' l = Some (inr lock)).
Variable cancellative : forall m1 m1' m2 m3, join m1 m2 m3 -> join m1' m2 m3 -> m1 = m1'.
(** Concurrent instructions are built on top of those [C'] *)
Inductive C : Set :=
| acquire : nat -> C -> C
| release : nat -> C -> C
| normal : C' -> C.
(*+ Joinability hypotheses *)
(* Those lemmas can be proved if the support set of maps is finite. We omit those for conveninence, here. *)
Variable jointo : forall {A} (maps : A -> map) (m : map), Prop.
(*+ Definition of safety *)
(* We define safety based on specification of externals (acquire and release) *)
(* no need for an oracle, so it is unit *)
Definition Z := unit.
Record ext : Type := mkext {
ext_type : Type;
Pre : ext_type -> Z -> map -> Prop;
Post : ext_type -> Z -> map -> Prop
}.
Definition after_external : C -> option C :=
fun c =>
match c with
| acquire _ k => Some k
| release _ k => Some k
| _ => None
end.
(* [Hrel] is related to step indexing levels, and specify that the PURE of the maps coincide, which is always implied by joinability *)
Variable Hrel : nat -> map -> map -> Prop.
Inductive safeN_ (at_ext : C -> option ext) : nat -> Z -> C -> map -> Prop :=
safeN_0 : forall (z : Z) (c : C) (m : map), safeN_ at_ext 0 z c m
| safeN_step : forall (n : nat) (z : Z) (c c' : C') (m m' : map),
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 : map) (e : ext) (x : ext_type e),
at_ext c = Some e ->
Pre e x z m ->
(forall (m' : map) (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.
(*+ Specifications *)
Definition acquire_spec l : ext :=
mkext
(nat * (map -> Prop))
(fun x Ω m =>
match x with
| (lx, Rx) =>
lx = l /\
islock l Rx m
end)
(fun x Ω m =>
exists m1 m2,
join m1 m2 m /\
match x with
| (lx, Rx) =>
islock lx Rx m1 /\
Rx m2
end).
Definition release_spec l : ext :=
mkext
(nat * (map -> Prop))
(fun x Ω m =>
exists m1 m2,
join m1 m2 m /\
match x with
| (lx, Rx) =>
lx = l /\
islock l Rx m1 /\
precise Rx /\
Rx m2
end)
(fun x Ω m =>
match x with
| (lock, Rx) =>
islock lock Rx m
end).
Definition at_ext : C -> option ext :=
fun c =>
match c with
| acquire l _ => Some (acquire_spec l)
| release l _ => Some (release_spec l)
| _ => None
end.
(*+ 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 := nat -> option (option map).
Definition config := (schedule * threads * lockpool)%type.
Reserved Notation " c1 ===> c2 " (at level 50).
Definition there_is_a_lock_at (m : map) (l : nat) :=
exists lock,
m l = Some (inr lock).
Definition map_matches_lock_at (m : map) (l : nat) (mlock : map) :=
exists lock,
m l = Some (inr lock) /\
interp_lock lock mlock.
Inductive machine : config -> config -> Prop :=
| machine_outofschedule thd pool :
(nil, thd, pool) ===>
(nil, thd, pool)
| machine_scheduleoutofbound i sch thd pool :
nth thd i = None ->
(i :: sch, thd, pool) ===>
(sch, thd, pool)
| machine_core i sch thd c c' m m' pool :
corestep c m c' m' ->
nth thd i = Some (m, normal c) ->
(i :: sch, thd, pool) ===>
(i :: sch, nth_upd thd i (m', normal c'), pool)
| machine_release i sch thd m mlock m' l p pool :
pool l <> None ->
nth thd i = Some (m, release l p) ->
(* mlock |= resinvs l -> *)
map_matches_lock_at m l mlock ->
join m' mlock m ->
(i :: sch, thd, pool) ===>
(sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
| machine_acquire_failure i sch thd m l p pool :
nth thd i = Some (m, acquire l p) ->
pool l = Some (None) (* locked *) ->
(i :: sch, thd, pool) ===>
(sch, thd, pool)
| machine_acquire_success i sch thd m mlock m' l p pool :
nth thd i = Some (m, acquire l p) ->
pool l = Some (Some mlock) (* unlocked *) ->
join m mlock m' ->
(i :: sch, thd, pool) ===>
(i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).
Hint Constructors machine.
(*+ Proving machine safety from the invariant *)
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 (Some m) => m
| Some None => emptymap
| None => emptymap
end
end.
Definition lockpool_matches_map (pool : lockpool) (Phi : map) :=
forall l,
match pool l with
| Some (Some mlock) => map_matches_lock_at Phi l mlock
| Some None => there_is_a_lock_at Phi l
| None => True
end.
Definition map_matches_lockpool (pool : lockpool) (Phi : map) :=
forall l lock,
Phi l = Some (inr lock) ->
pool l <> None.
Definition invariant n (x : config) :=
match x with (_, thd, pool) =>
exists Phi,
jointo (reindex thd pool) Phi /\
lockpool_matches_map pool Phi /\
map_matches_lockpool pool Phi /\
(forall i oracle m p,
nth thd i = Some (m, p) ->
safeN_ at_ext n oracle p m)
end.

Theorem progress n x : invariant (S n) x -> exists y, x ===> y.