(* Hybrid Machine Signature *)
(** Defines the structure of Hybrid Machines. Some notable definitions: - MachineSig: The definitions that make a machine possible. That includes The definition of thread_steps, synchronization steps and other accounting steps (resume, suspend, halt)... It also includes lemmas about the relations (e.g. syncstep_equal_halted doesn't change halted threads) - machine_step/MachStep: gathers all the posible steps of the hybrid machine in a single smallstep relation. Used to define a Core-semantics for the HybridMachine. - internal_step/external_step: two smallstep relations that together cover all possible steps of the machine. [internal_step] covers all threadsteps and external_step covers all other steps (synchronizations and accounting) - new_MachineSemantics: builds a ConcurSemantics out of a MachineSig, by using internal_step/external_step steps. - MachineCoreSemantics: defines a coresemantics for the machine, by using MachStep as a smallstep, and it's never at_external, after_external. - HybridMachine: wraps both definitions of Core-semantics and ConcurSemantics in a record. The two semantics are identical, except concure-semantics distinguishes between internal/external_step. *)
(** This file also constructs the Coarse and Finegrained HybridMachines - HybridCoarseMachine - HybridFineMachine  Moreover, it defines a notion of csafe for HybridCoarseMachine. (TODO: can this be moved elsewhere? Is this not compatible with fineMachines? *)
From mathcomp.ssreflect Require Import ssreflect seq ssrbool.
Require Export VST.concurrency.common.semantics.
(*Require Import VST.concurrency.safety. Require Import VST.concurrency.coinductive_safety.*)
Notation EXIT :=
(EF_external "EXIT" (mksignature (AST.Tint::nil) None)).
Notation CREATE_SIG := (mksignature (AST.Tint::AST.Tint::nil) None cc_default).
Notation CREATE := (EF_external "spawn" CREATE_SIG).
Notation MKLOCK :=
(EF_external "makelock" (mksignature (AST.Tptr::nil) None cc_default)).
Notation FREE_LOCK :=
(EF_external "freelock" (mksignature (AST.Tptr::nil) None cc_default)).
Notation LOCK_SIG := (mksignature (AST.Tptr::nil) None cc_default).
Notation LOCK := (EF_external "acquire" LOCK_SIG).
Notation UNLOCK_SIG := (mksignature (AST.Tptr::nil) None cc_default).
Notation UNLOCK := (EF_external "release" UNLOCK_SIG).
Module Events.
(** Synchronization Events.  The release/acquire cases include the footprints of permissions moved  when applicable*)
Definition evRes := (access_map * access_map)%type.
Definition evDelta := (delta_map * delta_map)%type.
(* Santiago July 9: On consultation with Andrew and Lennart: Turns out all we need from the traces, is the content of the observable locations (observable according to the delta_map, which is not in the trace) events now record: - delta_contents: is the memory, only with the contetns of "observable" memory *)
(*  move this to  VST.concurrency.common.permissions*)
Definition delta_content := (Maps.PTree.t (Z -> option memval)).
Inductive sync_event : Type :=
| release : address -> option delta_content -> sync_event
| acquire : address -> option delta_content -> sync_event
| mklock :  address -> sync_event
| freelock : address -> sync_event
| spawn : address -> option delta_content -> option delta_content -> sync_event
| failacq: address -> sync_event.
(** Machine Events *)
Inductive machine_event : Type :=
| internal: nat -> mem_event -> machine_event
| external : nat -> sync_event -> machine_event.
Definition thread_id ev : nat :=
match ev with
| internal i _ => i
| external i _ => i
end.
Inductive act : Type :=
| Read : act
| Write : act
| Alloc : act
| Free : act
| Release : act
| Acquire : act
| Mklock : act
| Freelock : act
| Failacq : act
| Spawn : act.
Definition is_internal ev :=
match ev with
| internal _ _ => true
| _ => false
end.
Definition is_external ev :=
match ev with
| external _ _ => true
| _ => false
end.
Definition action ev : act :=
match ev with
| internal _ mev =>
match mev with
| event_semantics.Write _ _ _ => Write
| event_semantics.Read _ _ _ _ => Read
| event_semantics.Alloc _ _ _ => Alloc
| event_semantics.Free _ => Free
end
| external _ sev =>
match sev with
| release _ _ => Release
| acquire _ _ => Acquire
| mklock _ => Mklock
| freelock _ => Freelock
| failacq _ => Failacq
| spawn _ _ _ => Spawn
end
end.
Definition location ev : option (address*nat) :=
match ev with
| internal _ mev =>
match mev with
| event_semantics.Write b ofs vs => Some ((b, ofs), length vs)
| event_semantics.Read b ofs _ vs => Some ((b, ofs), length vs)
| _ => None
end
| external _ sev =>
match sev with
| release addr _ => Some (addr, lksize.LKSIZE_nat)
| acquire addr _ => Some (addr, lksize.LKSIZE_nat)
| mklock addr => Some (addr, lksize.LKSIZE_nat)
| freelock addr => Some (addr, lksize.LKSIZE_nat)
| spawn addr _ _ => Some (addr, lksize.LKSIZE_nat)
| failacq addr => Some (addr, lksize.LKSIZE_nat)
end
end.
End Events.
Module HybridMachineSig.
(** Used to erase permissions of the machine when needed, e.g. fine machine erases max permissions, bare machine erases all permissions *)
Class DiluteMem :=
{ diluteMem: mem -> mem;
diluteMem_valid: forall m,
forall b, Memory.Mem.valid_block (diluteMem m) b <-> Memory.Mem.valid_block m b
}.
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.

Lemma hybrid_initial_schedule: forall m m' main vals U p st n,
initial_core (MachineCoreSemantics U p) n m st m' main vals ->
exists c, st = (U, nil, c).