(*+ Specifications *)
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 preservation n x y : x ===> y -> invariant (S n) x -> invariant n y.
Inductive csafe : nat -> config -> Prop :=
| csafe_0 sch thd pool : csafe 0 (sch, thd, pool)
| csafe_halted n thd pool : csafe n (nil, thd, pool)
| csafe_core n sch thd pool thd' pool' :
machine (sch, thd, pool) (sch, thd', pool') ->
csafe n (sch, thd', pool') ->
csafe (S n) (sch, thd, pool)
| csafe_sch n i sch thd pool thd' pool' :
machine (i :: sch, thd, pool) (sch, thd', pool') ->
(forall sch', csafe n (sch', thd', pool')) ->
csafe (S n) (i :: sch, thd, pool).