(** * Bare (no permissions) Interleaving Machine *)
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.
(*NOTE: because of redefinition of [val], these imports must appear after Ssreflect eqtype.*)
Module BareMachine.
Section BareMachine.
(** Assume some threadwise semantics *)
Context {Sem: Semantics}.
(** This machine has no permissions or other logical info *)
Instance resources : Resources :=
{| res := unit; lock_info := unit |}.
Notation C:= (@semC Sem).
Notation G:= (@semG Sem).
Notation semSem:= (@semSem Sem).
Existing Instance OrdinalPool.OrdinalThreadPool.
(** Memories*)
Definition richMem: Type := mem.
Definition dryMem: richMem -> mem:= id.
Notation thread_pool := (@t resources Sem).
(** The state respects the memory*)
Definition mem_compatible (tp : thread_pool) (m : mem) : Prop := True.
Definition invariant (tp : thread_pool) := True.
(** Steps*)
Inductive thread_step {tid0 tp m} (cnt: containsThread tp tid0)
(Hcompatible: mem_compatible tp m) :
thread_pool -> mem -> seq mem_event -> Prop :=
| step_thread :
forall (tp':thread_pool) c m' (c' : C) ev
(Hcode: getThreadC cnt = Krun c)
(Hcorestep: ev_step semSem c m ev c' m')
(Htp': tp' = updThreadC cnt (Krun c')),
thread_step cnt Hcompatible tp' m' ev.
Inductive ext_step {tid0 tp m} (*Can we remove genv from here?*)
(cnt0:containsThread tp tid0)(Hcompat:mem_compatible tp m):
thread_pool -> mem -> sync_event -> Prop :=
| step_acquire :
forall (tp' : thread_pool) c m' b ofs
(Hcode: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external semSem c m =
Some (LOCK, Vptr b ofs::nil))
(Hload: Mem.load Mint32 m b (Ptrofs.intval ofs) = Some (Vint Int.one))
(Hstore: Mem.store Mint32 m b (Ptrofs.intval ofs) (Vint Int.zero) = Some m')
(Htp': tp' = updThreadC cnt0 (Kresume c Vundef)),
ext_step cnt0 Hcompat tp' m' (acquire (b, Ptrofs.intval ofs) None)
| step_release :
forall (tp':thread_pool) c m' b ofs
(Hcode: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external semSem c m =
Some (UNLOCK, Vptr b ofs::nil))
(Hstore: Mem.store Mint32 m b (Ptrofs.intval ofs) (Vint Int.one) = Some m')
(Htp': tp' = updThreadC cnt0 (Kresume c Vundef)),
ext_step cnt0 Hcompat tp' m' (release (b, Ptrofs.intval ofs) None)
| step_create :
forall (tp_upd tp':thread_pool) c b ofs arg
(Hcode: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external semSem c m =
Some (CREATE, Vptr b ofs::arg::nil))
(Htp_upd: tp_upd = updThreadC cnt0 (Kresume c Vundef))
(Htp': tp' = addThread tp_upd (Vptr b ofs) arg tt),
ext_step cnt0 Hcompat tp' m (spawn (b, Ptrofs.intval ofs) None None)
| step_mklock :
forall  (tp': thread_pool) c m' b ofs
(Hcode: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external semSem c m =
Some (MKLOCK, Vptr b ofs::nil))
(Hstore: Mem.store Mint32 m b (Ptrofs.intval ofs) (Vint Int.zero) = Some m')
(Htp': tp' = updThreadC cnt0 (Kresume c Vundef)),
ext_step cnt0 Hcompat tp' m' (mklock (b, Ptrofs.intval ofs))
| step_freelock :
forall (tp' tp'': thread_pool) c b ofs
(Hcode: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external semSem c m =
Some (FREE_LOCK, Vptr b ofs::nil))
(Htp': tp' = updThreadC cnt0 (Kresume c Vundef)),
ext_step cnt0 Hcompat  tp' m (freelock (b,Ptrofs.intval ofs))
| step_acqfail :
forall  c b ofs
(Hcode: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external semSem c m =
Some (LOCK, Vptr b ofs::nil))
(Hload: Mem.load Mint32 m b (Ptrofs.intval ofs) = Some (Vint Int.zero)),
ext_step cnt0 Hcompat tp m (failacq (b, Ptrofs.intval ofs)).
Definition threadStep: forall {tid0 ms m},
containsThread ms tid0 -> mem_compatible ms m ->
thread_pool -> mem -> seq mem_event -> Prop:=
@thread_step.
Definition syncStep (isCoarse:bool) :
forall {tid0 ms m},
containsThread ms tid0 -> mem_compatible ms m ->
thread_pool -> mem -> sync_event -> Prop:=
@ext_step.

(* Specifications: *)
Lemma threadStep_at_Krun:
forall i tp m cnt cmpt tp' m' tr,
@threadStep i tp m cnt cmpt tp' m' tr ->
(exists q, @getThreadC _ _ _ i tp cnt = Krun q).
Lemma threadStep_equal_run:
forall i tp m cnt cmpt tp' m' tr,
@threadStep i tp m cnt cmpt tp' m' tr ->
forall j,
(exists cntj q, @getThreadC _ _ _ j tp cntj = Krun q) <->
(exists cntj' q', @getThreadC _ _ _ j tp' cntj' = Krun q').
Lemma syncstep_equal_run:
forall b i tp m cnt cmpt tp' m' tr,
@syncStep b i tp m cnt cmpt tp' m' tr ->
forall j,
(exists cntj q, @getThreadC _ _ _ j tp cntj = Krun q) <->
(exists cntj' q', @getThreadC _ _ _ j tp' cntj' = Krun q').
Lemma syncstep_not_running:
forall b i tp m cnt cmpt tp' m' tr,
@syncStep b i tp m cnt cmpt tp' m' tr ->
forall cntj q, ~ @getThreadC _ _ _ i tp cntj = Krun q.