(** Erasure Proof *)
(** This file contains the proof of erasure between juicy and dry programs *)
(** *Imports*)
(* This file uses Proof Irrelevance: forall (P : Prop) (p1 p2 : P), p1 = p2. *)
(* CompCert imports *)
(* VST imports *)
(* Concurrency Imports *)
(*The semantics*)
(*Erasure specification*)
(*SSReflect*)
From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From mathcomp.ssreflect Require Import ssreflect seq.
Set Bullet Behavior "Strict Subproofs".
Module Parching <: ErasureSig.
Section Parching.
Context (ge : Clight.genv).
Instance Sem : Semantics := ClightSemanticsForMachines.Clight_newSem ge.
Instance JR : Resources := LocksAndResources.
Instance JTP : ThreadPool.ThreadPool := OrdinalPool.OrdinalThreadPool.
Instance JMS : MachineSig := Concur.JuicyMachineShell.
Instance DilMem : DiluteMem := HybridMachineSig.HybridCoarseMachine.DilMem.
Instance scheduler : Scheduler := HybridCoarseMachine.scheduler.
Instance JuicyMachine : HybridMachine := HybridCoarseMachine.HybridCoarseMachine.
Definition jstate := jstate ge.
Instance DR : Resources := DryHybridMachine.dryResources.
Instance DTP : ThreadPool.ThreadPool := OrdinalPool.OrdinalThreadPool.
Instance DMS : MachineSig := DryHybridMachine.DryHybridMachineSig.
Instance DryMachine : HybridMachine := HybridCoarseMachine.HybridCoarseMachine.
Definition dstate := ThreadPool.t
(ThreadPool := OrdinalPool.OrdinalThreadPool)
(* @t dryResources DSem (@OrdinalPool.OrdinalThreadPool dryResources DSem) *).  Definition dmachine_state:= MachState(ThreadPool := OrdinalPool.OrdinalThreadPool).  Import event_semantics threadPool.ThreadPool.  (** * Match relation between juicy and dry state : *)
(* 1-2. Same threads are contained in each state: 3.   Threads have the same c 4-5.   Threads have the same permissions up to erasure 6.   the locks are in the same addresses. 7-8-9. Lock contents match up to erasure. *)
Inductive match_st' : jstate ->  dstate -> Prop:=
MATCH_ST: forall (js:jstate) (ds:dstate)
(mtch_cnt: forall {tid},  containsThread js tid -> containsThread ds tid )
(mtch_cnt': forall {tid}, containsThread ds tid -> containsThread js tid )
(mtch_gtc: forall {tid} (Htid:containsThread js tid)(Htid':containsThread ds tid),
getThreadC Htid = getThreadC Htid' )
(mtch_perm1: forall b ofs {tid} (Htid:containsThread js tid)(Htid':containsThread ds tid),
juicy_mem.perm_of_res (resource_at (getThreadR Htid) (b, ofs)) =
((getThreadR Htid').1 !! b) ofs )
(mtch_perm2: forall b ofs {tid} (Htid:containsThread js tid)(Htid':containsThread ds tid),
juicy_mem.perm_of_res_lock (resource_at (getThreadR Htid) (b, ofs)) =
((getThreadR Htid').2 !! b) ofs )
(mtch_locks: forall a,
ssrbool.isSome (lockRes js a) = ssrbool.isSome (lockRes ds a))
(mtch_locksEmpty: forall lock dres,
lockRes js lock = Some (None) ->
lockRes ds lock = Some dres ->
dres = (empty_map, empty_map))
(mtch_locksRes: forall lock jres dres,
lockRes js lock = Some (Some jres) ->
lockRes ds lock = Some dres ->
forall b ofs,
juicy_mem.perm_of_res (resource_at jres (b, ofs)) = (dres.1 !! b) ofs )
(mtch_locksRes: forall lock jres dres,
lockRes js lock = Some (Some jres) ->
lockRes ds lock = Some dres ->
forall b ofs,
juicy_mem.perm_of_res_lock (resource_at jres (b, ofs)) = (dres.2 !! b) ofs )

(* Specifications: *)
(*mtch_locks: AMap.map (fun _ => tt) (lockGuts js) = lockGuts ds*), match_st' js ds. Definition match_st:= match_st'.   (** *Match lemmas*)
Lemma MTCH_cnt: forall {js tid ds},
match_st js ds ->
containsThread js tid -> containsThread ds tid.
Lemma MTCH_locks: forall ds js laddr rmap,
match_st js ds ->
lockRes ds laddr = Some rmap ->
exists x, lockRes js laddr = Some x.
Lemma MTCH_getThreadC: forall js ds tid c,
forall (cnt: containsThread js tid)
(cnt': containsThread ds tid)
(M: match_st js ds),
getThreadC cnt =  c ->
getThreadC cnt'  =  c.
Lemma MTCH_lockSet: forall js ds,
match_st js ds ->
forall b ofs, (lockSet js) !! b ofs = (lockSet ds) !! b ofs.
Lemma MTCH_compat: forall js ds m,
match_st js ds ->
mem_compatible js m ->
mem_compatible ds m.
Lemma MTCH_updt:
forall js ds tid c
(H0:match_st js ds)
(cnt: containsThread js tid)
(cnt': containsThread ds tid),
match_st (updThreadC cnt c)
(updThreadC cnt' c).
Lemma MTCH_updt':
forall js ds tid c m
(H0:match_st js ds)
(cnt: containsThread js tid)
(cnt': containsThread ds tid)
(Hcmpt : mem_compatible js m)
(Hcmpt' : HybridMachineSig.mem_compatible ds m),
match_st (updThread cnt c (add_block Hcmpt cnt (Concur.install_perm Hcmpt cnt)))
(updThread cnt' c (HybridMachineSig.add_block Hcmpt' cnt' (Concur.install_perm Hcmpt cnt))).
Lemma MTCH_restrict_personal:
forall ds js m i
(MTCH: match_st js ds)
(Hi: containsThread js i)
(Hi': containsThread ds i)
Hcmpt
(Hcmpt': DryHybridMachine.mem_compatible ds m),
restrPermMap (DryHybridMachine.compat_th _ _ Hcmpt' Hi').1 =
m_dry (@Concur.personal_mem m (@getThreadR _ _ _ i js Hi) Hcmpt).
(*    Lemma MTCH_halted: forall ds js i (cnt: containsThread  js i) (cnt': containsThread  ds i), match_st js ds-> threadHalted cnt -> invariant ds -> threadHalted cnt'.  Lemma MTCH_updLockS: forall js ds loc jres dres1 dres2, match_st js ds -> (forall b ofs, perm_of_res (jres @ (b, ofs)) = dres1 !! b ofs) -> (forall b ofs, perm_of_res_lock (jres @ (b, ofs)) = dres2 !! b ofs) -> match_st (updLockSet js loc (Some jres)) (updLockSet ds loc (dres1,dres2)).  Lemma MTCH_updLockN: forall js ds loc, match_st js ds -> match_st (updLockSet js loc None) (updLockSet ds loc (empty_map,empty_map)). intros. constructor. + intros. apply cntUpdateL. destruct H; apply mtch_cnt. apply cntUpdateL' in H0; assumption. + intros. apply cntUpdateL. destruct H; apply mtch_cnt'. apply cntUpdateL' in H0; assumption. + intros. rewrite gLockSetCode gLockSetCode. inversion H; subst. apply mtch_gtc. + intros. rewrite gLockSetRes gLockSetRes. inversion H; subst. apply mtch_perm1. + intros. rewrite gLockSetRes gLockSetRes. inversion H; subst. apply mtch_perm2. + intros. destruct (AMap.E.eq_dec loc a) as [EQ | NEQ]. * subst loc. rewrite gsslockResUpdLock gsslockResUpdLock. reflexivity. * rewrite gsolockResUpdLock. rewrite gsolockResUpdLock. inversion H. solve[apply mtch_locks]. assumption. assumption. + intros. destruct (AMap.E.eq_dec loc lock) as [EQ | NEQ]. * subst loc. rewrite gsslockResUpdLock in H1; inversion H1; reflexivity. * rewrite gsolockResUpdLock in H1. rewrite gsolockResUpdLock in H0. inversion H. eapply mtch_locksEmpty; eassumption. assumption. assumption. + intros. destruct (AMap.E.eq_dec loc lock) as [EQ | NEQ]. * subst loc. rewrite gsslockResUpdLock in H0. rewrite gsslockResUpdLock in H1. inversion H0. * rewrite gsolockResUpdLock in H0. 2: assumption. rewrite gsolockResUpdLock in H1. 2: assumption. inversion H. eapply mtch_locksRes; eassumption. + intros. destruct (AMap.E.eq_dec loc lock) as [EQ | NEQ]. * subst loc. rewrite gsslockResUpdLock in H0. rewrite gsslockResUpdLock in H1. inversion H0. * rewrite gsolockResUpdLock in H0. 2: assumption. rewrite gsolockResUpdLock in H1. 2: assumption. inversion H. eapply mtch_locksRes0; eassumption. Qed.  Lemma MTCH_remLockN: forall js ds loc, match_st js ds -> match_st (remLockSet js loc) (remLockSet ds loc). intros. constructor. + intros. apply cntRemoveL. destruct H; apply mtch_cnt. apply cntRemoveL' in H0; assumption. + intros. apply cntRemoveL. destruct H; apply mtch_cnt'. apply cntRemoveL' in H0; assumption. + intros. rewrite gRemLockSetCode gRemLockSetCode. inversion H; subst. apply mtch_gtc. + intros. rewrite gRemLockSetRes  gRemLockSetRes. inversion H; subst. apply mtch_perm1. + intros. rewrite gRemLockSetRes  gRemLockSetRes. inversion H; subst. apply mtch_perm2. + intros. destruct (AMap.E.eq_dec loc a) as [EQ | NEQ]. * subst loc. rewrite gsslockResRemLock gsslockResRemLock. reflexivity. * rewrite gsolockResRemLock. 2: exact NEQ. rewrite gsolockResRemLock. 2: exact NEQ. inversion H. solve[apply mtch_locks]. + intros. destruct (AMap.E.eq_dec loc lock) as [EQ | NEQ]. * subst loc. rewrite gsslockResRemLock in H1; inversion H1; reflexivity. * rewrite gsolockResRemLock in H1. 2: exact NEQ. rewrite gsolockResRemLock in H0. 2: exact NEQ. inversion H. eapply mtch_locksEmpty; eassumption. + intros. destruct (AMap.E.eq_dec loc lock) as [EQ | NEQ]. * subst loc. rewrite gsslockResRemLock in H0. rewrite gsslockResRemLock in H1. inversion H0. * rewrite gsolockResRemLock in H0. 2: exact NEQ. rewrite gsolockResRemLock in H1. 2: exact NEQ. inversion H. eapply mtch_locksRes; eassumption. + intros. destruct (AMap.E.eq_dec loc lock) as [EQ | NEQ]. * subst loc. rewrite gsslockResRemLock in H0. rewrite gsslockResRemLock in H1. inversion H0. * rewrite gsolockResRemLock in H0. 2: exact NEQ. rewrite gsolockResRemLock in H1. 2: exact NEQ. inversion H. eapply mtch_locksRes0; eassumption. Qed.  Lemma MTCH_update: forall js ds Kc phi p1 p2 i (Hi : containsThread js i) (Hi': containsThread ds i), match_st js ds -> ( forall b ofs, perm_of_res (phi @ (b, ofs)) = p1 !! b ofs) -> ( forall b ofs, perm_of_res_lock (phi @ (b, ofs)) = p2 !! b ofs) -> match_st (updThread Hi  Kc phi) (updThread Hi' Kc (p1,p2)).  Lemma match_st_age_tp_to tp n ds : match_st tp ds -> match_st (Concur.age_tp_to n tp) ds.  Definition match_rmap_perm (rmap : rmap) (pmap: access_map * access_map): Prop:= (forall b ofs, perm_of_res (rmap @ (b, ofs)) = pmap.1 !! b ofs) /\ pmap.2 = empty_map.  Definition no_locks_perm (rmap : rmap): Prop:= forall b ofs, perm_of_res_lock (rmap @ (b, ofs)) = None.  Lemma MTCH_initial: forall  c rmap pmap, match_rmap_perm rmap pmap -> no_locks_perm rmap -> match_st (Concur.initial_machine rmap c) (DryHybridMachine.initial_machine (*genv*) pmap.1 c).  Lemma contains_iff_num: forall (js : jstate) (ds : dstate) (Hcnt: forall i, containsThread js i <-> containsThread ds i), OrdinalPool.num_threads js = OrdinalPool.num_threads ds.   Lemma MTCH_latestThread: forall js ds, match_st js ds -> latestThread js = latestThread ds.  Lemma perm_of_writable0: forall sh, shares.writable0_share sh -> sh <> Share.top -> perm_of_sh sh = Some Writable.  Lemma MTCH_addThread: forall js ds parg arg phi res lres, match_st js ds -> (forall b0 ofs0, perm_of_res (phi@(b0, ofs0)) = res !! b0 ofs0) -> (forall b0 ofs0, perm_of_res_lock (phi@(b0, ofs0)) = lres !! b0 ofs0) -> match_st (addThread js parg arg phi) (addThread ds parg arg (res,lres)).  Lemma MTCH_age: forall js ds age, match_st js ds -> match_st (Concur.age_tp_to age js) ds.  Lemma MTCH_tp_update: forall js ds phi js' phi', match_st js ds -> tp_update js phi js' phi' -> match_st js' ds.    (*    (** *Inital state simulation*)
(* Erasure of the juicy initial_state is the dry initial_state AND the two are related by a Match relation. *)
Lemma init_diagram:
forall (j : Values.Val.meminj) (U:schedule) (js : jstate)
(vals : list Values.val) (m m' : Mem.mem) rmap pmap main h,
init_inj_ok j m ->
match_rmap_perm rmap pmap ->
no_locks_perm rmap ->
initial_core (JMachineSem U (Some rmap)) h m (U, nil, js) m' main vals ->
exists (ds : dstate),
initial_core (ClightMachineSem U (Some pmap)) h m (U, nil, ds) m' main vals /\
invariant ds /\
match_st js ds.
Lemma perm_of_readable' : forall sh, shares.readable_share sh ->
Mem.perm_order' (perm_of_sh (Share.glb Share.Rsh sh)) Readable.
Lemma perm_of_writable' : forall sh, shares.writable0_share sh ->
Mem.perm_order' (perm_of_sh sh) Writable.
Lemma lock_range_perm : forall m js ds (MATCH : match_st js ds) i (Hi : containsThread js i)
(Hcmpt : mem_compatible js m) b ofs
sh R (HJcanwrite : Concur.lock_at_least sh R (getThreadR Hi) b (Ptrofs.intval ofs)),
Mem.range_perm (Concur.juicyRestrict_locks (Concur.mem_compat_thread_max_cohere Hcmpt Hi)) b
(Ptrofs.intval ofs) (Ptrofs.intval ofs + LKSIZE) Cur Readable.