(*+ 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. *)
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.

(* Specifications: *)
Lemma sameperms_refl m : sameperms m m.
Lemma sameperms_sym m n : sameperms m n -> sameperms n m.
Lemma sameperms_trans m n o : sameperms m n -> sameperms n o -> sameperms m o.
Hint Resolve sameperms_refl sameperms_sym sameperms_trans.
Lemma sameperms_updatemap m x e m' : updatemap m x e = Some m' -> sameperms m m'.
Lemma sameperms_joins m m' n : sameperms m m' -> joins m n -> joins m' n.
Hint Resolve sameperms_updatemap.
Lemma selfjoins_sameperms_compat {A} maps1 maps2 : (forall i:A, sameperms (maps1 i) (maps2 i)) -> selfjoins maps1 -> selfjoins maps2.
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.
Lemma selfjoins_swapped {A} {m1 m2 : A -> map} (Adec:forall x y:A,{x=y}+{x<>y})
i j (J:selfjoins m1) e a b c d :
swapped m1 m2 i j a b c d ->
join a b e ->
join c d e ->
selfjoins m2.