Section JuicyMachineShell.
Context {Sem: Semantics}.
Notation C:= (semC).
Notation G:= (semG).
Notation tid:= nat.
Notation lockMap:= (AMap.t lock_info).
Notation SSome x:= (Some (Some x)).
Notation SNone:= (Some None).
(** 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 rm, AMap.find loc ls = SSome 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 (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,
(forall i, 0 <= i < LKSIZE -> exists sh psh P, juice @ (fst loc, snd loc + i) = YES sh psh (LK LKSIZE i) 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,
forall i, 0 <= i < LKSIZE -> exists sh' psh' P, join_sub sh sh' /\ juice @ (fst loc, snd loc + i) = YES sh' psh' (LK LKSIZE i) 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 i, juice @ loc = YES sh psh (LK z i) 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:=LocksAndResources) cnti)
(getThreadR cntj).
(* Per-lock disjointness definition*)
Definition disjoint_locks tp :=
forall loc1 loc2 r1 r2,
lockRes tp loc1 = SSome r1 ->
lockRes tp loc2 = SSome r2 ->
joins r1 r2.
(* lock-thread disjointness definition*)
Definition disjoint_lock_thread tp :=
forall i loc r (cnti : containsThread tp i),
lockRes tp loc = SSome r ->
joins (getThreadR cnti)r.
Variant invariant' (tp:t) := True. (* The invariant has been absorbed my mem_compat*)
(* { no_race : disjoint_threads tp }.*)
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.
- 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.
- 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.
- 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 phi, lockRes(resources:=LocksAndResources) tp i = Some (Some phi) -> le n (level phi)).
Definition tp_level_is n tp :=
(forall i (cnti : containsThread tp i), level (getThreadR cnti) = n) /\
(forall i phi, lockRes(resources:=LocksAndResources) tp i = Some (Some phi) -> level phi = n).
(* Lemma mem_compatible_same_level tp m : mem_compatible tp m -> tp_level_is (level_tp tp) tp.  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 (option_map (age_to k)) lset) end.  Lemma level_age_tp_to tp k : tp_level_is_above k tp -> tp_level_is k (age_tp_to k tp).  Lemma map_compose {A B C} (g : A -> B) (f : B -> C) l : map (f oo g) l = map f (map g l).  Lemma join_list_age_to k l Phi : le k (level Phi) -> join_list l Phi -> join_list (map (age_to k) l) (age_to k Phi).  Lemma join_list'_age_to k (l : list (option res)) (Phi : option res) : (match Phi with None => Logic.True | Some phi => le k (level phi) end) -> join_list' l Phi -> join_list' (map (option_map (age_to k)) l) (option_map (age_to k) Phi).  Lemma join_all_age_to k tp Phi : le k (level Phi) -> join_all tp Phi -> join_all (age_tp_to k tp) (age_to k Phi).  Lemma perm_of_age rm age loc : perm_of_res (age_to age rm @ loc) = perm_of_res (rm @ loc).  Lemma perm_of_age_lock rm age loc : perm_of_res_lock (age_to age rm @ loc) = perm_of_res_lock (rm @ loc).  Lemma almost_empty_perm: forall rm, res_predicates.almost_empty rm -> forall loc, Mem.perm_order'' (Some Nonempty) (perm_of_res (rm @ loc)).  Lemma cnt_age {js i age} : containsThread (age_tp_to age js) i -> containsThread js i.  Lemma cnt_age' {js i age} : containsThread js i -> containsThread (age_tp_to age js) i.  Lemma age_getThreadCode: forall i tp age cnt cnt', @getThreadC _ _ _ i tp cnt = @getThreadC _ _ _ i (age_tp_to age tp) cnt'.  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) .  Definition lock_at_least sh R phi b ofs := forall i, 0 <= i < LKSIZE -> exists sh' rsh', join_sub sh sh' /\ phi@(b,ofs+i) = YES sh' rsh' (LK LKSIZE i) (pack_res_inv R).   Notation Kblocked := (threadPool.Kblocked). Open Scope Z_scope. 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)(R:pred rmap)
(HJcanwrite: lock_at_least sh R phi b (Ptrofs.intval ofs))
(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) = SSome 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) None )
(Htp''': tp''' = age_tp_to (level phi - 1)%coq_nat tp''),
syncStep' cnt0 Hcompat tp''' m' (acquire (b, Ptrofs.intval ofs) None)
| 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)
(HJcanwrite: lock_at_least sh R phi b (Ptrofs.intval ofs))
(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) = SNone )
(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) (Some d_phi))
(Htp''': tp''' = age_tp_to (level phi - 1)%coq_nat tp''),
syncStep' cnt0 Hcompat tp''' m' (release (b, Ptrofs.intval ofs) None)
| 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))
(Harg: Val.inject (Mem.flat_inj (Mem.nextblock m)) arg arg)
(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) 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)) = SNone)
(*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) (R:pred rmap)
(HJcanwrite: lock_at_least sh R phi b (Ptrofs.intval ofs))
(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_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).