Section InvMachineShell.
Context {Sem: Semantics}.
Notation C:= (semC).
Notation G:= (semG).
Notation tid:= nat.
Notation lockMap:= (AMap.t lock_info).
(** Memories*)
Definition richMem: Type:= juicy_mem.
Definition dryMem: richMem -> mem:= m_dry.
(** Environment and Threadwise semantics *)
(* This all comes from the SEM. *)
(*Parameter G : Type. Parameter Sem : CoreSemantics G code mem.*)
Notation the_sem := (csem (event_semantics.msem semSem)).
(*thread pool*)
Existing Instance OrdinalThreadPool.
Notation thread_pool := (@ThreadPool.t _ _ OrdinalThreadPool).
(** Machine Variables*)
Definition lp_id : tid:= (0)%nat. (*lock pool thread id*)
(** Invariants*)
(** The state respects the memory*)
Definition access_cohere' m phi:= forall loc,
Mem.perm_order'' (max_access_at m loc) (perm_of_res (phi @ loc)).
(* This is similar to the coherence of juicy memories, * * but for entire machines. It is slighly weaker in one way: * - acc_coh is looser and only talks about maxcoh. * - alse acc_coh  might me redundant with max_coh IDK... x*)
Record mem_cohere' m phi :=
{ cont_coh: contents_cohere m phi;
(*acc_coh: access_cohere m phi;*)
(*acc_coh: access_cohere' m phi;*)
max_coh: max_access_cohere m phi;
all_coh: alloc_cohere m phi
}.
Definition mem_thcohere (tp : thread_pool) m :=
forall {tid} (cnt: containsThread tp tid), mem_cohere' m (getThreadR cnt).
Definition mem_lock_cohere (ls:lockMap) m:=
forall loc R rm, AMap.find loc ls = Some (R, Some rm) -> mem_cohere' m rm.
(*Join juice from all threads *)
Definition getThreadsR (tp : thread_pool):=
map (perm_maps tp) (enums_equality.enum (num_threads tp)).
Fixpoint join_list (ls: seq.seq res) r:=
if ls is phi::ls' then exists r', join phi r' r /\ join_list ls' r' else
app_pred emp r.  (*Or is is just [amp r]?*)
Definition join_threads (tp : thread_pool) r:= join_list (getThreadsR tp) r.
(*Join juice from all locks*)
Fixpoint join_list' (ls: seq.seq (mpred * option res)) (r:option res):=
if ls is (_, phi)::ls' then exists (r':option res),
@join _ (@Join_lower res _) phi r' r /\ join_list' ls' r' else r=None.
Definition join_locks tp r:= join_list' (map snd (AMap.elements (lset tp))) r.
(*Join all the juices*)
Inductive join_all: thread_pool -> res -> Prop:=
AllJuice tp r0 r1 r:
join_threads tp r0 ->
join_locks tp r1 ->
join (Some r0) r1 (Some r) ->
join_all tp r.
Definition juicyLocks_in_lockSet (lset : lockMap) (juice: rmap):=
forall loc sh psh P z, juice @ loc = YES sh psh (LK z) P  ->  AMap.find loc lset.
(* I removed the NO case for two reasons: * - To ensure that lset is "valid" (lr_valid), it needs inherit it from the rmap * - there was no real reason to have a NO other than speculation of the future. *)
Definition lockSet_in_juicyLocks (lset : lockMap) (juice: rmap):=
forall loc, AMap.find loc lset ->
(exists sh psh P, juice @ loc = YES sh psh (LK LKSIZE) P).
Definition lockSet_in_juicyLocks' (lset : lockMap) (juice: rmap):=
forall loc, AMap.find loc lset ->
Mem.perm_order'' (Some Nonempty) (perm_of_res (juice @ loc)).
Definition lockSet_Writable (lset : lockMap) m :=
forall b ofs, AMap.find (b,ofs) lset ->
forall ofs0, Intv.In ofs0 (ofs, ofs + LKSIZE)%Z ->
Mem.perm_order'' ((Mem.mem_access m)!! b ofs0 Max) (Some Writable) .
(*This definition makes no sense. In fact if there is at least one lock in rmap, *then the locks_writable is false (because perm_of_res(LK) = Some Nonempty). *)
Definition locks_writable (juice: rmap):=
forall loc sh psh P z, juice @ loc = YES sh psh (LK z) P  ->
Mem.perm_order'' (perm_of_res (juice @ loc)) (Some Writable).
Record mem_compatible_with' (tp : thread_pool) m all_juice : Prop :=
{   juice_join : join_all tp all_juice
; all_cohere : mem_cohere' m all_juice
; loc_writable : lockSet_Writable (lockGuts tp) m
; jloc_in_set : juicyLocks_in_lockSet (lockGuts tp) all_juice
; lset_in_juice: lockSet_in_juicyLocks  (lockGuts tp) all_juice
}.
Definition mem_compatible_with := mem_compatible_with'.
Definition mem_compatible tp m := ex (mem_compatible_with tp m).
(* Lemma mem_compatible_locks_lt: forall {tp m}, mem_compatible tp m -> forall i cnti, permMapLt (perm_of_res_lock (@getThreadR i tp cnti)) (getMaxPerm m ).  Lemma compat_lt_m: forall m js, mem_compatible js m -> forall b ofs, Mem.perm_order'' ((getMaxPerm m) !! b ofs) ((lockSet js) !! b ofs).  (** There is no inteference in the thread pool *)
(* Per-thread disjointness definition*)
Definition disjoint_threads tp :=
forall i j (cnti : containsThread tp i)
(cntj: containsThread tp j) (Hneq: i <> j),
joins (getThreadR(resources:=LockInvsAndResources) cnti)
(getThreadR cntj).
(* Per-lock disjointness definition*)
Definition disjoint_locks tp :=
forall loc1 loc2 R1 R2 r1 r2,
lockRes tp loc1 = Some (R1, Some r1) ->
lockRes tp loc2 = Some (R2, Some r2) ->
joins r1 r2.
(* lock-thread disjointness definition*)
Definition disjoint_lock_thread tp :=
forall i loc R r (cnti : containsThread tp i),
lockRes tp loc = Some (R, Some r) ->
joins (getThreadR cnti) r.
Variant invariant' (tp:t) := True. (* The invariant has been absorbed my mem_compat*)
Definition invariant := invariant'.
(*Lemmas to retrive the ex-invariant properties from the mem-compat*)
(** Steps*)
(* What follows is the lemmas needed to construct a "personal" memory That is a memory with the juice and Cur of a particular thread. *)
Definition mapmap {A B} (def:B) (f:positive -> A -> B) (m:PMap.t A): PMap.t B:=
(def, PTree.map f m#2).
(* You need the memory, to make a finite tree. *)
Definition juice2Perm (phi:rmap)(m:mem): access_map:=
mapmap (fun _ => None) (fun block _ => fun ofs => perm_of_res (phi @ (block, ofs)) ) (getMaxPerm m).
Definition juice2Perm_locks (phi:rmap)(m:mem): access_map:=
mapmap (fun _ => None) (fun block _ => fun ofs => perm_of_res_lock (phi @ (block, ofs)) ) (getMaxPerm m).
Definition juicyRestrict {phi:rmap}{m:Mem.mem}(coh:access_cohere' m phi): Mem.mem:=
restrPermMap (juice2Perm_cohere coh).
Definition juicyRestrict_locks {phi:rmap}{m:Mem.mem}(coh:max_access_cohere m phi): Mem.mem:=
restrPermMap (juice2Perm_locks_cohere coh).
Definition juicyRestrict':=
fun phi m macoh => @juicyRestrict phi m (max_acc_coh_acc_coh macoh).
intros r1 r2[r J]; inversion J; subst; simpl.
- if_tac.
+ subst.
if_tac.
* eauto with *.
* apply join_to_bot_l in RJ; subst;
congruence.
+ if_tac; constructor.
- destruct k; try solve [constructor].
+ apply po_join_sub_sh.
eexists; eauto.
+ apply po_join_sub_sh.
* eexists; eauto.
+ apply po_join_sub_sh.
* eexists; eauto.
+ apply po_join_sub_sh.
* eexists; eauto.
- destruct k.
+ if_tac.
* hnf. destruct (perm_of_sh _); apply I.
* apply perm_order''_trans with (perm_of_sh sh3).
-- apply po_join_sub_sh.
++ eexists; eauto.
-- destruct  (perm_of_sh sh3) eqn:E.
++ constructor.
++ pose proof @perm_of_empty_inv _ E; subst.
apply join_to_bot_l in RJ; subst; congruence.
+ if_tac.
* hnf. destruct (perm_of_sh _); apply I.
* apply perm_order''_trans with (perm_of_sh sh1).
-- apply po_join_sub_sh.
++ eexists; eauto.
-- destruct  (perm_of_sh sh1) eqn:E.
++ constructor.
++ pose proof @perm_of_empty_inv _ E; subst; congruence.
+ if_tac.
* hnf. destruct (perm_of_sh _); apply I.
* apply perm_order''_trans with (perm_of_sh sh1).
-- apply po_join_sub_sh.
++ eexists; eauto.
-- destruct  (perm_of_sh sh1) eqn:E.
++ constructor.
++ pose proof @perm_of_empty_inv _ E; subst; congruence.
+ if_tac.
* hnf. destruct (perm_of_sh _); apply I.
* apply perm_order''_trans with (perm_of_sh sh1).
-- apply po_join_sub_sh.
++ eexists; eauto.
-- destruct  (perm_of_sh sh1) eqn:E.
++ constructor.
++ pose proof @perm_of_empty_inv _ E; subst; congruence.
- destruct k; try constructor.
+ apply po_join_sub_sh; eexists; eauto.
+ apply po_join_sub_sh; eexists; eauto.
+ apply po_join_sub_sh; eexists; eauto.
+ apply po_join_sub_sh; eexists; eauto.
- constructor.
Qed.
(* PERSONAL MEM: Is the contents of the global memory, with the juice of a single thread and the Cur that corresponds to that juice.*)
Definition acc_coh:= fun m phi pr => @max_acc_coh_acc_coh m phi (max_coh pr).
Definition personal_mem {m phi} (pr : mem_cohere' m phi) : juicy_mem:=
mkJuicyMem
(@juicyRestrict phi m (acc_coh pr))
phi
(juicyRestrictContentCoh (acc_coh pr) (cont_coh pr))
(juicyRestrictAccCoh (acc_coh pr))
(juicyRestrictMaxCoh (acc_coh pr) (max_coh pr))
(juicyRestrictAllocCoh (acc_coh pr) (all_coh pr)).
Definition juicy_sem := (FSem.F _ _ JuicyFSem.t) _ the_sem.
(* Definition juicy_step := (FSem.step _ _ JuicyFSem.t) _ _ the_sem. *)
Program Definition first_phi (tp : thread_pool) : rmap := (@getThreadR _ _ _ 0%nat tp _).
Next Obligation.
unfold OrdinalPool.containsThread.
destruct num_threads.
simpl.
ssromega.
Defined.
Program Definition level_tp (tp : thread_pool) := level (first_phi tp).
Definition tp_level_is_above n tp :=
(forall i (cnti : containsThread tp i), le n (level (getThreadR cnti))) /\
(forall i R phi, lockRes(resources:=LockInvsAndResources) tp i = Some (R, Some phi) -> le n (level phi)).
Definition tp_level_is n tp :=
(forall i (cnti : containsThread tp i), level (getThreadR cnti) = n) /\
(forall i R phi, lockRes(resources:=LockInvsAndResources) tp i = Some (R, Some phi) -> level phi = n).
Definition cnt_from_ordinal tp : forall i : ordinal (pos.n (num_threads tp)), containsThread tp i.
intros [i pr]; apply pr. Defined.
Definition age_tp_to (k : nat) (tp : thread_pool) : thread_pool :=
match tp with
mk n pool maps lset =>
mk n pool
((age_to k) oo maps)
(AMap.map (fun '(R, r) => (R, option_map (age_to k) r)) lset)
end.
Inductive juicy_step  {tid0 tp m} (cnt: containsThread tp tid0)
(Hcompatible: mem_compatible tp m) : thread_pool -> mem -> list mem_event -> Prop :=
| step_juicy :
forall (tp':thread_pool) c jm jm' m' (c' : C),
forall (Hpersonal_perm:
personal_mem (thread_mem_compatible Hcompatible cnt) = jm)
(Hinv : invariant tp)
(Hthread: getThreadC cnt = Krun c)
(Hcorestep: corestep juicy_sem c jm c' jm')
(Htp': tp' = @updThread _ _ _ tid0 (age_tp_to (level jm') tp) (cnt_age' cnt) (Krun c') (m_phi jm'))
(Hm': m_dry jm' = m'),
juicy_step  cnt Hcompatible tp' m' [::].
Definition pack_res_inv (R: pred rmap) := SomeP rmaps.Mpred (fun _ => R) .
Notation Kblocked := (threadPool.Kblocked).
Open Scope Z_scope.
(* This differs from juicy_machine.syncStep' in two ways: 1) The lockRes tracks the invariant associated with each lock. 2) The release and acquire events include the permission changes involved. This should allow us to show that events are preserved by erasure, and that they are consistent with the associated invariants. *)
Inductive syncStep' {isCoarse: bool} {tid0 tp m}
(cnt0:containsThread tp tid0)(Hcompat:mem_compatible tp m):
thread_pool -> mem -> sync_event -> Prop :=
| step_acquire :
forall (tp' tp'' tp''':thread_pool) c m0 m1 b ofs d_phi phi phi' m' pmap_tid',
forall
(Hinv : invariant tp)
(Hthread: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external the_sem c m =
Some (LOCK, Vptr b ofs::nil))
(Hcompatible: mem_compatible tp m)
(*Hpersonal_perm: personal_mem cnt0 Hcompatible = jm*)
(Hpersonal_juice: getThreadR cnt0 = phi)
(sh:Share.t)psh(R:pred rmap)
(HJcanwrite: phi@(b, Ptrofs.intval ofs) = YES sh psh (LK LKSIZE) (pack_res_inv R))
(Hrestrict_map0: juicyRestrict_locks
(mem_compat_thread_max_cohere Hcompat cnt0) = m0)
(Hload: Mem.load Mint32 m0 b (Ptrofs.intval ofs) = Some (Vint Int.one))
(*Hrestrict_pmap: permissions.restrPermMap (mem_compatible_locks_ltwritable Hcompatible) = m1*)
(Hset_perm: setPermBlock (Some Writable)
b (Ptrofs.intval ofs) (juice2Perm_locks phi m) LKSIZE_nat = pmap_tid')
(Hlt': permMapLt pmap_tid' (getMaxPerm m))
(* This following condition is not needed: It should follow from the mem_compat statement... somehow... *)
(Hrestrict_pmap: restrPermMap Hlt' = m1)
(Hstore: Mem.store Mint32 m1 b (Ptrofs.intval ofs) (Vint Int.zero) = Some m')
(His_unlocked: lockRes tp (b, Ptrofs.intval ofs) = Some (R, Some d_phi))
(Hadd_lock_res: join phi d_phi phi')
(Htp': tp' = updThread cnt0 (Kresume c Vundef) phi')
(Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) (R, None) )
(Htp''': tp''' = age_tp_to (level phi - 1)%coq_nat tp'')
(virtueThread : delta_map * delta_map)
(Hcompute: juice2Perm phi' m' = computeMap (juice2Perm phi m) virtueThread.1 /\
juice2Perm_locks phi' m' = computeMap (juice2Perm_locks phi m) virtueThread.1),
syncStep' cnt0 Hcompat tp''' m'
(acquire (b, Ptrofs.intval ofs) (Some virtueThread))
| step_release :
forall  (tp' tp'' tp''':thread_pool) c m0 m1 b ofs  (phi d_phi :rmap) (R: pred rmap) phi' m' pmap_tid',
forall
(Hinv : invariant tp)
(Hthread: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external the_sem c m =
Some (UNLOCK, Vptr b ofs::nil))
(Hcompatible: mem_compatible tp m)
(* Hpersonal_perm: personal_mem cnt0 Hcompatible = jm *)
(Hpersonal_juice: getThreadR cnt0 = phi)
(sh:Share.t) psh
(HJcanwrite: phi@(b, Ptrofs.intval ofs) = YES sh psh (LK LKSIZE) (pack_res_inv R))
(Hrestrict_map0: juicyRestrict_locks
(mem_compat_thread_max_cohere Hcompat cnt0) = m0)
(Hload: Mem.load Mint32 m0 b (Ptrofs.intval ofs) = Some (Vint Int.zero))
(*Hrestrict_pmap: permissions.restrPermMap (mem_compatible_locks_ltwritable Hcompatible) = m1*)
(Hset_perm: setPermBlock (Some Writable)
b (Ptrofs.intval ofs) (juice2Perm_locks phi m) LKSIZE_nat = pmap_tid')
(Hlt': permMapLt pmap_tid' (getMaxPerm m))
(* This following condition is not needed: It should follow from the mem_compat statement... somehow... *)
(Hrestrict_pmap: restrPermMap Hlt' = m1)
(Hstore: Mem.store Mint32 m1 b (Ptrofs.intval ofs) (Vint Int.one) = Some m')
(His_locked: lockRes tp (b, Ptrofs.intval ofs) = Some (R, None) )
(Hsat_lock_inv: R (age_by 1 d_phi))
(Hrem_lock_res: join d_phi phi' phi)
(Htp': tp' = updThread cnt0 (Kresume c Vundef) phi')
(Htp'': tp'' =
updLockSet tp' (b, Ptrofs.intval ofs) (R, Some d_phi))
(Htp''': tp''' = age_tp_to (level phi - 1)%coq_nat tp''),
syncStep' cnt0 Hcompat tp''' m' (release (b, Ptrofs.intval ofs) (Some (juice2Perm d_phi m, juice2Perm_locks d_phi m)))
| step_create :
forall  (tp_upd tp':thread_pool) c vf arg jm (d_phi phi': rmap) b ofs (* P Q *),
forall
(Hinv : invariant tp)
(Hthread: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external the_sem c m =
Some (CREATE, vf::arg::nil))
(Hfun_sepc: vf = Vptr b ofs)
(Hcompatible: mem_compatible tp m)
(Hpersonal_perm:
personal_mem (thread_mem_compatible Hcompatible cnt0) = jm)
(Hrem_fun_res: join d_phi phi' (m_phi jm))
(Htp': tp_upd = updThread cnt0 (Kresume c Vundef) phi')
(Htp'': tp' = age_tp_to (level (m_phi jm) - 1)%coq_nat (addThread tp_upd vf arg d_phi)),
syncStep' cnt0 Hcompat tp' m (spawn (b, Ptrofs.intval ofs) None None)
| step_mklock :
forall  (tp' tp'': thread_pool)  jm c b ofs R ,
let: phi := m_phi jm in
forall
phi' m'
(Hinv : invariant tp)
(Hthread: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external the_sem c m =
Some (MKLOCK, Vptr b ofs::nil))
(Hcompatible: mem_compatible tp m)
(*Hright_juice:  m = m_dry jm*)
(Hpersonal_perm:
personal_mem (thread_mem_compatible Hcompatible cnt0) = jm)
(Hpersonal_juice: getThreadR cnt0 = phi)
(*Check I have the right permission to mklock and the right value (i.e. 0) *)
(*Haccess: address_mapsto LKCHUNK (Vint Int.zero) sh Share.top (b, Ptrofs.intval ofs) phi*)
(Hstore:
Mem.store Mint32 (m_dry jm) b (Ptrofs.intval ofs) (Vint Int.zero) = Some m')
(* [Hrmap] replaced: [Hct], [Hlock], [Hj_forward] and [levphi']. This says that phi and phi' coincide everywhere except in adr_range, and specifies how phi and phi' should differ in adr_range (in particular, they have equal shares, pointwise) *)
(Hrmap : rmap_makelock phi phi' (b, Ptrofs.unsigned ofs) R LKSIZE)
(Htp': tp' = updThread cnt0 (Kresume c Vundef) phi')
(Htp'': tp'' = age_tp_to (level phi - 1)%coq_nat
(updLockSet tp' (b, Ptrofs.intval ofs) (R, None) )),
syncStep' cnt0 Hcompat tp'' m' (mklock (b, Ptrofs.intval ofs))
| step_freelock :
forall  (tp' tp'': thread_pool) c b ofs phi R phi',
forall
(Hinv : invariant tp)
(Hthread: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external the_sem c m =
Some (FREE_LOCK, Vptr b ofs::nil))
(Hcompatible: mem_compatible tp m)
(Hpersonal_juice: getThreadR cnt0 = phi)
(*First check the lock is acquired:*)
(His_acq: lockRes tp (b, (Ptrofs.intval ofs)) = Some (R, None))
(*Relation between rmaps:*)
(Hrmap : rmap_freelock phi phi' m (b, Ptrofs.unsigned ofs) R LKSIZE)
(Htp': tp' = updThread cnt0 (Kresume c Vundef) phi')
(Htp'': tp'' = age_tp_to (level phi - 1)%coq_nat
(remLockSet tp' (b, Ptrofs.intval ofs) )),
syncStep' cnt0 Hcompat  tp'' m (freelock (b, Ptrofs.intval ofs))
| step_acqfail :
forall  c b ofs jm m1,
let: phi := m_phi jm in
forall
(Hinv : invariant tp)
(Hthread: getThreadC cnt0 = Kblocked c)
(Hat_external: at_external the_sem c m =
Some (LOCK, Vptr b ofs::nil))
(Hcompatible: mem_compatible tp m)
(Hpersonal_perm:
personal_mem (thread_mem_compatible Hcompatible cnt0) = jm)
(Hrestrict_map: juicyRestrict_locks
(mem_compat_thread_max_cohere Hcompat cnt0) = m1)
(sh:Share.t) psh(R:pred rmap)
(HJcanwrite: phi@(b, Ptrofs.intval ofs) = YES sh psh (LK LKSIZE) (pack_res_inv R))
(Hload: Mem.load Mint32 m1 b (Ptrofs.intval ofs) = Some (Vint Int.zero)),
syncStep' 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 -> list mem_event -> Prop:=
@juicy_step.

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').