Section Clight_safety_equivalence.
Context (CPROOF : semax_to_juicy_machine.CSL_proof).
Definition prog:= CPROOF.(CSL_prog).
Definition ge:= Clight.globalenv prog.
Definition init_mem:= proj1_sig (init_mem CPROOF).
(*We should be able to construct a Clight.state from the proof... *)
Definition f_main : {f | Genv.find_funct_ptr (Clight.genv_genv ge) (projT1 (spr CPROOF)) = Some f}.
Inductive match_ctl : ctl -> ctl -> Prop :=
| match_Krun c c' : match_states c (fst (CC'.CC_state_to_CC_core c')) -> match_ctl (Krun c) (Krun c')
| match_Kblocked c c' : match_states c (fst (CC'.CC_state_to_CC_core c')) -> match_ctl (Kblocked c) (Kblocked c')
| match_Kresume c c' v : match_states c (fst (CC'.CC_state_to_CC_core c')) -> match_ctl (Kresume c v) (Kresume c' v)
| match_Kinit v v' : match_ctl (Kinit v v') (Kinit v v').
(* This should essentially reproduce Clight_sim at the hybrid machine level. *)
Inductive match_st (tp : ThreadPool.t(resources := dryResources)(ThreadPool:= threadPool.OrdinalPool.OrdinalThreadPool(Sem:=Clight_newSem ge)))
(tp' : ThreadPool.t(resources := dryResources)(ThreadPool:= threadPool.OrdinalPool.OrdinalThreadPool(Sem:=ClightSem ge))) : Prop :=
MATCH_ST: forall (mtch_cnt: forall {tid},  containsThread tp tid -> containsThread tp' tid)
(mtch_cnt': forall {tid}, containsThread tp' tid -> containsThread tp tid)
(mtch_gtc: forall {tid} (Htid:containsThread tp tid)(Htid':containsThread tp' tid),
match_ctl (getThreadC Htid) (getThreadC Htid'))
(mtch_gtr1: forall {tid} (Htid:containsThread tp tid)(Htid':containsThread tp' tid)
b ofs,
(fst (getThreadR Htid)) !! b ofs = (fst (getThreadR Htid')) !! b ofs)
(mtch_gtr2: forall {tid} (Htid:containsThread tp tid)(Htid':containsThread tp' tid),
snd (getThreadR Htid) = snd (getThreadR Htid'))
(mtch_locks: forall a, lockRes tp a = lockRes tp' a)
(mtch_latest: latestThread tp = latestThread tp'),
match_st tp tp'.
Existing Instance scheduler.
Existing Instance DilMem.
Instance ClightAxioms : @CoreLanguage.SemAxioms (ClightSem ge).
Opaque updThread updThreadC containsThread getThreadC getThreadR lockRes.
Definition MachStateDry := @MachState dryResources (Clight_newSem ge)
(@OrdinalPool.OrdinalThreadPool dryResources (Clight_newSem ge)).
(* SearchHead (MachState -> _). Print Val.inject. Definition flat_inject (v: memval) *)
Definition threadpool_of (st: MachStateDry) :=    match st with (_, _, tp) => tp end.
Definition dryThreadPool := @ThreadPool.t dryResources (Clight_newSem ge)
(@OrdinalPool.OrdinalThreadPool dryResources (Clight_newSem ge)).
Definition ctl_ok nextb (c: @ctl Clight_new.corestate) : Prop :=
match c with
| Krun q => corestate_ok nextb q
| Kblocked q => corestate_ok nextb q
| Kresume q v => corestate_ok nextb q /\ val_ok nextb v
| Kinit v1 v2 => val_ok nextb v1 /\ val_ok nextb v2
end.
Definition mem_ok (tp: dryThreadPool) m :=
Smallstep.globals_not_fresh (Clight.genv_genv ge) m /\
mem_wd2 m /\
(forall i (CT: containsThread tp i),
ctl_ok (Mem.nextblock m) (getThreadC CT)).
(* spawn handler *)
Notation tvoidptr := (Tpointer Tvoid noattr).
Notation tvoidfun := (Tfunction (Tcons tvoidptr Tnil) tvoidptr AST.cc_default).
Definition f_wrapper : Clight.function :=
{| Clight.fn_return := Tvoid; Clight.fn_callconv := AST.cc_default;
Clight.fn_params := [(1%positive, tvoidfun); (2%positive, tvoidptr)];
Clight.fn_vars := []; Clight.fn_temps := [];
Clight.fn_body := Clight.Scall None (Clight.Etempvar 1%positive tvoidfun) [Clight.Etempvar 2%positive tvoidptr] |}.
(*Todo Explain the following definition *)
Class spawn_wrapper := { lookup_wrapper: exists b_wrapper, Genv.find_funct_ptr (Clight.genv_genv ge) b_wrapper = Some (Ctypes.Internal f_wrapper)}.
Context {SW : spawn_wrapper}.
Set Bullet Behavior "Strict Subproofs".
split;intros  ??.
-- erewrite computeMap_eq; try eapply Hlt_new1.
move mtch_gtr1 at bottom.
symmetry; eapply mtch_gtr1.
reflexivity.
-- simpl in *.
erewrite <- mtch_gtr2; eauto.
* erewrite restrPermMap_irr; eauto.
erewrite mtch_gtr2; eauto.
* rewrite <- mtch_locks; eauto.
* clear - Hangel1 mtch_gtr1.
repeat intro.
erewrite <- mtch_gtr1, <- computeMap_ext by eauto; apply Hangel1.
* erewrite <- mtch_gtr2; apply Hangel2. }
{ rewrite <- H6 in Hsafe.
intro; eapply IHn; auto.
2:{ eapply (csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto. }
{ auto. }
apply MTCH_updLockSet, MTCH_updThread; auto.
- constructor; constructor; auto.
- apply computeMap_ext; auto.
- subst newThreadPerm; intros; simpl.
erewrite mtch_gtr2; eauto. }
+ eapply AngelSafe.
{ eapply sync_step with (Hcmpt0 := MTCH_compat _ _ _ H0 Hcmpt); eauto.
eapply step_release; simpl; eauto; simpl; eauto.
* eapply MTCH_invariant; eauto.
* erewrite restrPermMap_irr; eauto.
* erewrite restrPermMap_irr; eauto.
* erewrite restrPermMap_irr; eauto.
erewrite mtch_gtr2; eauto.
* rewrite <- mtch_locks; eauto.
* clear - Hangel1 mtch_gtr1.
repeat intro.
specialize (Hangel1 b ofs); simpl in *.
erewrite <- mtch_gtr1, <- computeMap_ext; eauto.
* erewrite <- mtch_gtr2; apply Hangel2. }
{ rewrite <- H6 in Hsafe.
intro; eapply IHn; auto.
2:{ eapply (csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto. }
{ auto. }
apply MTCH_updLockSet, MTCH_updThread; auto.
- constructor; constructor; auto.
- apply computeMap_ext; auto.
- subst newThreadPerm; intros; simpl.
erewrite mtch_gtr2; eauto. }
+ eapply AngelSafe.
{ eapply sync_step with (Hcmpt0 := MTCH_compat _ _ _ H0 Hcmpt); eauto.
eapply step_create with (virtue3 := virtue1)(virtue4 := virtue2); simpl; eauto; simpl; eauto.
* eapply MTCH_invariant; eauto.
* subst newThreadPerm threadPerm'; intros ??; simpl in *.
specialize (Hangel1 b0 ofs0).
erewrite <- mtch_gtr1, <- (computeMap_ext _ _ (fst virtue1)) by eauto; apply Hangel1.
* erewrite <- mtch_gtr2; apply Hangel2. }
{ rewrite <- H6 in Hsafe.
intro; eapply IHn; auto.
2:{ eapply (csafe_trace(ThreadPool := OrdinalPool.OrdinalThreadPool)),
(csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto. }
{ auto. }
apply MTCH_addThread; auto.
apply MTCH_updThread; auto.
- constructor; constructor; auto.
- apply computeMap_ext; auto.
- subst threadPerm'; intros; simpl.
erewrite mtch_gtr2; eauto. }
+ eapply AngelSafe.
{ eapply sync_step with (Hcmpt0 := MTCH_compat _ _ _ H0 Hcmpt); eauto.
eapply step_mklock with (pmap_tid'0 := (_, _)); simpl; eauto; simpl; eauto.
* eapply MTCH_invariant; eauto.
* erewrite <- restrPermMap_ext; eauto.
intro; extensionality ofs0; auto.
* erewrite <- restrPermMap_ext; eauto.
intro; extensionality ofs0; auto.
* rewrite <- mtch_locks; auto. }
{ rewrite <- H6 in Hsafe.
intro; eapply IHn; auto.
2:{ eapply (csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto. }
{ auto. }
apply MTCH_updLockSet, MTCH_updThread; auto.
* constructor; constructor; auto.
* intros; simpl.
setoid_rewrite <- Hdata_perm.
rewrite !addressFiniteMap.setPermBlock_lookup.
destruct (adr_range_dec _ _ _); auto.
* simpl.
setoid_rewrite <- Hlock_perm.
erewrite <- mtch_gtr2; eauto. }
+ eapply AngelSafe.
{ eapply sync_step with (Hcmpt0 := MTCH_compat _ _ _ H0 Hcmpt); eauto.
eapply step_freelock with (pmap_tid'0 := (_, _)); simpl; eauto; simpl; eauto.
* eapply MTCH_invariant; eauto.
* rewrite <- mtch_locks; auto.
* erewrite restrPermMap_irr; eauto. }
{ rewrite <- H6 in Hsafe.
intro; eapply IHn; auto.
2:{ eapply (csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto. }
{ auto. }
apply MTCH_remLockSet, MTCH_updThread; auto.
* constructor; constructor; auto.
* intros; simpl.
setoid_rewrite <- Hdata_perm.
destruct (adr_range_dec (b, Ptrofs.intval ofs) LKSIZE (b0, ofs0)).
-- destruct a; subst.
rewrite !setPermBlock_var_same by (unfold LKSIZE_nat; rewrite Z2Nat.id; lkomega); auto.
-- destruct (eq_dec b b0); [|rewrite !setPermBlock_var_other_2; auto].
subst; assert (~(Ptrofs.intval ofs <= ofs0 < Ptrofs.intval ofs + LKSIZE)).
{ intro; contradiction n0; split; auto. }
rewrite !setPermBlock_var_other_1; auto; unfold LKSIZE_nat; rewrite Z2Nat.id; lkomega.
* simpl.
setoid_rewrite <- Hlock_perm.
erewrite <- mtch_gtr2; eauto. }
+ eapply AngelSafe.
{ eapply sync_step with (Hcmpt0 := MTCH_compat _ _ _ H0 Hcmpt); eauto.
eapply step_acqfail; simpl; eauto; simpl; eauto.
* eapply MTCH_invariant; eauto.
* erewrite restrPermMap_irr; eauto.
* erewrite restrPermMap_irr; eauto. }
{ rewrite <- H6 in Hsafe.
intro; eapply IHn; auto.
2:eapply (csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto.
{ auto. }
auto.
}
(*  - inv Hhalted; contradiction.*)
- subst; eapply AngelSafe.
{ simpl; rewrite <- H5.
eapply schedfail; eauto; simpl.
- inv H0.
intro; contradiction Htid; apply mtch_cnt'; auto.
- eapply MTCH_invariant; eauto.
- eapply MTCH_compat; eauto. }
{ intro; eapply IHn; auto.
2: eapply (csafe_reduce(ThreadPool := OrdinalPool.OrdinalThreadPool)); eauto.
{ auto. }
auto.
}
Unshelve.
all: auto.
2: apply cntUpdate; auto.
+ unfold add_block.
hnf in Hperm; subst.
unshelve eapply @CoreLanguageDry.decay_compatible with (m := m); auto.
* eapply MTCH_compat; eauto.
* eapply MTCH_invariant; eauto.
* split.
{ rewrite restrPermMap_valid; intros.
(*        eapply Mem.valid_block_alloc_inv in H2; eauto. rewrite restrPermMap_valid in H2; destruct H2; [|contradiction]. *)
subst; right; intro. contradiction. }
rewrite restrPermMap_valid; intro.
right; intro.
erewrite restrPermMap_ext; eauto.
intro; extensionality ofs2; auto.
+ eapply mem_compatible_updThreadC, MTCH_compat; eauto.
+ erewrite <- mtch_gtr2; eauto.
+ erewrite <- mtch_gtr2; eauto.
Admitted.
Definition init_threadpool :=
@initial_machine (Clight_newSem ge)
(@OrdinalPool.OrdinalThreadPool dryResources (Clight_newSem ge))
(getCurPerm init_mem) (initial_corestate CPROOF).
Transparent getThreadC.
(*New safety theorem, with the correct initial state: TODO: swap the names when we think it's ready. *)
(* This is the right initial state, should be a [Callstate]*)
Definition initial_Clight_state' : Clight.state.
Admitted.
Definition main_pointer:= Vptr (projT1 (spr CPROOF)) Ptrofs.zero.

(* Question: this proof assumes no arguments to main. can we cahnge that? *)
Lemma initial_Clight_state_is_initial:
Clight.entry_point ge init_mem initial_Clight_state' main_pointer nil.