Section HybridMachineSig.
Variable n: option nat.
Context {resources: Resources}
{Sem: Semantics}
{ThreadPool : ThreadPool.ThreadPool}
{DilMem : DiluteMem}.
Definition thread_pool := ThreadPool.t.
Definition C:= (@semC Sem).
Definition G:= (@semG Sem).
Local Notation ctl := (@ctl C).
Class MachineSig :=
{
richMem: Type
; dryMem: richMem -> mem
(** The thread pool respects the memory*)
; mem_compatible: thread_pool -> mem -> Prop
; invariant: thread_pool -> Prop
; install_perm: forall {ms m tid},
mem_compatible ms m -> containsThread ms tid -> mem -> Prop
; add_block: forall {ms m tid},
mem_compatible ms m -> containsThread ms tid -> mem -> res
(** Step relations *)
; threadStep:
forall {tid0 ms m},
containsThread ms tid0 -> mem_compatible ms m ->
thread_pool -> mem -> seq mem_event -> Prop
; 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)
;  threadStep_equal_run:
forall i tp m cnt cmpt tp' m' tr,
@threadStep i tp m cnt cmpt tp' m' tr ->
forall (j: nat),
(exists cntj q, @getThreadC _ _ _ j tp cntj = Krun q) <->
(exists cntj' q', @getThreadC _ _ _ j tp' cntj' = Krun q')
; syncStep:
bool -> (* if it's a Coarse machine. Temp solution to propagating changes. *)
forall {tid0 ms m},
containsThread ms tid0 -> mem_compatible ms m ->
thread_pool -> mem -> sync_event -> Prop
;  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')
;  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
; init_mach : option res -> mem -> thread_pool -> mem -> val -> list val -> Prop}.
Context {machineSig: MachineSig}.
Definition event_trace := (seq machine_event).
Definition schedule := (seq nat).
Definition MachState : Type:= (schedule * event_trace * t)%type.
Definition schedPeek sch: option nat:=
match sch with
nil => None
| cons hd tl => Some hd
end.
Definition schedSkip sch: (seq nat):= List.tl sch.
Definition machine_state := thread_pool.
Inductive start_thread : forall (m: mem) {tid0} {ms:machine_state},
containsThread ms tid0 -> machine_state -> mem -> Prop:=
| StartThread: forall m m' m_new tid0 ms ms' c_new vf arg
(ctn: containsThread ms tid0)
(Hcode: getThreadC ctn = Kinit vf arg)
(Hcmpt: mem_compatible ms m)
(Hperm: install_perm Hcmpt ctn m')
(Hinitial: initial_core semSem tid0
m' c_new m_new vf (arg::nil))
(Hinv: invariant ms)
(Hms': updThread ctn (Krun c_new) (add_block Hcmpt ctn m_new) = ms'),
(* (Hcmpt': mem_compatible ms' m_new) *)
(* (Hinv': invariant ms')*)
start_thread m ctn ms' m_new.
(** Resume and Suspend: threads running must be preceded by a Resume and followed by Suspend.  This functions wrap the state to indicate it's ready to take a syncronisation step or resume running. (This keeps the invariant that at most one thread is not at_external) *)
Inductive resume_thread' : forall (m: mem) {tid0} {ms:machine_state},
containsThread ms tid0 -> machine_state -> Prop:=
| ResumeThread: forall m tid0 ms ms' c c' X m'
(ctn: containsThread ms tid0)
(Hcmpt: mem_compatible ms m)
(Hperm: install_perm Hcmpt ctn m')
(Hat_external: at_external semSem c m' = Some X)
(Hafter_external: after_external semSem None c m' = Some c')
(Hcode: getThreadC ctn = Kresume c Vundef)
(Hinv: invariant ms)
(Hms': updThreadC ctn (Krun c')  = ms'),
resume_thread' m ctn ms'.
Definition resume_thread: forall m {tid0 ms},
containsThread ms tid0 -> machine_state -> Prop:=
@resume_thread'.
Inductive suspend_thread': forall m {tid0} {ms:machine_state},
containsThread ms tid0 -> machine_state -> Prop:=
| SuspendThread: forall m tid0 ms ms' c X m'
(ctn: containsThread ms tid0)
(Hcmpt: mem_compatible ms m)
(Hcode: getThreadC ctn = Krun c)
(Hperm: install_perm Hcmpt ctn m')
(Hat_external: at_external semSem c m'  = Some X)
(Hinv: invariant ms)
(Hms': updThreadC ctn (Kblocked c) = ms'),
suspend_thread' m ctn ms'.
Definition suspend_thread: forall (m: mem) {tid0 ms},
containsThread ms tid0 -> machine_state -> Prop:=
@suspend_thread'.
(** Provides control over scheduling. For example, for FineMach this is schedSkip, for CoarseMach this is just id *)
Class Scheduler :=
{ isCoarse : bool;
yield: schedule -> schedule}.
Context {scheduler : Scheduler}.
Inductive machine_step:
schedule -> event_trace -> machine_state -> mem -> schedule ->
event_trace -> machine_state -> mem -> Prop :=
| start_step:
forall tid U ms ms' m m' tr
(HschedN: schedPeek U = Some tid)
(Htid: containsThread ms tid)
(Htstep: start_thread m Htid ms' m'),
machine_step U tr ms m (yield U) tr ms' (diluteMem m')
| resume_step:
forall tid U ms ms' m tr
(HschedN: schedPeek U = Some tid)
(Htid: containsThread ms tid)
(Htstep: resume_thread m Htid ms'),
machine_step U tr ms m (yield U) tr ms' m
| thread_step:
forall tid U ms ms' m m' ev tr
(HschedN: schedPeek U = Some tid)
(Htid: containsThread ms tid)
(Hcmpt: mem_compatible ms m)
(Htstep: threadStep Htid Hcmpt ms' m' ev),
machine_step U tr ms m (yield U)
(tr ++ (List.map (fun mev => internal tid mev) ev)) ms' (diluteMem m')
| suspend_step:
forall tid U U' ms ms' m tr
(HschedN: schedPeek U = Some tid)
(HschedS: schedSkip U = U')        (*Schedule Forward*)
(Htid: containsThread ms tid)
(Htstep:suspend_thread m Htid ms'),
machine_step U tr ms m U' tr ms' m
| sync_step:
forall tid U U' ms ms' m m' ev tr
(HschedN: schedPeek U = Some tid)
(HschedS: schedSkip U = U')        (*Schedule Forward*)
(Htid: containsThread ms tid)
(Hcmpt: mem_compatible ms m)
(Htstep: syncStep isCoarse Htid Hcmpt ms' m' ev),
machine_step U tr ms m U' (tr ++ [:: external tid ev]) ms' m'
| schedfail :
forall tid U U' ms m tr
(HschedN: schedPeek U = Some tid)
(Htid: ~ containsThread ms tid)
(Hinv: invariant ms)
(Hcmpt: mem_compatible ms m)
(HschedS: schedSkip U = U'),        (*Schedule Forward*)
machine_step U tr ms m U' tr ms m.
Definition MachStep (c:MachState) (m:mem)
(c':MachState) (m':mem) :=
@machine_step (fst (fst c)) (snd (fst c)) (snd c)  m
(fst (fst c')) (snd (fst c')) (snd c')  m'.
Definition at_external_mach (st : MachState) (m: mem)
: option (external_function * list val) := None.
Definition after_external_mach (ov : option val) (st : MachState) (m : mem) :
option (MachState) := None.
(*not clear what the value of halted should be*)
(*Nick: IMO, the machine should be halted when the schedule is empty. The value is probably unimportant? *)
(*Santiago: I belive empty schedule should "diverge". After all that's *)
Definition halted_machine (st : MachState) : option val :=
match schedPeek (fst (fst st)) with
| Some _ => None
| _ => Some Vundef
end.
Definition init_machine (U:schedule) (r : option res) (m: mem)
(st : MachState) (m': mem) (f : val) (args : list val)
: Prop :=
match st with (U', [::], c) => U' = U /\ init_mach r m c m' f args | _ => False end.
Program Definition MachineCoreSemantics (U:schedule) (r : option res):
CoreSemantics MachState mem.
intros.
apply (@Build_CoreSemantics MachState _
(fun n => init_machine U r)
at_external_mach
after_external_mach
(fun st i => halted_machine st = Some (Vint i)) (* this is False *)
MachStep
);
unfold at_external_mach, halted_machine; try reflexivity.
intros. inversion H; subst; rewrite HschedN; intro Hcontra; discriminate.
Defined.
Definition make_init_machine c r:=
mkPool (Krun c) r.
Definition init_machine' (the_ge : semG) m
c m' (f : val) (args : list val)
: option res -> Prop := fun op_r =>
if op_r is Some r then
init_mach op_r m (make_init_machine c r) m' f args
else False.
Definition init_machine'' (op_m: option mem)(op_r : option res)(m: mem)
(tp : thread_pool) (m': mem) (f : val) (args : list val)
: Prop :=
op_m = Some m /\
if op_r is Some r then
init_mach op_r m tp m' f args
else False.
Definition unique_Krun tp i :=
forall j cnti q,
@getThreadC _ _ _ j tp cnti = Krun q ->
eq_nat_dec i j.
simpl. destruct st as ((?, ?), ?); simpl; intros.
destruct e; [|contradiction].
destruct H; subst; eauto.
Qed.
(** The new semantics below makes internal (thread) and external (machine) steps explicit *)
Inductive internal_step:
schedule -> machine_state -> mem -> machine_state -> mem -> Prop :=
| thread_step':
forall tid U ms ms' m m' ev
(HschedN: schedPeek U = Some tid)
(Htid: containsThread ms tid)
(Hcmpt: mem_compatible ms m)
(Htstep: threadStep Htid Hcmpt ms' m' ev),
internal_step U ms m ms' (diluteMem m').
Inductive external_step:
schedule -> event_trace -> machine_state -> mem -> schedule ->
event_trace -> machine_state -> mem -> Prop :=
| start_state': forall tid U ms ms' m m' tr
(HschedN: schedPeek U = Some tid)
(Htid: containsThread ms tid)
(Htstep: start_thread m Htid ms' m'),
external_step U tr ms m (yield U) tr ms' (diluteMem m')
| resume_step':
forall tid U ms ms' m tr
(HschedN: schedPeek U = Some tid)
(Htid: containsThread  ms tid)
(Htstep: resume_thread m Htid ms'),
external_step U tr ms m (yield U) tr ms' m
| suspend_step':
forall tid U U' ms ms' m tr
(HschedN: schedPeek U = Some tid)
(HschedS: schedSkip U = U')        (*Schedule Forward*)
(Htid: containsThread ms tid)
(Htstep:suspend_thread m Htid ms'),
external_step U tr ms m U' tr ms' m
| sync_step':
forall tid U U' ms ms' m m' ev tr
(HschedN: schedPeek U = Some tid)
(HschedS: schedSkip U = U')        (*Schedule Forward*)
(Htid: containsThread ms tid)
(Hcmpt: mem_compatible ms m)
(Htstep: syncStep isCoarse Htid Hcmpt ms' m' ev),
external_step U tr ms m  U' (tr ++ [:: external tid ev]) ms' m'
| schedfail':
forall tid U U' ms m tr
(HschedN: schedPeek U = Some tid)
(Htid: ~ containsThread ms tid)
(Hinv: invariant ms)
(Hcmpt: mem_compatible ms m)
(HschedS: schedSkip U = U'),        (*Schedule Forward*)
external_step U tr ms m U' tr ms m.

(*Symmetry*)
(* These steps are basically the same: *)
Lemma step_equivalence1: forall U tr st m U' tr' st' m',
@machine_step U tr st m U' tr' st' m' ->
(U' = yield U /\ @internal_step U st m st' m') \/
@external_step U tr st m U' tr' st' m'.