(******************************************************************************)
(** Conversions between single steps and block execution steps                *)
(******************************************************************************)
Require Import Classical Peano_dec.
From hahn Require Import Hahn.
Require Import Omega.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_s_hb.
Require Import imm_s.
Require Import OCaml.
Require Import OmmProgram.
Require Import ListHelpers.
Require Import OmmImmCompScheme.
Require Import ListHelpersTemp.
Require Import Utils.
Require Import ClosuresProperties.
Require Import Prog.
Require Import ProgToExecution.
Require Import ProgToExecutionProperties.
Require Import Logic.Decidable.
From PromisingLib Require Import Basic Loc.
Require Import Basics.
Set Implicit Arguments.

Section Steps.

Lemma init_mm_same: forall PO BPI (COMP: is_thread_block_compiled PO BPI),
    mm_similar_states (init PO) (binit BPI).
Proof.
  ins. red. simpl. splits; auto.
  3: { basic_solver. }
  2: { ins. simpl. unfold DepsFile.init. simpl. basic_solver. }
  unfold init_execution. red. simpl. basic_solver.
Qed.

Lemma steps_same_instrs sti sti' (STEPS: exists tid, (step tid)＊ sti sti'):
  instrs sti = instrs sti'.
Proof.
  destruct STEPS as [tid STEPS]. apply crt_num_steps in STEPS.
  destruct STEPS as [n STEPS].
  generalize dependent sti'.
  induction n.
  - intros sti' STEPS. simpl in STEPS. generalize STEPS. basic_solver 10.
  - intros sti' STEPS.
    rewrite step_prev in STEPS. destruct STEPS as [sti'' STEPS'']. desc.
    replace (instrs sti) with (instrs sti'').
    { red in STEPS''0. desf. red in STEPS''0. desf. }
    symmetry. eapply IHn. eauto.
Qed.

Lemma omm_steps_same_instrs sto sto' (STEPS: exists tid, (Ostep tid)＊ sto sto'):
  instrs sto = instrs sto'.
Proof.
  (* TODO: join with previous*)
  destruct STEPS as [tid STEPS]. apply crt_num_steps in STEPS.
  destruct STEPS as [n STEPS].
  generalize dependent sto'.
  induction n.
  - intros sto' STEPS. simpl in STEPS. generalize STEPS. basic_solver 10.
  - intros sto' STEPS.
    rewrite step_prev in STEPS. destruct STEPS as [sto'' STEPS'']. desc.
    replace (instrs sto) with (instrs sto'').
    { red in STEPS''0. desf. red in STEPS''0. desf. }
    symmetry. eapply IHn. eauto.
Qed.

Definition on_block st block :=
  ⟪ PROG_BLOCK: block = sublist (instrs st) (pc st) (length block) ⟫ /\
  ⟪ COMP_BLOCK: (exists oinstr, is_instruction_compiled oinstr block) ⟫.

Definition at_compilation_block st :=
  (exists block, on_block st block) \/ is_terminal st.

Definition oseq_step (tid : thread_id) sti1 sti2 :=
  exists block, on_block sti1 block /\
           (step tid) ^^ (length block) sti1 sti2.

Lemma igt_compiled_addr cond addr PO PI (IN_COMP: In (Instr.ifgoto cond addr) PI)
      (COMP: is_thread_compiled PO PI):
  addr <= length PI.
Proof.
  cdes COMP. cdes COMP0.
  red in COMP1. desc. clear COMP COMP0. subst PI.
  replace (length (flatten BPI)) with (length (flatten BPI0)).
  2: { ins.
       rewrite <- firstn_all with (l := BPI0).
       rewrite <- firstn_all with (l := BPI).
       replace (length BPI) with (length BPI0).
       2: { eapply Forall2_length; eauto. }
       apply SAME_STRUCT_PREF. eapply correction_same_struct; eauto. }
  assert (exists BPI_corr, Forall2 (block_corrected BPI_corr) BPI0 BPI /\ same_struct BPI_corr BPI0) as CORR_ALT.
  { exists BPI0. splits; vauto. apply same_struct_refl. }
  desc.
  replace (length (flatten BPI0)) with (length (flatten BPI_corr)).
  2: { ins.
       rewrite <- firstn_all with (l := BPI0).
       rewrite <- firstn_all with (l := BPI_corr).
       replace (length BPI_corr) with (length BPI0).
       2: { symmetry. red in CORR_ALT0. eapply Forall2_length; eauto. }
       apply SAME_STRUCT_PREF. auto. }
  clear COMP3 CORR_ALT0.
  generalize dependent BPI. generalize dependent BPI0. induction PO.
  { ins. inversion COMP1. subst. inversion CORR_ALT. subst. vauto. }
  ins. inversion COMP1. subst. inversion CORR_ALT. subst.
  simpl in IN_COMP. apply in_app_or in IN_COMP. des.
  2: { specialize (IHPO l' H3 l'0 IN_COMP H5). auto. }
  (* Ltac invert_nil := match goal with *)
  (*                    | H:  *)
  inversion H1; subst.
  { inversion H2. subst. inversion H7. subst. inversion H4. subst.
    subst ld. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H9. subst.
    inversion H6. subst. inversion H4. subst.
    subst f st. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H9. subst.
    inversion H6. subst. inversion H4. subst.
    subst f ld. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H9. subst.
    inversion H6. subst. inversion H4. subst.
    subst f exc. simpl in IN_COMP. des; vauto. }
  { subst. inversion H2. subst. inversion H7. subst. inversion H4. subst.
    subst asn. simpl in IN_COMP. des; vauto. }
  subst. inversion H2. subst. inversion H7. subst.
  subst igt. inversion H4; vauto.
  simpl in IN_COMP. des; [| done].
  inversion IN_COMP. subst.
  subst addr1.
  rewrite <- firstn_skipn with (l := BPI_corr) (n := n) at 2.
  rewrite flatten_app, app_length. omega.
Qed.

Lemma is_terminal_pc_bounded st tid PO PI (REACH: (step tid)＊ (init PI) st)
      (COMP: is_thread_compiled PO PI):
  is_terminal st <-> pc st = length (instrs st).
Proof.
  unfold is_terminal.
  split; [|omega].
  apply crt_num_steps in REACH. desc. generalize dependent st. induction n.
  { ins. red in REACH. desc. subst. simpl in *. omega. }
  ins. red in REACH. desc.
  do 2 (red in REACH0; desc).
  assert (forall instr, Some instr = nth_error (instrs z) (pc z) ->
                   pc st = pc z + 1 -> pc st = length (instrs st)) as NEXT_HELPER.
  { ins. assert (pc z < length (instrs st)).
    { apply nth_error_Some, OPT_VAL. rewrite <- INSTRS. eauto. }
    omega. }
  inversion ISTEP0; try (by eapply NEXT_HELPER; eauto).
  destruct (Const.eq_dec (RegFile.eval_expr (regf z) expr) 0).
  { eapply NEXT_HELPER; eauto. }
  forward eapply (@igt_compiled_addr expr shift PO (instrs z)) as BOUND.
  { subst instr. eapply nth_error_In. eauto. }
  { replace (instrs z) with PI; auto.
    replace PI with (instrs (init PI)) by vauto.
    apply steps_same_instrs. exists tid. apply crt_num_steps. eauto. }
  rewrite INSTRS in BOUND. omega.
Qed.

Definition bst_from_st st BPI b :=
  {|
    binstrs := BPI;
    bpc := b;
    bG := G st;
    beindex := eindex st;
    bregf := regf st;
    bdepf := depf st;
    bectrl := ectrl st |}.

Definition min_prop {A: Type} (P: list A -> Prop)
  := forall l (Pl: P l), (forall l1 l2 (LT: l2 <> []) (SPLIT: l = l1 ++ l2), ~ P l1).

Lemma firstn_length_leq {A: Type} (l: list A) i:
  length (firstn i l) <= length l.
Proof.
  generalize dependent l. induction i.
  { ins. omega. }
  ins. destruct l; vauto.
  simpl. apply le_n_S. auto.
Qed.

Lemma start_block_deterministic
      (A : Type)
      (P : list A -> Prop)
      (block : list A)
      (block' : list A)
      (ll : list (list A))
      (MINPROP : min_prop P)
      (NEblock: block <> [])
      (Pblock: P block)
      (NE_B : block' <> [])
      (BLOCK'_P : P block')
      (BLOCK' : block' = firstn (length block') (flatten (block :: ll))):
  block' = block.
Proof.
  assert (block = firstn (length block) (block ++ flatten ll)) as L0.
  { rewrite <- Nat.add_0_r with (n := length block).
    rewrite firstn_app_2. simpl. symmetry. apply app_nil_r. }
  assert (length block' <= length (flatten (block :: ll))) as LEN_B.
  { apply (@f_equal _ _ (@length _)) in BLOCK'.
    pose proof (firstn_length_leq (flatten (block :: ll)) (length block')). omega. }
  assert (length block <= length (flatten (block :: ll))) as LEN_L0.
  { simpl. rewrite app_length. omega. }
  destruct (lt_eq_lt_dec (length block') (length block)) as [[LT | EQ] | GT].
  2: { forward eapply (@firstn_ge_incl _ (flatten (block :: ll)) (length block') (length block)) as PREF; [omega| ].
       rewrite EQ in PREF at 2. rewrite skipn_firstn_nil in PREF.
       rewrite app_nil_r in PREF. simpl in BLOCK'. congruence. }
  { forward eapply (@firstn_ge_incl _ (flatten (block :: ll)) (length block') (length block)) as PREF; [omega| ].
    exfalso.
    simpl in *. rewrite <- BLOCK', <- L0 in PREF.
    red in MINPROP. specialize (MINPROP block Pblock block' (skipn (length block') block)).
    apply MINPROP; vauto.
    apply (@f_equal _ _ (@length _)) in PREF. rewrite app_length in PREF.
    red. ins. apply NE_B. apply length_zero_iff_nil.
    apply length_zero_iff_nil in H. omega. }
  forward eapply (@firstn_ge_incl _ (flatten (block :: ll)) (length block) (length block')) as PREF; [omega| ].
  exfalso.
  simpl in *. rewrite <- BLOCK', <- L0 in PREF.
  red in MINPROP. specialize (MINPROP block' BLOCK'_P block (skipn (length block) block')).
  apply MINPROP; vauto.
  apply (@f_equal _ _ (@length _)) in PREF. rewrite app_length in PREF.
  red. ins. apply NEblock.
  apply length_zero_iff_nil.  apply length_zero_iff_nil in H. omega.
Qed.

Lemma ll_l_corr {A: Type} ll (l: list A) (FLT: l = flatten ll) block b
      (NE_LL: Forall (fun l => l <> []) ll)
      P (MINPROP: min_prop P)
      (P_LL: Forall P ll)
      (NE_B: block <> [])
      (BLOCK_P: P block):
  block = sublist l (length (flatten (firstn b ll))) (length block)
  <-> Some block = nth_error ll b.
Proof.
  generalize dependent block. generalize dependent ll. generalize dependent l.
  induction b.
  { intros. unfold sublist. rewrite FLT. simpl.
    split.
    { intros BLOCK. destruct ll.
      { simpl in BLOCK. rewrite firstn_nil in BLOCK. vauto. }
      f_equal.
      eapply start_block_deterministic; eauto; [inv NE_LL| inv P_LL]. }
    intros BLOCK. destruct ll; vauto. simpl.
    rewrite <- Nat.add_0_r with (n := length l0). rewrite firstn_app_2.
    simpl. symmetry. apply app_nil_r. }
  ins. destruct ll; vauto.
  { simpl. unfold sublist. simpl. rewrite firstn_nil. vauto. }
  simpl. rewrite app_length. unfold sublist.
  rewrite skipn_app.
  replace (skipn (length l0 + length (flatten (firstn b ll))) l0) with (@nil A).
  2: { clear NE_LL. clear P_LL. induction l0.
       { simpl. destruct (length (flatten (firstn b ll))); vauto. }
       simpl. auto. }
  rewrite app_nil_l.
  replace (length l0 + length (flatten (firstn b ll)) - length l0) with (length (flatten (firstn b ll))) by omega.
  apply IHb; vauto.
  { inversion NE_LL. vauto. }
  inversion P_LL. vauto.
Qed.

Lemma instr_compiled_min_prop:
  min_prop (fun blk : list Instr.t =>
              exists oinstr : Instr.t, is_instruction_compiled oinstr blk).
Proof.
  red. intros block [oinstr COMP] block' block'' NE'' BLOCK_STRUCT.
  red. intros [oinstr' COMP'].
  inversion COMP; subst.
  all: (inversion COMP'; subst; inversion H0; subst; auto).
Qed.

Lemma ll_l_corr_helper BPI PI (FLT: PI = flatten BPI) block b
      (COMP: exists PO, is_thread_block_compiled PO BPI)
      (COMP_BLOCK: exists oinstr, is_instruction_compiled oinstr block)
  :
    block = sublist PI (length (flatten (firstn b BPI))) (length block)
    <-> Some block = nth_error BPI b.
Proof.
  eapply ll_l_corr with (P := fun blk => exists oinstr, is_instruction_compiled oinstr blk); vauto.
  { desc. eapply COMPILED_NONEMPTY; eauto. }
  { apply instr_compiled_min_prop. }
  { clear COMP_BLOCK. eapply Forall_index. ins.
    desc. eapply resulting_block_compiled; eauto.
    eapply COMPILED_NONEMPTY; eauto. }
  desc. inversion COMP_BLOCK; vauto.
Qed.

Lemma st_bst_prog_blocks bst block (COMP: exists PO, is_thread_block_compiled PO (binstrs bst)):
  on_block (bst2st bst) block <-> Some block = nth_error (binstrs bst) (bpc bst).
Proof.
  desc.
  assert (Forall (fun l : list Instr.t => l <> []) (binstrs bst)) as BPI_NE.
  { eapply COMPILED_NONEMPTY; eauto. }
  split.
  { intros ON_BLOCK. red in ON_BLOCK. desc.
    unfold bst2st in PROG_BLOCK. simpl in PROG_BLOCK.
    eapply ll_l_corr_helper in PROG_BLOCK; eauto. }
  intros BLOCK. red.
  forward eapply resulting_block_compiled as COMP'; eauto.
  splits; auto.
  eapply ll_l_corr_helper; vauto.
Qed.

Definition on_block_pc pc PI block :=
  ⟪BLOCK: block = sublist PI pc (length block)⟫ /\
  ⟪COMP_BLOCK: exists oinstr : Instr.t, is_instruction_compiled oinstr block⟫.

(* TODO: remove it since exact instruction is known when block_start is called? *)
Lemma block_start pc PI block instr (BLOCK: on_block_pc pc PI block)
      (AT_PC: Some instr = nth_error PI pc):
  (exists mode, instr = Prog.Instr.fence mode) \/
  (exists loc expr, instr = Prog.Instr.load Orlx loc expr) \/
  (exists cond loc, instr = Prog.Instr.ifgoto cond loc) \/
  (exists reg expr, instr = Prog.Instr.assign reg expr).
Proof.
  red in BLOCK. desc.
  inversion COMP_BLOCK.
  all: subst; simpl in *.
  (* TODO: refactor *)
  - assert (AT_PC1: Some ld = nth_error PI pc).
    { apply eq_trans with (y := nth_error [ld] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    right. left. subst ld. eauto.
  - assert (AT_PC1: Some f = nth_error PI pc).
    { apply eq_trans with (y := nth_error [f; st] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    left. subst f. eauto.
  - assert (AT_PC1: Some f = nth_error PI pc).
    { apply eq_trans with (y := nth_error [f; ld] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    left. subst f. eauto.
  - assert (AT_PC1: Some f = nth_error PI pc).
    { apply eq_trans with (y := nth_error [f; exc] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    left. subst f. eauto.
  - assert (AT_PC1: Some asn = nth_error PI pc).
    { apply eq_trans with (y := nth_error [asn] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    do 3 right. subst asn. eauto.
  - assert (AT_PC1: Some igt = nth_error PI pc).
    { apply eq_trans with (y := nth_error [igt] 0); auto.
      rewrite <- (NPeano.Nat.add_0_r pc).
      eapply sublist_items; eauto. }
    rewrite <- AT_PC in AT_PC1. inversion AT_PC1.
    do 2 right. left. subst igt. eauto.
Qed.

Lemma block_mid pc PI block instr (BLOCK: on_block_pc pc PI block)
      (BLOCK_LEN: length block >= 2)
      (AT_PC1: Some instr = nth_error PI (pc + 1)):
  (exists loc expr, instr = Prog.Instr.store Orlx loc expr) \/
  (exists loc expr, instr = Prog.Instr.load Osc loc expr) \/
  (exists expr loc, instr = Prog.Instr.update (Prog.Instr.exchange expr) false Xpln Osc Osc exchange_reg loc).
Proof.
  red in BLOCK. desc.
  inversion COMP_BLOCK.
  all: (rename H into OINSTR; rename H0 into BLOCK_CONTENTS).
  all: subst block; simpl in *.
  (* trivial cases for single instruction blocks *)
  all: try omega.
  (* now only 2-blocks remain*)
  (* TODO: refactor *)
  { assert (AT_PC1': Some st = nth_error PI (pc + 1)).
    { apply eq_trans with (y := nth_error [f; st] 1); auto.
      eapply sublist_items; eauto. }
    replace instr with st; [| congruence].
    subst st. eauto. }
  { assert (AT_PC1': Some ld = nth_error PI (pc + 1)).
    { apply eq_trans with (y := nth_error [f; ld] 1); auto.
      eapply sublist_items; eauto. }
    replace instr with ld; [| congruence].
    subst ld. eauto. }
  { assert (AT_PC1': Some exc = nth_error PI (pc + 1)).
    { apply eq_trans with (y := nth_error [f; exc] 1); auto.
      eapply sublist_items; eauto. }
    replace instr with exc; [| congruence].
    subst exc. eauto. }
Qed.

Lemma no_acb_between_pc pc1 pc2 n (PC2: pc2 = pc1 + n)
      block (* (BLOCK: on_block st1 block) *)
      PI (BLOCK: on_block_pc pc1 PI block)
      (LT: n < length block) (NZ: n <> 0):
  not ((exists block', on_block_pc pc2 PI block') \/ pc2 >= length PI).
Proof.
  pose proof BLOCK as BLOCK1.
  red in BLOCK. desc.
  inversion COMP_BLOCK.
  all: rename H into OINSTR.
  all: rename H0 into BLOCK_CONTENTS.
  all: subst block; simpl in *.
  (* trivial cases for single instruction blocks *)
  all: try (replace (n) with (0) in *; [vauto | omega]).
  (* now only 2-blocks remain*)
  all: replace n with 1 in *; [| omega].
  (* TODO: refactor *)
  { assert (AT_PC1: Some st = nth_error PI (pc1 + 1)).
    { apply eq_trans with (y := nth_error [f; st] 1); auto.
      eapply sublist_items; eauto. }
    assert (AT_PC: Some f = nth_error PI pc1).
    { apply eq_trans with (y := nth_error [f; st] 0); auto.
      replace pc1 with (pc1 + 0) by omega.
      eapply sublist_items; eauto. }

    red. intros ACB2. (* red in ACB2. *)
    destruct ACB2 as [[block2 BLOCK2]| TERM2].
    2: { subst pc2.
         red in TERM2. (* rewrite NEXT_PC, SAME_INSTRS in TERM2. *)
         pose proof (nth_error_None PI (pc1 + 1)) as CONTRA.
         apply not_iff_compat in CONTRA. destruct CONTRA as [CONTRA _].
         forward eapply CONTRA; [apply OPT_VAL; eauto| ].
         ins. }
    forward eapply (block_start) as PC1_INSTR; eauto.
    { rewrite PC2. eauto. }
    forward eapply (block_mid BLOCK1) as PC1_INSTR'; eauto.
    des.
    all: (rewrite PC1_INSTR in PC1_INSTR'; discriminate). }
  { assert (AT_PC1: Some ld = nth_error PI (pc1 + 1)).
    { apply eq_trans with (y := nth_error [f; ld] 1); auto.
      eapply sublist_items; eauto. }
    assert (AT_PC: Some f = nth_error PI pc1).
    { apply eq_trans with (y := nth_error [f; ld] 0); auto.
      replace pc1 with (pc1 + 0) by omega.
      eapply sublist_items; eauto. }

    red. intros ACB2.
    destruct ACB2 as [[block2 BLOCK2]| TERM2].
    2: { red in TERM2. (* rewrite NEXT_PC, SAME_INSTRS in TERM2. *)
         pose proof (nth_error_None PI (pc1 + 1)) as CONTRA.
         destruct CONTRA. forward eapply H0; try omega.
         intros. rewrite H1 in AT_PC1. discriminate. }
    forward eapply (block_start) as PC1_INSTR; eauto.
    { rewrite PC2. eauto. }
    forward eapply (block_mid BLOCK1) as PC1_INSTR'; eauto.
    des.
    all: (rewrite PC1_INSTR in PC1_INSTR'; discriminate). }
  { assert (AT_PC1: Some exc = nth_error PI (pc1 + 1)).
    { apply eq_trans with (y := nth_error [f; exc] 1); auto.
      eapply sublist_items; eauto. }
    assert (AT_PC: Some f = nth_error PI pc1).
    { apply eq_trans with (y := nth_error [f; exc] 0); auto.
      replace pc1 with (pc1 + 0) by omega.
      eapply sublist_items; eauto. }
    red. intros ACB2.
    destruct ACB2 as [[block2 BLOCK2]| TERM2].
    2: { red in TERM2. rewrite PC2 in TERM2.
         pose proof (nth_error_None PI (pc1 + 1)) as CONTRA.
         destruct CONTRA. forward eapply H0; try omega.
         intros. rewrite H1 in AT_PC1. discriminate. }
    forward eapply (block_start) as PC1_INSTR; eauto.
    { rewrite PC2. eauto. }
    forward eapply (block_mid BLOCK1) as PC1_INSTR'; eauto.
    des.
    all: (rewrite PC1_INSTR in PC1_INSTR'; discriminate). }
Qed.

Lemma no_acb_between st1 st2 tid block n (STEPS: (step tid) ^^ n st1 st2)
      (BLOCK: on_block st1 block) (LT: n < length block) (NZ: n <> 0):
  not (at_compilation_block st2).
Proof.
  assert (SAME_INSTRS: instrs st2 = instrs st1).
  { symmetry. apply steps_same_instrs. eexists. eapply crt_num_steps. eauto. }
  pose proof BLOCK as BLOCK1.
  red in BLOCK. desc.

  cut (not ((exists block', on_block_pc (pc st2) (instrs st1) block') \/ (pc st2 >= length (instrs st1)))).
  { ins. red. ins. apply H. red in H0. des.
    { left. exists block0. red in H0.
      rewrite SAME_INSTRS in H0.
      desc. red. splits; eauto. }
    right. red in H0. congruence. }

  eapply no_acb_between_pc; eauto.
  assert (length block = 2 -> exists md, Some (Instr.fence md) = nth_error (instrs st1) (pc st1)).
  { ins. inversion COMP_BLOCK; vauto.
    all: subst f.
    { exists Oacqrel.
      apply eq_trans with (y := nth_error [Instr.fence Oacqrel; st] 0); auto.
      replace (pc st1) with (pc st1 + 0) by omega.
      eapply sublist_items; vauto. }
    { exists Oacq.
      apply eq_trans with (y := nth_error [Instr.fence Oacq; ld] 0); auto.
      replace (pc st1) with (pc st1 + 0) by omega.
      eapply sublist_items; vauto. }
    exists Oacq.
    apply eq_trans with (y := nth_error [Instr.fence Oacq; exc] 0); auto.
    replace (pc st1) with (pc st1 + 0) by omega.
    eapply sublist_items; vauto. }
  inversion COMP_BLOCK; subst; simpl in *; try omega.
  all: replace n with 1 in * by omega.
  all: apply (same_relation_exp (pow_1 (step tid))) in STEPS.
  all: red in STEPS; desc; red in STEPS; desc.
  all: inversion ISTEP0; vauto.
  all: destruct H as [md FENCE]; auto.
  all: rewrite <- FENCE in ISTEP.
  all: inversion ISTEP.
Qed.

Lemma skipn_0 {A: Type} (l: list A): skipn 0 l = l.
Proof. destruct l; vauto. Qed.

Lemma on_block_iff_bindex BPI
      block pc (SL: block = sublist (flatten BPI) pc (length block))
      (COMP: exists PO, is_thread_block_compiled PO BPI):
  (exists oinstr, is_instruction_compiled oinstr block) <->
  exists b, Some block = nth_error BPI b /\ pc = length (flatten (firstn b BPI)).
Proof.
  split.
  2: { ins. desc. eapply resulting_block_compiled; eauto.
       eapply COMPILED_NONEMPTY; eauto. }
  intros COMP_BLOCK.
  assert (COMP': exists PO, itbc_weak PO BPI).
  { desc. exists PO. red. red in COMP. desc. eauto. }
  clear COMP.
  generalize dependent BPI.
  set (P := fun pc =>   forall BPI : list (list Instr.t),
                block = sublist (flatten BPI) pc (length block) ->
                (exists PO : list Instr.t, itbc_weak PO BPI) ->
                exists b : nat, Some block = nth_error BPI b /\ pc = length (flatten (firstn b BPI))).
  generalize dependent pc. apply (strong_induction P).
  intros pc IH. red. intros BPI BLOCK COMP.
  destruct BPI as [| blk0 BPI'].
  { exfalso. unfold sublist in BLOCK.
    desc.
    destruct pc; simpl in BLOCK; rewrite firstn_nil in BLOCK; inversion COMP_BLOCK; vauto. }
  destruct (ge_dec pc (length blk0)) as [GE | LT].
  { assert (block = sublist (flatten BPI') (pc - length blk0) (length block)).
    { rewrite BLOCK at 1.
      simpl. unfold sublist at 1.
      rewrite skipn_app. unfold sublist.
      rewrite firstn_app.
      rewrite skipn_all2; [| omega]. rewrite firstn_nil. simpl.
      rewrite Nat.sub_0_r. auto. }
    forward eapply (IH (pc - length blk0)) as IHprev.
    { desc. forward eapply COMPILED_NONEMPTY_weak as NE; eauto.
      inversion NE. subst. destruct blk0; vauto. simpl in *. omega. }
    red in IHprev. forward eapply (IHprev BPI' H) as [b' BLOCK'].
    { desc. destruct PO as [| oinstr_ PO'].
      { red in COMP. desc. inversion COMP. subst. inversion COMP0. }
      exists PO'. red. red in COMP. destruct COMP as [BPI0 [BPI0' [COMP CORR]]].
      inversion CORR. subst. inversion COMP. subst. eauto. }
    exists (S b'). desc. split; auto.
    simpl. rewrite app_length. omega. }
  apply not_ge in LT.
  assert (blk0 = firstn (length blk0) (blk0 ++ flatten BPI')) as BLK0.
  { rewrite <- Nat.add_0_r with (n := length blk0). rewrite firstn_app_2.
    rewrite firstn_O. symmetry. apply app_nil_r. }
  destruct (gt_0_eq pc).
  2: { subst. exists 0. simpl in *. split; auto. f_equal.
       unfold sublist in BLOCK. rewrite skipn_0 in BLOCK.
       eapply (start_block_deterministic (P := fun blk => exists oinstr, is_instruction_compiled oinstr blk)); eauto.
       { apply instr_compiled_min_prop. }
       { desc. pose proof (COMPILED_NONEMPTY_weak COMP).
         inv H. }
       { desc.
         eapply resulting_block_compiled_weak; eauto.
         { eapply COMPILED_NONEMPTY_weak; eauto. }
         Unshelve. 2: exact 0. vauto. }
       desc. inversion COMP_BLOCK; vauto. }
  exfalso.
  forward eapply (@no_acb_between_pc 0 pc pc) as NOACB; eauto.
  { Unshelve. 2: exact (blk0 ++ flatten BPI').
    red. splits; vauto.
    desc. eapply resulting_block_compiled_weak; eauto.
    { eapply COMPILED_NONEMPTY_weak; eauto. }
    Unshelve. 2: exact 0. auto. }
  { omega. }
  apply not_or in NOACB. desc.
  apply NOACB. exists block. red. splits; eauto.
Qed.

Lemma acb_iff_bst st BPI
      (COMP: exists PO, is_thread_compiled_with PO (instrs st) BPI)
      (REACH: exists tid, (step tid)＊ (init (instrs st)) st):
  at_compilation_block st <-> exists bst, ⟪ST: st = bst2st bst⟫ /\
                                   ⟪BINSTRS: binstrs bst = BPI⟫ /\
                                   ⟪BPC: bpc bst <= length BPI⟫.
Proof.
  split.
  { intros ACB. desc. red in COMP. desc.
    red in ACB. des.
    2: { exists (bst_from_st st BPI (length BPI)). splits; auto.
         unfold bst2st. simpl. rewrite firstn_all. rewrite <- COMP0.
         forward eapply (@is_terminal_pc_bounded st tid PO (flatten BPI)) as TERM; vauto.
         { congruence. }
         apply TERM in ACB. rewrite <- ACB.
         by destruct st. }
    red in ACB. desc.
    forward eapply (@on_block_iff_bindex BPI block (pc st)) as [BLOCK_INDEX _]; vauto.
    { congruence. }
    forward eapply BLOCK_INDEX as [b [BLOCK PC]]; eauto.
    exists (bst_from_st st BPI b). splits; auto.
    2: { apply Nat.lt_le_incl. apply nth_error_Some, OPT_VAL. eauto. }
    unfold bst2st, bst_from_st. simpl.
    rewrite <- PC, <- COMP0. by destruct st. }
  intros. desc. red. red in COMP. desc.
  subst.
  destruct (ge_dec (bpc bst) (length (binstrs bst))) as [TERM | NONTERM].
  { right.
    forward eapply (@is_terminal_pc_bounded (bst2st bst) tid PO (instrs (bst2st bst))) as TERM_EQ; vauto.
    apply TERM_EQ.
    pose proof is_terminal_pc_bounded.
    simpl.
    rewrite <- firstn_skipn with (n := bpc bst) (l := binstrs bst) at 2.
    rewrite skipn_all2; [| auto].
    rewrite app_nil_r. auto. }
  apply not_ge in NONTERM. left.
  apply nth_error_Some, OPT_VAL in NONTERM. destruct NONTERM as [block BLOCK].
  exists block. apply st_bst_prog_blocks; eauto.
Qed.

Definition non_igt instr :=
  ~ match instr with | Instr.ifgoto _ _ => True | _ => False end.

Lemma regular_pc_change st1 st2 tid (STEP: step tid st1 st2)
      instr (AT_PC: Some instr = nth_error (instrs st1) (pc st1))
      (NOT_IGT: non_igt instr):
  pc st2 = pc st1 + 1.
Proof.
  do 2 (red in STEP; desc). red in NOT_IGT.
  inversion ISTEP0; auto.
  assert (instr = instr0) by congruence. subst. vauto.
Qed.

Lemma steps_pc_change st1 st2 tid block (ON_BLOCK: on_block st1 block)
      (STEPS: (step tid) ^^ (length block) st1 st2):
  pc st2 = pc st1 + length block \/
  (exists (cond : Instr.expr) (addr : nat),
      block = [Instr.ifgoto cond addr] /\ pc st2 = addr).
Proof.
  red in ON_BLOCK. desc.
  destruct block as [| instr block'].
  { inversion COMP_BLOCK. }
  assert ([instr] = sublist (instrs st1) (pc st1) 1).
  { unfold sublist in *. simpl in PROG_BLOCK.
    simpl. destruct (skipn (pc st1) (instrs st1)); vauto. }
  assert (AT_PC: Some instr = nth_error (instrs st1) (pc st1)).
  { apply eq_trans with (y := nth_error [instr] 0); auto.
    rewrite <- (NPeano.Nat.add_0_r (pc st1)).
    eapply sublist_items; eauto. }
  destruct block' as [| instr' block''].
  {
    inversion COMP_BLOCK.
    3: { subst. simpl in *.
         apply (same_relation_exp (seq_id_l (step tid))) in STEPS.
         do 2 (red in STEPS; desc).
         (* actually most cases here are nonsense, but they still fit into lemma statement *)
         inversion ISTEP0; auto.
         subst instr.
         destruct (Const.eq_dec (RegFile.eval_expr (regf st1) expr) 0); auto.
         right. exists e. exists n. split; eauto.
         assert (igt = Instr.ifgoto expr shift) by congruence.
         inversion H0. auto. }
    all: left; subst; simpl in *.
    all: try apply (same_relation_exp (seq_id_l (step tid))) in STEPS.
    all: eapply regular_pc_change; vauto. }
  left.
  assert ([instr;  instr'] = sublist (instrs st1) (pc st1) 2).
  { unfold sublist in *. simpl in PROG_BLOCK.
    simpl. destruct (skipn (pc st1) (instrs st1)); vauto.
    destruct l; vauto. }
  assert (AT_PC': Some instr' = nth_error (instrs st1) (pc st1 + 1)).
  { apply eq_trans with (y := nth_error [instr; instr'] 1); auto.
    eapply sublist_items; eauto. }
  simpl.
  simpl in STEPS. red in STEPS. desc. red in STEPS. desc.
  assert (forall st' (STEP1: step tid st1 st') (STEP2: step tid st' st2)
            (NOT_IGT1: non_igt instr) (NOT_IGT2: non_igt instr'),
             pc st2 = pc st1 + 2) as STEPS2_HELPER.
  { ins.
    assert (pc st' = pc st1 + 1) by (eapply regular_pc_change; eauto).
    replace (pc st2) with (pc st' + 1); [omega| ].
    symmetry. eapply regular_pc_change; eauto.
    replace (instrs st') with (instrs st1); [congruence |].
    do 2 (red in STEP1; desc). auto. }

  inversion COMP_BLOCK; subst; simpl in *; red in STEPS; subst; desc.
  all: forward eapply STEPS2_HELPER; vauto.
Qed.

Lemma oseq_continuos st1 st2 tid PO
      (OSEQ: (oseq_step tid) st1 st2)
      (REACH: (step tid)＊ (init (instrs st1)) st1)
      (GOTO_RESTR: goto_addresses_restricted PO)
      (COMP: is_thread_compiled PO (instrs st1)):
  at_compilation_block st2.
Proof.
  red in OSEQ. desc.
  red in COMP. desc.
  assert (exists bst1, st1 = bst2st bst1 /\ binstrs bst1 = BPI /\ bpc bst1 <= length BPI) as [bst1 [BST1 [BINSTRS1 BPC1]]].
  { apply acb_iff_bst; vauto. }
  assert (Some block = nth_error (binstrs bst1) (bpc bst1)) as BLOCK.
  { apply st_bst_prog_blocks; vauto.
    exists PO. red in COMP. desc. auto. }
  forward eapply steps_pc_change as PC2; eauto.
  assert (instrs st2 = instrs st1) as SAME_INSTRS.
  { symmetry. apply steps_same_instrs. exists tid. apply crt_num_steps. eauto. }
  assert ((step tid)＊ (init (instrs st2)) st2) as REACH'.
  { rewrite SAME_INSTRS. eapply rt_trans; eauto. apply crt_num_steps. eauto. }

  assert (forall blc (STEPS: (step tid) ^^ (length blc) st1 st2)
            (BLC: Some blc = nth_error (binstrs bst1) (bpc bst1))
            (PC_PLUS: pc st2 = pc st1 + length blc),
             at_compilation_block st2) as NEXT_BLOCK.
  { ins. forward eapply (@acb_iff_bst st2) as [_ ACB_IF_BST].
    2: { eauto. }
    { rewrite SAME_INSTRS. eauto. }
    apply ACB_IF_BST.
    exists (bst_from_st st2 (binstrs bst1) (bpc bst1 + 1)).
    splits; auto.
    2: { simpl. apply le_lt_or_eq in BPC1. destruct BPC1; [omega |].
         subst.
         pose proof (proj2 (nth_error_None (binstrs bst1) (bpc bst1))).
         forward eapply H0; [omega| ]. ins. congruence. }
    unfold bst2st. simpl.
    replace (flatten (binstrs bst1)) with (instrs st2).
    2: { rewrite <- (@steps_same_instrs st1 st2); [subst; eauto| ].
         exists tid. apply crt_num_steps. eauto. }
    red in OSEQ. desc.
    clear dependent oinstr. (* to avoid confusion with actual initial oinstr *)
    pose proof ll_index_shift. specialize H with (j := (bpc bst1 + 1)). specialize_full H; eauto.
    { eapply COMPILED_NONEMPTY. Unshelve. 2: exact PO.
      red in COMP. desc. vauto. }
    { cut (bpc bst1 < length (binstrs bst1)); [ins; omega|].
      apply nth_error_Some, OPT_VAL. vauto. }
    cdes H. rewrite H1; auto.
    subst st1. unfold bst2st in PC_PLUS. simpl in PC_PLUS.
    rewrite <- PC_PLUS.
    by destruct st2. }

  destruct PC2 as [PC2 | PC2].
  - eapply NEXT_BLOCK; eauto.
  - desc. subst addr. (* subst block. *) simpl in *.
    red in COMP. desc.
    subst BPI.
    red in COMP. desc.
    assert (exists oinstr, Some oinstr = nth_error PO (bpc bst1)) as [oinstr OINSTR].
    { apply OPT_VAL. apply nth_error_Some.
      replace (length PO) with (length (binstrs bst1)).
      { apply nth_error_Some, OPT_VAL. eauto. }
      symmetry. apply compilation_same_length. red; vauto. }
    assert (exists block0, Some block0 = nth_error BPI0 (bpc bst1)) as [block0 BLOCK0].
    { apply OPT_VAL. apply nth_error_Some.
      replace (length BPI0) with (length (binstrs bst1)).
      { apply nth_error_Some, OPT_VAL. eauto. }
      symmetry. eapply Forall2_length. eauto. }
    assert (is_instruction_compiled oinstr block0) as COMP_BLOCK.
    { eapply Forall2_index; eauto. }
    assert (block_corrected BPI0 block0 block) as CORR_BLOCK.
    { eapply Forall2_index; eauto. }
    subst block.
    inversion CORR_BLOCK. inversion H3. subst.
    inversion H2; vauto. subst addr.
    inversion COMP_BLOCK. subst.
    simpl in OSEQ0. apply (same_relation_exp (seq_id_l (step tid))) in OSEQ0.
    do 2 (red in OSEQ0; desc).
    assert (instr = Instr.ifgoto cond (pc st2)).
    { forward eapply (@near_pc (Instr.ifgoto cond (pc st2)) _ 0) as AT_PC; eauto.
      { vauto. }
      { apply nth_error_Some, OPT_VAL. eauto. }
      rewrite Nat.add_0_r in AT_PC. congruence. }
    subst instr.
    inversion ISTEP0.
    all: try discriminate.
    destruct (Const.eq_dec (RegFile.eval_expr (regf (bst2st bst1)) expr) 0).
    + eapply NEXT_BLOCK; eauto. simpl.
      apply (same_relation_exp (seq_id_l (step tid))).
      red. eexists. red. eauto.
    + subst.
      inversion CORR_BLOCK. subst. inversion H4; vauto.
      forward eapply acb_iff_bst as [_ ACB_IF_BST].
      { rewrite <- INSTRS. exists PO. simpl. red. splits; eauto.
        vauto. }
      { eauto.  }
      apply ACB_IF_BST.
      exists (bst_from_st st2 (binstrs bst1) addr0). splits; auto.
      2: { simpl.
           replace (length (binstrs bst1)) with (length PO).
           2: { apply compilation_same_length. vauto. }
           red in GOTO_RESTR. eapply GOTO_RESTR; eauto. }
      unfold bst2st. simpl.
      replace (flatten (binstrs bst1)) with (instrs st2).
      replace (length (flatten (firstn addr0 (binstrs bst1)))) with (length (flatten (firstn addr0 BPI0))).
      2: { apply SAME_STRUCT_PREF. eapply correction_same_struct; eauto. }
      rewrite H5. by destruct st2.
Qed.

(* had to define it separately since otherwise Coq doesn't understand what P is *)
Definition StepProp n := forall st1 st2 tid PO (STEPS: (step tid) ^^ n st1 st2)
                           (REACH: (step tid)＊ (init (instrs st1)) st1)
                           bst1 (BST1: st1 = bst2st bst1)
                           bst2 (BST2: st2 = bst2st bst2)
                           (BOUND1: bpc bst1 <= length (binstrs bst1))
                           (BOUND2: bpc bst2 <= length (binstrs bst2))
                           (COMP: is_thread_block_compiled PO (binstrs bst1))
                           (GOTO_RESTR: goto_addresses_restricted PO)
                           (SAME_BINSTRS: binstrs bst1 = binstrs bst2),
    (omm_block_step_PO PO tid)＊ bst1 bst2.

Lemma oseq_between_acb: forall n, StepProp n.
Proof.
  apply strong_induction.
  unfold StepProp. intros n IH. ins. desc.
  assert (at_compilation_block st1) as ACB1.
  { eapply acb_iff_bst; eauto.
    unfold is_thread_compiled_with. exists PO.
    split; [congruence| ]. rewrite BST1. simpl. congruence. }
  assert (at_compilation_block st2) as ACB2.
  { forward eapply (@acb_iff_bst st2) as [_ ACB_IF_BST]; eauto.
    { exists PO. red. split; eauto. rewrite SAME_BINSTRS. vauto. }
    { exists tid. replace (instrs st2) with (instrs st1).
      2: { subst. simpl. congruence. }
      eapply transitive_rt; eauto.
      apply crt_num_steps. eauto. }
    apply ACB_IF_BST. exists bst2. splits; vauto. congruence. }
  assert (bst2st bst1 = bst2st bst2 -> (omm_block_step_PO PO tid)＊ bst1 bst2) as WHEN_SAME_BST.
  { intros SAME_BST2ST.
    replace bst2 with bst1; [apply rt_refl| ].
    destruct bst2. destruct bst1.
    f_equal; vauto.
    rewrite <- SAME_BINSTRS in BOUND2.
    simpl in *.
    eapply (@NONEMPTY_PREF _ binstrs); vauto.
    eapply COMPILED_NONEMPTY; eauto. }

  unfold at_compilation_block in ACB1. desf.
  2: { destruct n.
       { apply WHEN_SAME_BST. apply steps0 in STEPS. auto. }
       forward eapply (@steps_sub _ (step tid) (S n) _ _ 1) as [st' STEP];
         [omega | eauto |].
       apply (same_relation_exp (pow_1 (step tid))) in STEP.
       do 2 (red in STEP; desc).
       cut (None = nth_error (instrs (bst2st bst1)) (pc (bst2st bst1))); [congruence| ].
       symmetry. apply nth_error_None. red in ACB1. omega. }
  pose proof (le_lt_dec (length block) n) as LEN. destruct LEN.
  { forward eapply (steps_split (step tid) (length block) (n - length block)) as SPLIT.
    { symmetry. apply le_plus_minus. auto. }
    apply SPLIT in STEPS. destruct STEPS as  [st' [PREV_STEPS NEXT_STEPS]]. clear SPLIT.
    assert (oseq_step tid (bst2st bst1) st') as OSEQ.
    { red. eexists. eauto. }
    forward eapply (oseq_continuos OSEQ) as ACB'; vauto.
    assert (exists PO', is_thread_compiled PO' (instrs st')) as COMP'.
    { replace (instrs st') with (instrs (bst2st bst1)); vauto.
      apply steps_same_instrs. exists tid.
      (* remove duplicated proof *)
      red in OSEQ. desc. rewrite crt_num_steps. eexists. eauto. }
    assert (LEN': n - length block < n).
    { red in ACB1. desc. inversion COMP_BLOCK; subst; simpl in *; omega. }
    assert ((step tid)＊ (init (instrs st')) st') as REACH'.
    {  replace (instrs st') with (instrs (bst2st bst1)).
      2: { apply steps_same_instrs. exists tid. apply crt_num_steps. eauto. }
      eapply transitive_rt; eauto.
      apply crt_num_steps. eauto. }
    forward eapply (@acb_iff_bst st' (binstrs bst1)) as [BST_IF_ACB _]; eauto.
    { exists PO. red. split; auto.
      replace (instrs st') with (instrs (bst2st bst1)); auto.
      apply steps_same_instrs; eauto. exists tid. apply crt_num_steps. eauto. }
    specialize (BST_IF_ACB ACB'). destruct BST_IF_ACB as [bst' [BST' [SAME_BINSTRS' BPC']]].
    forward eapply IH as IH_; eauto.
    { red in SAME_BINSTRS'. rewrite SAME_BINSTRS'. auto. }
    { congruence. }
    { congruence. }
    apply clos_trans_in_rt. apply t_step_rt. exists bst'. split; auto.
    red. splits; vauto.
    exists block. red. splits; auto.
    apply st_bst_prog_blocks; eauto. rewrite <- BST'. auto. }
  destruct (NPeano.Nat.eq_0_gt_0_cases n).
  { subst. apply steps0 in STEPS. apply WHEN_SAME_BST. auto. }
  forward eapply no_acb_between; eauto; [omega | vauto].
Qed.

Definition is_block_terminal bst := bpc bst >= length (binstrs bst).

Lemma steps_imply_ommblocks bfin PO tid
      (BPC_LIM: bpc bfin <= length (binstrs bfin))
      (GOTO_RESTR: goto_addresses_restricted PO)
      (COMP: is_thread_block_compiled PO (binstrs bfin)):
  let fin := (bst2st bfin) in
  (step tid)＊ (init (instrs fin)) fin -> (omm_block_step_PO PO tid)＊ (binit (binstrs bfin)) bfin.
Proof.
  intros fin STEPS. apply crt_num_steps in STEPS as [n STEPS].
  eapply oseq_between_acb; eauto.
  2: { simpl. omega. }
  simpl. apply rt_refl.
Qed.

Lemma ommblocks_imply_steps bfin tid PO:
  let fin := (bst2st bfin) in
  (omm_block_step_PO PO tid)＊ (binit (binstrs bfin)) bfin -> (step tid)＊ (init (instrs fin)) fin.
Proof.
  intros fin STEPS. apply crt_num_steps in STEPS as [n STEPS].
  generalize dependent bfin. induction n.
  { ins. red in STEPS. desc. subst. simpl.
    replace (init (flatten (binstrs bfin))) with (bst2st bfin); [apply rt_refl| ].
    rewrite <- STEPS. vauto. }
  ins. apply crt_num_steps.
  red in STEPS. desc.
  assert (binstrs bfin = binstrs z) as BINSTRS_SAME.
  { red in STEPS0. desc. vauto. }
  rewrite BINSTRS_SAME in STEPS. specialize (IHn z STEPS).
  red in STEPS0. desc. red in BLOCK_STEP. desc.
  apply crt_num_steps in IHn. desc.
  exists (n0 + length block). eapply steps_split; eauto.
  eexists. splits; eauto. rewrite BINSTRS_SAME. auto.
Qed.

End Steps.


Require Import CoqlibC Maps Integers Floats Lattice Kildall.
Require Import AST Linking.
Require Import ValuesC Events Memory Globalenvs Smallstep.
Require Compopts Machregs.
Require Import Op Registers RTLC.
Require Import Liveness ValueDomain ValueAOp ValueAnalysisC.
Require Import ConstpropOp ConstpropOpproof Constprop.
(** newly added **)
Require Export Constpropproof.
Require Import Simulation.
Require Import Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem AsmregsC MatchSimModSem.
Require SimMemExt.
Require UnreachC.

Set Implicit Arguments.

Section SIMMODSEM.

Variable skenv_link: SkEnv.t.
Variable sm_link: SimMem.t.
Variables prog tprog: program.
Let md_src: Mod.t := (RTLC.module prog).
Let md_tgt: Mod.t := (RTLC.module tprog).
Hypothesis (INCLSRC: SkEnv.includes skenv_link (Mod.sk md_src)).
Hypothesis (INCLTGT: SkEnv.includes skenv_link (Mod.sk md_tgt)).
Hypothesis (WF: SkEnv.wf skenv_link).
Hypothesis TRANSL: match_prog prog tprog.
Let ge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_src)) prog).
Let tge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_tgt)) tprog).
Definition msp: ModSemPair.t := ModSemPair.mk (md_src skenv_link) (md_tgt skenv_link) (SimSymbId.mk md_src md_tgt) sm_link.

Inductive match_states
          (idx: nat) (st_src0: RTL.state) (st_tgt0: RTL.state) (sm0: SimMem.t): Prop :=
| match_states_intro
    (MATCHST: Constpropproof.match_states prog idx st_src0 st_tgt0)
    (MCOMPATSRC: (get_mem st_src0) = sm0.(SimMem.src))
    (MCOMPATTGT: (get_mem st_tgt0) = sm0.(SimMem.tgt)).

Theorem make_match_genvs :
  SimSymbId.sim_skenv (SkEnv.project skenv_link (Mod.sk md_src))
                      (SkEnv.project skenv_link (Mod.sk md_tgt)) ->
  Genv.match_genvs (match_globdef (fun cu f tf => tf = transf_fundef (romem_for cu) f) eq prog) ge tge.
Proof. subst_locals. eapply SimSymbId.sim_skenv_revive; eauto. Qed.

Theorem sim_modsem:ModSemPair.sim msp.
Proof.
  eapply match_states_sim with (match_states := match_states) (match_states_at := top4);
    eauto; ii; ss.
  - apply lt_wf.
  - eapply Preservation.local_preservation_strong_spec. eapply sound_state_preservation; auto.
  - (* init bsim *)
    destruct sm_arg; ss. clarify. inv INITTGT. inv SIMARGS; ss. clarify.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE. des.
    eexists. eexists (SimMemExt.mk _ _). esplits; eauto.
    + econs; eauto; ss.
      * inv TYP. rpapply match_states_call; eauto.
        { econs; eauto. }
        { eapply lessdef_list_typify_list; try apply VALS; eauto. rewrite <- LEN.
          symmetry. eapply lessdef_list_length; eauto. }
        folder. inv SAFESRC. inv TYP.
        exploit (Genv.find_funct_match_genv SIMGE); eauto. i; des. folder.
        inv FPTR; ss. clarify.
  - (* init progress *)
    des. inv SAFESRC. inv SIMARGS; ss. inv FPTR; ss.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE.
    exploit (Genv.find_funct_match_genv SIMGE); eauto. i; des. ss. des_ifs.
    inv TYP. esplits; eauto. econs; swap 1 2; eauto.
    + econs; eauto with congruence.
      erewrite <- lessdef_list_length; eauto.
    + erewrite <- lessdef_list_length; eauto.
  - (* call wf *)
    inv MATCH; ss. destruct sm0; ss. clarify.
    u in CALLSRC. des. inv CALLSRC. inv MATCHST; ss.
  - (* call fsim *)
    inv MATCH; ss. destruct sm0; ss. clarify.
    inv CALLSRC. inv MATCHST; ss; cycle 1. folder. esplits; eauto.
    + econs; eauto.
      * folder. des. r in TRANSL. r in TRANSL.
        exploit (SimSymbId.sim_skenv_revive TRANSL); eauto.
        { apply SIMSKENV. }
        intro GE. apply (fsim_external_funct_id GE); ss.
        folder. inv FPTR; ss.
      * des. esplits; eauto. eapply SimSymb.simskenv_func_fsim; eauto; ss.
    + econs; ss; eauto.
      * instantiate (1:= SimMemExt.mk _ _). ss.
      * ss.
    + ss.
  - (* after fsim *)
    inv AFTERSRC. inv SIMRET; ss. exists sm_ret. destruct sm_ret; ss. clarify.
    inv MATCH; ss. inv MATCHST; ss. esplits; eauto.
    + econs; eauto.
    + econs; ss; eauto. clarify. econs; eauto. eapply lessdef_typify; ss.
  - (* final fsim *)
    inv MATCH. inv FINALSRC; inv MATCHST; ss.
    clarify. inv STACKS. destruct sm0; ss. clarify.
    eexists (SimMemExt.mk _ _). esplits; ss; eauto. econs; eauto.
  - left; i. esplits; eauto.
    { apply RTLC.modsem_receptive; et. }
    inv MATCH. ii. hexploit (@transf_step_correct prog skenv_link skenv_link); eauto.
    { inv SIMSKENV. ss. }
    { apply make_match_genvs; eauto. apply SIMSKENV. }
    { des. esplits; eauto. }
    i; des_safe. folder. des.
    + esplits; eauto.
      * left. apply plus_one. split. { apply modsem_determinate; et. } eauto.
      * instantiate (1:= (SimMemExt.mk _ _)). ss. econs; ss; eauto.
    + clarify. esplits; eauto.
      * right. esplits; eauto. { apply star_refl. }
      * instantiate (1:= (SimMemExt.mk _ _)). ss.
Unshelve.
  all: ss. apply msp.
Qed.

End SIMMODSEM.

Section SIMMOD.

Variable prog tprog: RTL.program.
Hypothesis TRANSL: match_prog prog tprog.

Definition mp: ModPair.t := SimSymbId.mk_mp (RTLC.module prog) (RTLC.module tprog).

Theorem sim_mod: ModPair.sim mp.
Proof.
  econs; ss.
  - r. eapply Sk.match_program_eq; eauto.
    ii. destruct f1; ss.
    + clarify. right. esplits; eauto.
    + clarify. left. esplits; eauto.
  - ii. inv SIMSKENVLINK. eapply sim_modsem; eauto.
Qed.

End SIMMOD.


From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Import events model_lst
     model_update_prelude.

Section Lsec_udpate.
  Context `{!anerisG Mdl Σ, !DB_params}.

  Lemma update_condition_lsec_not_in e i t (s : gset apply_event) j :
    (i < length t) →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    update_condition i e t →
    e ∉ DBM_lsec j s.
  Proof.
    intros Hjt Hst Hcnd Habs.
    apply (update_condition_time _ _ _ Hcnd).
    apply in_lsec_in_lhst in Habs.
      by pose proof  update_condition_lhst_not_in e i t s Hjt Hst Hcnd.
  Qed.

  (* NB: The assumption
    "t !! (ae_orig e) = Some (length (elements (DBM_lsec (ae_orig e) s))) →"
    is important and can be derived either from
    Local state validity or from dynamic check)
 *)
  Lemma DBM_lsec_complete_update e i j t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    ae_seqid e = S (size s) →
    update_condition i e t →
    j < length DB_addresses →
    t !! (ae_orig e) = Some (length (elements (DBM_lsec (ae_orig e) s))) →
    DBM_lsec_complete j (s ∪ {[e]}).
  Proof.
    intros His Hs Hseq Hcnd Hj Hte.
    destruct (decide (j = e.(ae_orig))) as [ Heq | Hneq ]; last first.
    - intros k.
      rewrite !DBM_lsec_union !DBM_lsec_singleton_out; last lia.
      rewrite right_id_L.
      intros; eapply DBM_LSV_comp; first apply DBM_LHV_secs_valid; eauto.
    - intro k.
      rewrite !DBM_lsec_union !DBM_lsec_singleton_in; last done.
      pose proof Hcnd as
          (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
      destruct (lookup_lt_is_Some_2 (ae_time e) i) as [ti Hti];
        eauto with lia.
      rewrite (comm_L _ _ {[_]}) elements_union_singleton /=; last first.
      { eapply update_condition_lsec_not_in; eauto; lia. }
      pose proof (DBM_LHV_secs_valid His j Hj) as Hij.
      destruct (decide (k ≤ (length (elements (DBM_lsec j s))))).
      + intros [? ?].
        destruct (DBM_LSV_comp Hij k) as [x [Hx1 Hx2]]; first eauto with lia.
        set_solver.
      + intros [Hk1 Hk2].
         assert (k = S (length (elements (DBM_lsec j s))))
           as -> by by simpl in *; lia.
         exists e. split; first set_solver.
          subst j. by rewrite Het Hte.
  Qed.

  Lemma DBM_lsec_locally_causal_refl_update e i t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    ae_seqid e = S (size s) →
    update_condition i e t →
    (ae_orig e = i →
     ∀ j, j < length DB_addresses →
          t !! j = Some (length (elements (DBM_lsec j s)))) →
    DBM_lsec_locally_causal_refl i (s ∪ {[e]}).
  Proof.
    intros His Hs Hseq Hcnd Htj.
    intros j' ei Hj' Hij'
           [He'1 [He'2| ->%elem_of_singleton]%elem_of_union]%elem_of_filter.
    pose proof DBM_LHV_bound_at His as Hb.
    pose proof DBM_LHV_secs_valid His i Hb as Hsv.
    - (* i ≠ ae_orig e *)
      assert (ae_time ei !! j' = Some (DBM_lsec_latest_in_frame j' s ei)) as ->.
      { apply (DBM_LSV_caus_refl Hsv j' ei); eauto with lia.
        rewrite -He'1. by apply in_lsec_orig.  }
      rewrite /DBM_lsec_latest_in_frame. f_equal.
      apply nat_sup_equiv. intros k.
      rewrite !elem_of_list_omap.
      setoid_rewrite elem_of_list_filter.
      setoid_rewrite elem_of_elements.
      assert ( ae_seqid ei < ae_seqid e) as Hseqi.
      { pose proof DBM_LHV_seqids His ei He'2. lia. }
      split.
      + intros (x&[Hx1 Hxin]&Hx2).
        exists x; split_and!; [done| set_solver | done].
      + intros (x&[Hx1 Hxin]&Hx2).
            exists x; split_and!; [done|  | done].
            assert ( ae_seqid x < ae_seqid e) by lia.
            rewrite (DBM_lsec_union j' s {[e]})in Hxin.
            apply elem_of_union in Hxin as [Hx | Hx]; first done.
            rewrite /DBM_lsec in Hx.
            apply elem_of_filter in Hx as [? <-%elem_of_singleton].
            eauto with lia.
    - (* i = ae_orig e *)
      pose proof Hcnd as
          (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
      specialize (Het'' He'1).
      specialize (Htj He'1).
      assert (ae_time e !! j' = t !! j') as Hetj'.
      { rewrite Het''. eapply incr_time_proj_neq; lia. }
      rewrite (Htj j' Hj') in Hetj'.
      rewrite Hetj'. f_equal.
      rewrite (lsec_lsup_length i); eauto.
      rewrite /DBM_lsec_latest_in_frame /lsec_sup.
       apply nat_sup_equiv.
      intros k.
      rewrite !elem_of_list_omap.
      setoid_rewrite elem_of_list_filter.
      setoid_rewrite elem_of_elements.
      split.
      + intros (x&Hxin&Hx2).
        exists x; split_and!; [| set_solver | done].
        eapply in_lsec_in_lhst in Hxin.
        pose proof DBM_LHV_seqids His x Hxin. lia.
      + intros (x&[Hx1 Hxin]&Hx2).
        exists x; split_and!; [  | done].
        assert ( ae_seqid x < ae_seqid e) by lia.
        rewrite (DBM_lsec_union j' s {[e]})in Hxin.
        apply elem_of_union in Hxin as [Hx | Hx]; first done.
        rewrite /DBM_lsec in Hx.
        apply elem_of_filter in Hx as [? <-%elem_of_singleton].
        eauto with lia.
  Qed.

  Lemma DBM_lsec_locally_causal_update e i j t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    ae_seqid e = S (size s) →
    update_condition i e t →
    j < length DB_addresses →
    (ae_orig e = i →
     ∀ j, j < length DB_addresses →
          t !! j = Some (length (elements (DBM_lsec j s)))) →
    (∀ j, j < length DB_addresses →
          default O (t !! j) <= (length (elements (DBM_lsec j s)))) →
    DBM_lsec_locally_causal j (s ∪ {[e]}).
  Proof.
    intros His Hs Hseq Hcnd Hj Htj Htj2.
     pose proof Hcnd as
        (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
    destruct (decide (j = i)) as [->|].
    - assert (DBM_lsec_locally_causal_refl i (s ∪ {[e]})) as Hvlrefl.
      { eapply DBM_lsec_locally_causal_refl_update; eauto. }
      rewrite /DBM_lsec_locally_causal_refl in Hvlrefl.
      rewrite /DBM_lsec_locally_causal.
      intros j' x Hj' Hneq Hxin.
      destruct (lookup_lt_is_Some_2 (ae_time x) j') as [k Hk].
      {  rewrite DBM_lsec_union in Hxin.
         apply elem_of_union in Hxin as
             [[? Hx]%elem_of_filter |
              [? ->%elem_of_singleton ]%elem_of_filter].
         + pose proof DBM_LHV_times His x Hx. lia.
         + lia. }
      rewrite Hk.
      assert (ae_time x !! j' =
              Some (DBM_lsec_latest_in_frame j' (s ∪ {[e]}) x)) as Hx'.
        by eauto. rewrite -Hk Hx'. simpl. done.
    -  pose proof DBM_LHV_bound_at His as Hb.
       intros j' ei Hj' Hij'
              [He'1 [He'2| ->%elem_of_singleton]%elem_of_union]%elem_of_filter.
       + pose proof DBM_LHV_secs_valid His j Hj as Hvs.
         assert (from_option
                   (λ a : nat, a ≤ DBM_lsec_latest_in_frame j' s ei) False
                   (ae_time ei !! j')) as Hle.
         { apply (DBM_LSV_caus Hvs j' ei); eauto with lia.
           subst j. by apply in_lsec_orig. }
         destruct (lookup_lt_is_Some_2 (ae_time ei) j') as [k Hk].
          pose proof DBM_LHV_times His ei He'2. lia.
          rewrite Hk. rewrite Hk in Hle. simpl in *.
          trans (DBM_lsec_latest_in_frame j' s ei); first done.
          rewrite /DBM_lsec_latest_in_frame.
          apply nat_sup_mono.
         intros r Hr.
          rewrite !elem_of_list_omap.
          setoid_rewrite elem_of_list_filter.
          setoid_rewrite elem_of_elements.
          erewrite elem_of_list_omap in Hr.
          destruct Hr as (ej & Hej1 & Hej2).
          setoid_rewrite elem_of_list_filter in Hej1.
          destruct Hej1 as [? ?].
          exists ej. split_and!; [ |  | done]; eauto with lia.
          set_solver.
       +  assert (j' ≠ ae_orig e) as Hj'e by lia.
          specialize (Het' j' Hj' Hj'e).
          destruct (lookup_lt_is_Some_2 (ae_time e) j') as [k Hk];
            first eauto with lia.
          rewrite Hk in Het'. rewrite Hk. simpl in *.
          specialize (Htj2 j' Hj').
          trans (length (elements (DBM_lsec j' s))).
          * trans (default 0 (t !! j')); eauto with lia.
          *  erewrite (lsec_lsup_length i); eauto.
             rewrite /DBM_lsec_latest_in_frame /lsec_sup.
             apply nat_sup_mono.
             intros r Hr.
             rewrite !elem_of_list_omap.
             setoid_rewrite elem_of_list_filter.
             setoid_rewrite elem_of_elements.
             erewrite elem_of_list_omap in Hr.
             destruct Hr as (ej & Hej1 & Hej2).
             exists ej; split_and!; [| set_solver | done].
             rewrite /DBM_lsec in Hej1.
             erewrite elem_of_elements in Hej1.
             apply elem_of_filter in Hej1 as [? Hej1].
             pose proof DBM_LHV_seqids His ej Hej1.
             rewrite Hseq. by apply le_lt_n_Sm.
  Qed.

  Lemma DBM_lhst_lsec_update e i t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    e.(ae_seqid) = (S (size s)) →
    update_condition i e t →
    t !! ae_orig e = Some (length (elements (DBM_lsec (ae_orig e) s))) →
    (ae_orig e = i
     → ∀ j, j < strings.length DB_addresses
            → t !! j = Some (length (elements (DBM_lsec j s)))) →
     (∀ j, j < length DB_addresses →
          default O (t !! j) <= (length (elements (DBM_lsec j s)))) →
    DBM_lhst_lsec_valid i (s ∪ {[ e ]}).
  Proof.
    intros.
    split.
    - eapply DBM_LHV_bound_at; eauto.
    - done.
    - eapply DBM_lsec_complete_update; eauto.
    - eapply DBM_lsec_locally_causal_refl_update; eauto.
    - eapply DBM_lsec_locally_causal_update; eauto.
  Qed.

End Lsec_udpate.


Require Import compcert.lib.Axioms.

Require Import concurrency.sepcomp. Import SepComp.
Require Import sepcomp.semantics_lemmas.

Require Import concurrency.pos.
Require Import concurrency.scheduler.
Require Import concurrency.TheSchedule.
Require Import concurrency.concurrent_machine.
Require Import concurrency.addressFiniteMap. (*The finite maps*)
Require Import concurrency.pos.
Require Import concurrency.lksize.
Require Import concurrency.permjoin_def.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

(*NOTE: because of redefinition of [val], these imports must appear
  after Ssreflect eqtype.*)
Require Import compcert.common.AST.     (*for typ*)
Require Import compcert.common.Values. (*for val*)
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.lib.Integers.
Require Import concurrency.threads_lemmas.
Require Import concurrency.semantics.
Require Import concurrency.TheSchedule. Import TheSchedule.

Require Import Coq.ZArith.ZArith.

Require Import concurrency.permissions.
Require Import concurrency.bounded_maps.
Require Import concurrency.threadPool.

Module LocksAndResources.
  (** Dry resources are a permission map for non-lock locations and one for lock
  locations*)
  Definition res := (access_map * access_map)%type.
  Definition lock_info := (access_map * access_map)%type.
End LocksAndResources.

Module ThreadPool (SEM:Semantics)  <: ThreadPoolSig
    with Module TID:= NatTID with Module SEM:=SEM
    with Module RES := LocksAndResources.

    Include (OrdinalPool SEM LocksAndResources).

End ThreadPool.

Module Concur.

  Module mySchedule := THESCH.

  (** The type of dry machines. This is basically the same as
  [ConcurrentMachineSig] but resources are instantiated with dry
  resources*)
  Module Type DryMachineSig  (SEM: Semantics) <: ConcurrentMachineSig
      with Module ThreadPool.RES:= LocksAndResources
      with Module ThreadPool.TID:=mySchedule.TID.

     Declare Module Events : EventSig.
     Module ThreadPool := ThreadPool SEM.
     Import ThreadPool SEM.
     Import event_semantics Events.

     (** Memories*)
     Definition richMem: Type:= mem.
     Definition dryMem: richMem -> mem:= id.
     Definition diluteMem: mem -> mem := setMaxPerm.

     Notation thread_pool := (ThreadPool.t).

     (** The state respects the memory*)
     Record mem_compatible' tp m : Prop :=
       { compat_th :> forall {tid} (cnt: containsThread tp tid),
             permMapLt (getThreadR cnt).1 (getMaxPerm m) /\
             permMapLt (getThreadR cnt).2 (getMaxPerm m);
         compat_lp : forall l pmaps, lockRes tp l = Some pmaps ->
                                permMapLt pmaps.1 (getMaxPerm m) /\
                                permMapLt pmaps.2 (getMaxPerm m);
         lockRes_blocks: forall l rmap, lockRes tp l = Some rmap ->
                                   Mem.valid_block m l.1}.

     Definition mem_compatible tp m : Prop := mem_compatible' tp m.

     Record invariant' tp :=
       { no_race_thr :
           forall i j (cnti: containsThread tp i) (cntj: containsThread tp j)
             (Hneq: i <> j),
             permMapsDisjoint2 (getThreadR cnti)
                              (getThreadR cntj); (*thread's resources are disjoint *)
         no_race_lr:
           forall laddr1 laddr2 rmap1 rmap2
             (Hneq: laddr1 <> laddr2)
             (Hres1: lockRes tp laddr1 = Some rmap1)
             (Hres2: lockRes tp laddr2 = Some rmap2),
             permMapsDisjoint2 rmap1 rmap2; (*lock's resources are disjoint *)
         no_race:
           forall i laddr (cnti: containsThread tp i) rmap
             (Hres: lockRes tp laddr = Some rmap),
             permMapsDisjoint2 (getThreadR cnti) rmap; (*resources are disjoint
             between threads and locks*)
         (* an address is in the lockres if there is at least one >= Readable
         lock permission - I am writing the weak version where this is required
         only for permissions of threads*)
         (* lock_res_perm: *)
         (*   forall b ofs, *)
         (*     (exists i (cnti: containsThread tp i), *)
         (*         Mem.perm_order' ((getThreadR cnti).2 !! b ofs) Readable) ->  *)
         (*     lockRes tp (b, ofs); *)

         (* if an address is a lock then there can be no data
             permission above non-empty for this address*)
         thread_data_lock_coh:
           forall i (cnti: containsThread tp i),
             (forall j (cntj: containsThread tp j),
                permMapCoherence (getThreadR cntj).1 (getThreadR cnti).2) /\
             (forall laddr rmap,
                 lockRes tp laddr = Some rmap ->
                 permMapCoherence rmap.1 (getThreadR cnti).2);
         locks_data_lock_coh:
           forall laddr rmap
             (Hres: lockRes tp laddr = Some rmap),
             (forall j (cntj: containsThread tp j),
                 permMapCoherence (getThreadR cntj).1 rmap.2) /\
             (forall laddr' rmap',
                 lockRes tp laddr' = Some rmap' ->
                 permMapCoherence rmap'.1 rmap.2);
         lockRes_valid: lr_valid (lockRes tp) (*well-formed locks*)
       }.

     Definition invariant := invariant'.
     Parameter threadStep :
       G ->
       forall tid0 (ms : t) (m : mem),
         containsThread ms tid0 ->
         mem_compatible ms m -> t -> mem -> seq mem_event -> Prop.

     Axiom threadStep_equal_run:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g 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').
     Parameter syncStep :
       bool -> (* if it's a Coarse machine. Temp solution to propagating changes. *)
       G ->
       forall tid0 (ms : t) (m : mem),
         containsThread ms tid0 ->
         mem_compatible ms m -> t -> mem -> sync_event -> Prop.

  Axiom syncstep_equal_run:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g 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').

  Axiom syncstep_not_running:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g i tp m cnt cmpt tp' m' tr ->
      forall cntj q, ~ @getThreadC i tp cntj = Krun q.

     Parameter threadHalted :
       forall tid0 (ms : t), containsThread ms tid0 -> Prop.
     Parameter init_mach : option RES.res -> G -> val -> seq val -> option t.

  Axiom threadHalt_update:
    forall i j, i <> j ->
      forall tp cnt cnti c' cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j (@updThreadC i tp cnti c') cnt') .

  Axiom syncstep_equal_halted:
    forall b g i tp m cnti cmpt tp' m' tr,
      @syncStep b g i tp m cnti cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j tp' cnt').

  Axiom threadStep_not_unhalts:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g i tp m cnt cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) ->
        (@threadHalted j tp' cnt') .

  End DryMachineSig.

  Module DryMachineShell (SEM:Semantics)  <: DryMachineSig SEM.

     Module Events := Events.
     Module ThreadPool := ThreadPool SEM.
     Import ThreadPool.
     Import ThreadPool.SEM ThreadPool.RES.
     Import event_semantics Events.

     Notation tid := NatTID.tid.

     (** Memories*)
     Definition richMem: Type:= mem.
     Definition dryMem: richMem -> mem:= id.
     Definition diluteMem: mem -> mem := setMaxPerm.

     Notation thread_pool := (ThreadPool.t).

     (** The state respects the memory*)

     Record mem_compatible' tp m : Prop :=
       { compat_th :> forall {tid} (cnt: containsThread tp tid),
             permMapLt (getThreadR cnt).1 (getMaxPerm m) /\
             permMapLt (getThreadR cnt).2 (getMaxPerm m);
         compat_lp : forall l pmaps, lockRes tp l = Some pmaps ->
                                permMapLt pmaps.1 (getMaxPerm m) /\
                                permMapLt pmaps.2 (getMaxPerm m);
         lockRes_blocks: forall l rmap, lockRes tp l = Some rmap ->
                                   Mem.valid_block m l.1}.

     Definition mem_compatible tp m : Prop := mem_compatible' tp m.

     (* should there be something that says that if something is a lock then
     someone has at least readable permission on it?*)
     Record invariant' tp :=
       { no_race_thr :
           forall i j (cnti: containsThread tp i) (cntj: containsThread tp j)
             (Hneq: i <> j),
             permMapsDisjoint2 (getThreadR cnti)
                              (getThreadR cntj); (*thread's resources are disjoint *)
         no_race_lr:
           forall laddr1 laddr2 rmap1 rmap2
             (Hneq: laddr1 <> laddr2)
             (Hres1: lockRes tp laddr1 = Some rmap1)
             (Hres2: lockRes tp laddr2 = Some rmap2),
             permMapsDisjoint2 rmap1 rmap2; (*lock's resources are disjoint *)
         no_race:
           forall i laddr (cnti: containsThread tp i) rmap
             (Hres: lockRes tp laddr = Some rmap),
             permMapsDisjoint2 (getThreadR cnti) rmap; (*resources are disjoint
             between threads and locks*)
         (* an address is in the lockres if there is at least one >= Readable
         lock permission - I am writing the weak version where this is required
         only for permissions of threads*)
         (* lock_res_perm: *)
         (*   forall b ofs, *)
         (*     (exists i (cnti: containsThread tp i), *)
         (*         Mem.perm_order' ((getThreadR cnti).2 !! b ofs) Readable) ->  *)
         (*     lockRes tp (b, ofs); *)

         (* if an address is a lock then there can be no data
             permission above non-empty for this address*)
         thread_data_lock_coh:
           forall i (cnti: containsThread tp i),
             (forall j (cntj: containsThread tp j),
                permMapCoherence (getThreadR cntj).1 (getThreadR cnti).2) /\
             (forall laddr rmap,
                 lockRes tp laddr = Some rmap ->
                 permMapCoherence rmap.1 (getThreadR cnti).2);
         locks_data_lock_coh:
           forall laddr rmap
             (Hres: lockRes tp laddr = Some rmap),
             (forall j (cntj: containsThread tp j),
                 permMapCoherence (getThreadR cntj).1 rmap.2) /\
             (forall laddr' rmap',
                 lockRes tp laddr' = Some rmap' ->
                 permMapCoherence rmap'.1 rmap.2);
         lockRes_valid: lr_valid (lockRes tp) (*well-formed locks*)
       }.
     Definition invariant := invariant'.

     (** Steps*)
     Inductive dry_step genv {tid0 tp m} (cnt: containsThread tp tid0)
               (Hcompatible: mem_compatible tp m) :
       thread_pool -> mem -> seq mem_event -> Prop :=
     | step_dry :
         forall (tp':thread_pool) c m1 m' (c' : code) ev
           (** Instal the permission's of the thread on non-lock locations*)
           (Hrestrict_pmap: restrPermMap (Hcompatible tid0 cnt).1 = m1)
           (Hinv: invariant tp)
           (Hcode: getThreadC cnt = Krun c)
           (Hcorestep: ev_step Sem genv c m1 ev c' m')
           (** the new data resources of the thread are the ones on the
           memory, the lock ones are unchanged by internal steps*)
           (Htp': tp' = updThread cnt (Krun c') (getCurPerm m', (getThreadR cnt).2)),
           dry_step genv cnt Hcompatible tp' m' ev.

     Definition option_function {A B} (opt_f: option (A -> B)) (x:A): option B:=
       match opt_f with
         Some f => Some (f x)
       | None => None
       end.
     Infix "??" := option_function (at level 80, right associativity).

     Inductive ext_step {isCoarse:bool} (genv:G) {tid0 tp m}
               (cnt0:containsThread tp tid0)(Hcompat:mem_compatible tp m):
       thread_pool -> mem -> sync_event -> Prop :=
     | step_acquire :
         forall (tp' tp'':thread_pool) m0 m1 c m' b ofs
           (pmap : LocksAndResources.lock_info)
           (pmap_tid' : access_map)
           (virtueThread : delta_map * delta_map)
           (Hbounded: if isCoarse then
                        ( sub_map virtueThread.1 (getMaxPerm m).2 /\
                          sub_map virtueThread.2 (getMaxPerm m).2)
                      else
                        True ),
           let newThreadPerm := (computeMap (getThreadR cnt0).1 virtueThread.1,
                                  computeMap (getThreadR cnt0).2 virtueThread.2) in
           forall
             (Hinv : invariant tp)
             (Hcode: getThreadC cnt0 = Kblocked c)
             (Hat_external: at_external Sem c = Some (LOCK, Vptr b ofs::nil))
             (** install the thread's permissions on lock locations*)
             (Hrestrict_pmap0: restrPermMap (Hcompat tid0 cnt0).2 = m0)
             (** check if the thread has permission to acquire the lock and the lock is free*)
             (Hload: Mem.load Mint32 m0 b (Int.intval ofs) = Some (Vint Int.one))
             (** set the permissions on the lock location equal to the max permissions on the memory*)
             (Hset_perm: setPermBlock (Some Writable)
                                       b (Int.intval ofs) ((getThreadR cnt0).2) LKSIZE_nat = pmap_tid')
             (Hlt': permMapLt pmap_tid' (getMaxPerm m))
             (Hrestrict_pmap: restrPermMap Hlt' = m1)
             (** acquire the lock*)
             (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
             (HisLock: lockRes tp (b, Int.intval ofs) = Some pmap)
             (Hangel1: permMapJoin pmap.1 (getThreadR cnt0).1 newThreadPerm.1)
             (Hangel2: permMapJoin pmap.2 (getThreadR cnt0).2 newThreadPerm.2)
             (Htp': tp' = updThread cnt0 (Kresume c Vundef) newThreadPerm)
             (** acquiring the lock leaves empty permissions at the resource pool*)
             (Htp'': tp'' = updLockSet tp' (b, Int.intval ofs) (empty_map, empty_map)),
             ext_step genv cnt0 Hcompat tp'' m'
                      (acquire (b, Int.intval ofs)
                               (Some virtueThread))

     | step_release :
         forall (tp' tp'':thread_pool) m0 m1 c m' b ofs virtueThread virtueLP pmap_tid' rmap
           (Hbounded: if isCoarse then
                        ( sub_map virtueThread.1 (getMaxPerm m).2 /\
                          sub_map virtueThread.2 (getMaxPerm m).2)
                      else
                        True )
           (HboundedLP: if isCoarse then
                        ( map_empty_def virtueLP.1 /\
                          map_empty_def virtueLP.2 /\
                          sub_map virtueLP.1.2 (getMaxPerm m).2 /\
                          sub_map virtueLP.2.2 (getMaxPerm m).2)
                      else
                        True ),
           let newThreadPerm := (computeMap (getThreadR cnt0).1 virtueThread.1,
                                 computeMap (getThreadR cnt0).2 virtueThread.2) in
           forall
             (Hinv : invariant tp)
             (Hcode: getThreadC cnt0 = Kblocked c)
             (Hat_external: at_external Sem c =
                            Some (UNLOCK, Vptr b ofs::nil))
             (** install the thread's permissions on lock locations *)
             (Hrestrict_pmap0: restrPermMap (Hcompat tid0 cnt0).2 = m0)
             (Hload: Mem.load Mint32 m0 b (Int.intval ofs) = Some (Vint Int.zero))
             (** set the permissions on the lock location equal to the max permissions on the memory*)
             (Hset_perm: setPermBlock (Some Writable)
                                      b (Int.intval ofs) ((getThreadR cnt0).2) LKSIZE_nat = pmap_tid')
             (Hlt': permMapLt pmap_tid' (getMaxPerm m))
             (Hrestrict_pmap: restrPermMap Hlt' = m1)
             (** release the lock *)
             (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.one) = Some m')
             (HisLock: lockRes tp (b, Int.intval ofs) = Some rmap)
             (** And the lock is taken*)
             (Hrmap: forall b ofs, rmap.1 !! b ofs = None /\ rmap.2 !! b ofs = None)
             (Hangel1: permMapJoin newThreadPerm.1 virtueLP.1 (getThreadR cnt0).1)
             (Hangel2: permMapJoin newThreadPerm.2 virtueLP.2 (getThreadR cnt0).2)
             (Htp': tp' = updThread cnt0 (Kresume c Vundef)
                                    (computeMap (getThreadR cnt0).1 virtueThread.1,
                                     computeMap (getThreadR cnt0).2 virtueThread.2))
             (Htp'': tp'' = updLockSet tp' (b, Int.intval ofs) virtueLP),
             ext_step genv cnt0 Hcompat tp'' m'
                      (release (b, Int.intval ofs)
                               (Some virtueLP))
     | step_create :
         forall (tp_upd tp':thread_pool) c b ofs arg virtue1 virtue2
           (Hbounded: if isCoarse then
                        ( sub_map virtue1.1 (getMaxPerm m).2 /\
                          sub_map virtue1.2 (getMaxPerm m).2)
                      else
                        True )
             (Hbounded_new: if isCoarse then
                        ( sub_map virtue2.1 (getMaxPerm m).2 /\
                          sub_map virtue2.2 (getMaxPerm m).2)
                      else
                        True ),
           let threadPerm' := (computeMap (getThreadR cnt0).1 virtue1.1,
                               computeMap (getThreadR cnt0).2 virtue1.2) in
           let newThreadPerm := (computeMap empty_map virtue2.1,
                                 computeMap empty_map virtue2.2) in
           forall
           (Hinv : invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (Hat_external: at_external Sem c = Some (CREATE, Vptr b ofs::arg::nil))
           (** we do not need to enforce the almost empty predicate on thread
           spawn as long as it's considered a synchronizing operation *)
           (Hangel1: permMapJoin newThreadPerm.1 threadPerm'.1 (getThreadR cnt0).1)
           (Hangel2: permMapJoin newThreadPerm.2 threadPerm'.2 (getThreadR cnt0).2)
           (Htp_upd: tp_upd = updThread cnt0 (Kresume c Vundef) threadPerm')
           (Htp': tp' = addThread tp_upd (Vptr b ofs) arg newThreadPerm),
             ext_step genv cnt0 Hcompat tp' m
                      (spawn (b, Int.intval ofs)
                             (Some (getThreadR cnt0, virtue1)) (Some virtue2))

     | step_mklock :
         forall  (tp' tp'': thread_pool) m1 c m' b ofs pmap_tid',
           let: pmap_tid := getThreadR cnt0 in
           forall
             (Hinv : invariant tp)
             (Hcode: getThreadC cnt0 = Kblocked c)
             (Hat_external: at_external Sem c = Some (MKLOCK, Vptr b ofs::nil))
             (** install the thread's data permissions*)
             (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).1 = m1)
             (** lock is created in acquired state*)
             (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
             (** The thread's data permissions are set to Nonempty*)
             (Hdata_perm: setPermBlock
                            (Some Nonempty)
                            b
                            (Int.intval ofs)
                            pmap_tid.1
                            LKSIZE_nat = pmap_tid'.1)
             (** thread lock permission is increased *)
             (Hlock_perm: setPermBlock
                            (Some Writable)
                            b
                            (Int.intval ofs)
                            pmap_tid.2
                            LKSIZE_nat = pmap_tid'.2)
             (** Require that [(b, Int.intval ofs)] was not a lock*)
             (HlockRes: lockRes tp (b, Int.intval ofs) = None)
             (Htp': tp' = updThread cnt0 (Kresume c Vundef) pmap_tid')
             (** the lock has no resources initially *)
             (Htp'': tp'' = updLockSet tp' (b, Int.intval ofs) (empty_map, empty_map)),
             ext_step genv cnt0 Hcompat tp'' m' (mklock (b, Int.intval ofs))

     | step_freelock :
         forall  (tp' tp'': thread_pool) c b ofs pmap_tid' m1 pdata rmap
           (Hbounded: if isCoarse then
                        ( bounded_maps.bounded_nat_func' pdata LKSIZE_nat)
                      else
                        True ),
             let: pmap_tid := getThreadR cnt0 in
           forall
           (Hinv: invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (Hat_external: at_external Sem c = Some (FREE_LOCK, Vptr b ofs::nil))
           (** If this address is a lock*)
           (His_lock: lockRes tp (b, (Int.intval ofs)) = Some rmap)
           (** And the lock is taken *)
           (Hrmap: forall b ofs, rmap.1 !! b ofs = None /\ rmap.2 !! b ofs = None)
           (** Install the thread's lock permissions*)
           (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).2 = m1)
           (** To free the lock the thread must have at least Writable on it*)
           (Hfreeable: Mem.range_perm m1 b (Int.intval ofs) ((Int.intval ofs) + LKSIZE) Cur Writable)
           (** lock permissions of the thread are dropped to empty *)
           (Hlock_perm: setPermBlock
                          None
                          b
                          (Int.intval ofs)
                          pmap_tid.2
                          LKSIZE_nat = pmap_tid'.2)
           (** data permissions are computed in a non-deterministic way *)
           (Hneq_perms: forall i,
                 (0 <= Z.of_nat i < LKSIZE)%Z ->
                 Mem.perm_order'' (pdata (S i)) (Some Writable)
           )
           (*Hpdata: perm_order pdata Writable*)
           (Hdata_perm: setPermBlock_var (*=setPermBlockfunc*)
                          pdata
                          b
                          (Int.intval ofs)
                          pmap_tid.1
                          LKSIZE_nat = pmap_tid'.1)
           (Htp': tp' = updThread cnt0 (Kresume c Vundef) pmap_tid')
           (Htp'': tp'' = remLockSet tp' (b, Int.intval ofs)),
           ext_step genv cnt0 Hcompat  tp'' m (freelock (b, Int.intval ofs))
     | step_acqfail :
         forall  c b ofs m1
           (Hinv : invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (Hat_external: at_external Sem c = Some (LOCK, Vptr b ofs::nil))
           (** Install the thread's lock permissions*)
           (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).2 = m1)
           (** Lock is already acquired.*)
           (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.zero)),
           ext_step genv cnt0 Hcompat tp m (failacq (b, Int.intval ofs)).

     Definition threadStep (genv : G): forall {tid0 ms m},
         containsThread ms tid0 -> mem_compatible ms m ->
         thread_pool -> mem -> seq mem_event -> Prop:=
       @dry_step genv.

     Lemma threadStep_equal_run:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g 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').
    Proof.
      intros. split.
      - intros [cntj [ q running]].
        inversion H; subst.
        assert (cntj':=cntj).
        eapply (cntUpdate (Krun c') (getCurPerm m', (getThreadR cnt)#2) cntj) in cntj'.
        exists cntj'.
        destruct (NatTID.eq_tid_dec i j).
        + subst j; exists c'.
          rewrite gssThreadCode; reflexivity.
        + exists q.
          rewrite gsoThreadCode; auto.
      - intros [cntj' [ q' running]].
        inversion H; subst.
        assert (cntj:=cntj').
        eapply cntUpdate' with(c0:=Krun c')(p:=(getCurPerm m', (getThreadR cnt)#2)) in cntj; eauto.
        exists cntj.
        destruct (NatTID.eq_tid_dec i j).
        + subst j; exists c.
          rewrite <- Hcode.
          f_equal.
          apply cnt_irr.
        + exists q'.
          rewrite gsoThreadCode in running; auto.
    Qed.

     Definition syncStep (isCoarse:bool) (genv :G) :
       forall {tid0 ms m},
         containsThread ms tid0 -> mem_compatible ms m ->
         thread_pool -> mem -> sync_event -> Prop:=
       @ext_step isCoarse genv.

  Lemma syncstep_equal_run:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g 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').
  Proof.
    intros b g i tp m cnt cmpt tp' m' tr H j; split.
    - intros [cntj [ q running]].
      destruct (NatTID.eq_tid_dec i j).
      + subst j. generalize running; clear running.
        inversion H; subst;
          match goal with
          | [ H: getThreadC ?cnt = Kblocked ?c |- _ ] =>
            replace cnt with cntj in H by apply cnt_irr;
              intros HH; rewrite HH in H; inversion H
          end.
      + (*this should be easy to automate or shorten*)
        inversion H; subst.
        * exists (cntUpdateL _ _
                        (cntUpdate (Kresume c Vundef)
                                   newThreadPerm
                                   _ cntj)), q.
          rewrite gLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists ( (cntUpdateL _ _
                          (cntUpdate (Kresume c Vundef)
                                     (computeMap (getThreadR cnt)#1 virtueThread#1,
                                      computeMap (getThreadR cnt)#2 virtueThread#2)
                                     _ cntj))), q.
          rewrite gLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists (cntAdd _ _ _
                    (cntUpdate (Kresume c Vundef)
                               threadPerm'
                               _ cntj)), q.
          erewrite gsoAddCode . (*i? *)
          rewrite gsoThreadCode; assumption.
          eapply cntUpdate. eauto.
        * exists ( (cntUpdateL _ _
                          (cntUpdate (Kresume c Vundef)
                                     pmap_tid'
                                     _ cntj))), q.
          rewrite gLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists ( (cntRemoveL _
                          (cntUpdate (Kresume c Vundef)
                                     pmap_tid'
                                     _ cntj))), q.
          rewrite gRemLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists cntj, q; assumption.
    - intros [cntj [ q running]].
      destruct (NatTID.eq_tid_dec i j).
      + subst j. generalize running; clear running.
        inversion H; subst;
          try rewrite gLockSetCode;
          try rewrite gRemLockSetCode;
          try rewrite gssThreadCode;
          try solve[intros HH; inversion HH].
        { (*addthread*)
          assert (cntj':=cntj).
          eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH].
          * erewrite gsoAddCode; eauto.
            subst; rewrite gssThreadCode; intros AA; inversion AA.
          * erewrite gssAddCode . intros AA; inversion AA.
            assumption. }
          { (*AQCUIRE*)
            replace cntj with cnt by apply cnt_irr.
            rewrite Hcode; intros HH; inversion HH. }
      + generalize running; clear running.
        inversion H; subst;
        try erewrite <- age_getThreadCode;
          try rewrite gLockSetCode;
          try rewrite gRemLockSetCode;
          try (rewrite gsoThreadCode; [|auto]);
        try (intros HH;
        match goal with
        | [ H: getThreadC ?cnt = Krun ?c |- _ ] =>
          exists cntj, c; exact H
        end).
      (*Add thread case*)
        assert (cntj':=cntj).
        eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH].
        * erewrite gsoAddCode; eauto.
          destruct (NatTID.eq_tid_dec i j);
            [subst; rewrite gssThreadCode; intros AA; inversion AA|].
          rewrite gsoThreadCode; auto.
          exists HH, q; assumption.
        * erewrite gssAddCode . intros AA; inversion AA.
          assumption.

          Grab Existential Variables.
          eauto. eauto. eauto.
  Qed.

  Lemma syncstep_not_running:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g i tp m cnt cmpt tp' m' tr ->
      forall cntj q, ~ @getThreadC i tp cntj = Krun q.
  Proof.
    intros.
    inversion H;
      match goal with
      | [ H: getThreadC ?cnt = _ |- _ ] =>
        erewrite (cnt_irr _ cnt);
          rewrite H; intros AA; inversion AA
      end.
  Qed.

     Inductive threadHalted': forall {tid0 ms},
         containsThread ms tid0 -> Prop:=
     | thread_halted':
         forall tp c tid0
           (cnt: containsThread tp tid0)
           (*Hinv: invariant tp*)
           (Hcode: getThreadC cnt = Krun c)
           (Hcant: halted Sem c),
           threadHalted' cnt.

    Definition threadHalted: forall {tid0 ms},
         containsThread ms tid0 -> Prop:= @threadHalted'.

   (* Lemma updCinvariant': forall {tid} ds c (cnt: containsThread ds tid),
         invariant (updThreadC cnt c) <-> invariant ds.
           split.
           { intros INV; inversion INV.
             constructor.
             - generalize no_race; unfold race_free.
               simpl. intros.
               apply no_race0; auto.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption. }

           { intros INV; inversion INV.
             constructor.
             - generalize no_race; unfold race_free.
               simpl. intros.
               apply no_race0; auto.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption. }
     Qed. *)

  Lemma threadHalt_update:
    forall i j, i <> j ->
      forall tp cnt cnti c' cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j (@updThreadC i tp cnti c') cnt') .
  Proof.
    intros; split; intros HH; inversion HH; subst;
    econstructor; eauto.
    erewrite <- (gsoThreadCC H); exact Hcode.
    erewrite (gsoThreadCC H); exact Hcode.
  Qed.

     Definition one_pos : pos := mkPos NPeano.Nat.lt_0_1.

     Definition initial_machine pmap c :=
       ThreadPool.mk
         one_pos
         (fun _ =>  Krun c)
         (fun _ => (pmap, empty_map)) (*initially there are no locks*)
         empty_lset.

     Definition init_mach (pmap : option RES.res) (genv:G)
                (v:val)(args:list val):option thread_pool :=
       match initial_core Sem genv v args with
       | Some c =>
         match pmap with
         | Some pmap => Some (initial_machine pmap.1 c)
         | None => None
         end
       | None => None
       end.

     Module DryMachineLemmas.

       (*TODO: This lemma should probably be moved. *)
       Lemma threads_canonical:
         forall ds m i (cnt:ThreadPool.containsThread ds i),
           mem_compatible ds m ->
           isCanonical (ThreadPool.getThreadR cnt).1 /\
           isCanonical (ThreadPool.getThreadR cnt).2.
             intros.
             destruct (compat_th H cnt);
               eauto using canonical_lt.
       Qed.
       (** most of these lemmas are in DryMachinLemmas*)

       (** *Invariant Lemmas*)

       (** ** Updating the machine state**)
        (* Manny invaraint lemmas were removed from here. *)
     End DryMachineLemmas.

    (** *More Properties of halted thread*)
      Lemma threadStep_not_unhalts:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g i tp m cnt cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) ->
        (@threadHalted j tp' cnt') .
  Proof.
    intros; inversion H; inversion H0; subst.
    destruct (NatTID.eq_tid_dec i j).
    - subst j. simpl in Hcorestep.
      eapply ev_step_ax1 in Hcorestep.
      eapply corestep_not_halted in Hcorestep.
      replace cnt1 with cnt in Hcode0 by apply cnt_irr.
      rewrite Hcode0 in Hcode; inversion Hcode;
      subst c0.
      rewrite Hcorestep in Hcant; inversion Hcant.
    - econstructor; eauto.
      rewrite gsoThreadCode; auto;
      erewrite <- age_getThreadCode; eauto.
  Qed.

  Lemma syncstep_equal_halted:
    forall b g i tp m cnti cmpt tp' m' tr,
      @syncStep b g i tp m cnti cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j tp' cnt').
  Proof.
    intros; split; intros HH; inversion HH; subst;
    econstructor; subst; eauto.
    - destruct (NatTID.eq_tid_dec i j).
      + subst j.
        inversion H;
          match goal with
          | [ H: getThreadC ?cnt = Krun ?c,
                 H': getThreadC ?cnt' = Kblocked ?c' |- _ ] =>
            replace cnt with cnt' in H by apply cnt_irr;
              rewrite H' in H; inversion H
          end.
      + inversion H; subst;
        try erewrite <- age_getThreadCode;
          try rewrite gLockSetCode;
          try rewrite gRemLockSetCode;
          try erewrite gsoAddCode; eauto;
          try rewrite gsoThreadCode; try eassumption.
        { (*AQCUIRE*)
            replace cnt' with cnt0 by apply cnt_irr;
          exact Hcode. }
    - destruct (NatTID.eq_tid_dec i j).
      + subst j.
        inversion H; subst;
        match goal with
          | [ H: getThreadC ?cnt = Krun ?c,
                 H': getThreadC ?cnt' = Kblocked ?c' |- _ ] =>
            try erewrite <- age_getThreadCode in H;
              try rewrite gLockSetCode in H;
              try rewrite gRemLockSetCode in H;
              try erewrite gsoAddCode in H; eauto;
              try rewrite gssThreadCode in H;
              try solve[inversion H]
        end.
        { (*AQCUIRE*)
            replace cnt with cnt0 by apply cnt_irr;
          exact Hcode. }
      +
        inversion H; subst;
        match goal with
          | [ H: getThreadC ?cnt = Krun ?c,
                 H': getThreadC ?cnt' = Kblocked ?c' |- _ ] =>
            try erewrite <- age_getThreadCode in H;
              try rewrite gLockSetCode in H;
              try rewrite gRemLockSetCode in H;
              try erewrite gsoAddCode in H; eauto;
              try rewrite gsoThreadCode in H;
              try solve[inversion H]; eauto
        end.
        { (*AQCUIRE*)
            replace cnt with cnt0 by apply cnt_irr;
          exact Hcode. }

        Grab Existential Variables.
        eauto. eauto. eauto.
  Qed.

  End DryMachineShell.

End Concur.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for PowerPC *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition ptr64 := false.

Definition big_endian := true.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

Definition splitlong := true.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  unfold splitlong, ptr64; congruence.
Qed.

Program Definition default_pl_64 : bool * nan_pl 53 :=
  (false, iter_nat 51 _ xO xH).

Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  false.                        (**r always choose first NaN *)

Program Definition default_pl_32 : bool * nan_pl 24 :=
  (false, iter_nat 22 _ xO xH).

Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
  false.                        (**r always choose first NaN *)

Definition float_of_single_preserves_sNaN := true.

Global Opaque ptr64 big_endian splitlong
              default_pl_64 choose_binop_pl_64
              default_pl_32 choose_binop_pl_32
              float_of_single_preserves_sNaN.

(** Can we use the 64-bit extensions to the PowerPC architecture? *)
Parameter ppc64: bool.


Require Import Program.

Require Import Sem SimProg Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem Sound SimSymb.
Require Import Cop Ctypes ClightC.
Require Import AsmC.
Require SimMemInjInvC SimSymbDropInv.
Require Import CoqlibC.
Require Import ValuesC.
Require Import LinkingC.
Require Import MapsC.
Require Import AxiomsC.
Require Import Ord.
Require Import MemoryC.
Require Import SmallstepC.
Require Import Events.
Require Import Preservation.
Require Import Integers.
Require Import LocationsC Conventions.
Require Import Conventions1C.

Require Import AsmregsC.
Require Import MatchSimModSem.
Require Import StoreArguments StoreArgumentsProps.
Require Import AsmStepInj IntegersC.
Require Import Coq.Logic.PropExtensionality.
Require Import CtypingC.
Require Import CopC.

Require Import MatchSimModSem.
Require Import Conventions1C.

Require Import ClightStepInj.
Require Import IdSimExtra IdSimInvExtra IdSimClightExtra.
Require Import mktac.

Set Implicit Arguments.

Local Opaque Z.mul Z.add Z.sub Z.div.

Section INJINV.

Local Existing Instance SimSymbDropInv.SimMemInvTop.
Local Existing Instance SimSymbDropInv.SimSymbDropInv.
Local Existing Instance SoundTop.Top.

Inductive match_states_clight_inv
  : unit -> Clight.state -> Clight.state -> SimMem.t -> Prop :=
| match_states_clight_inv_intro
    st_src st_tgt j m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMem.src))
    (MWFTGT: m_tgt = sm0.(SimMem.tgt))
    (MWFINJ: j = sm0.(SimMemInjInv.minj).(SimMemInj.inj))
    (MATCHST: match_states_clight_internal st_src st_tgt j m_src m_tgt)
    (MWF: SimMem.wf sm0)
  :
    match_states_clight_inv
      tt st_src st_tgt sm0
.

Lemma clight_inj_inv_drop
      (clight: Clight.program)
      (WF: Sk.wf (module2 clight))
  :
    exists mp,
      (<<SIM: ModPair.sim mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (module2 clight)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (module2 clight)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto. instantiate (1:=SimSymbDropInv.mk bot1 _ _).
  econs; ss; i.
  { econs; ss; i; clarify.
    inv WF. auto. }
  eapply match_states_sim with (match_states := match_states_clight_inv); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - i. ss. exploit SimSymbDropInv_match_globals.
    { inv SIMSKENV. ss. eauto. } intros GEMATCH.
    inv INITTGT. inv SAFESRC. inv SIMARGS. inv H. ss.
    exploit match_globals_find_funct; eauto.
    i. clarify.
    esplits; eauto.
    + econs; eauto.
    + refl.
    + econs; eauto. econs; eauto.
      { inv TYP. inv TYP0. eapply inject_list_typify_list; eauto. }
      econs.
    + ss.

  - i. ss. exploit SimSymbDropInv_match_globals.
    { inv SIMSKENV. ss. eauto. } intros GEMATCH.
    des. inv SAFESRC. inv SIMARGS. esplits. econs; ss.
    + eapply match_globals_find_funct; eauto.
    + inv TYP. econs; eauto.
      erewrite <- inject_list_length; eauto.
    + ss.

  - i. ss. inv MATCH; eauto.

  - i. ss. clear SOUND. inv CALLSRC. inv MATCH. inv MATCHST. inv SIMSKENV. ss.
    esplits; eauto.
    + econs; ss; eauto.
      * eapply SimSymbDropInv_find_None; eauto.
        ii. clarify. ss. des. clarify.
      * des. clear EXTERNAL.
        unfold Genv.find_funct, Genv.find_funct_ptr in *. des_ifs_safe.
        inv INJ. inv SIMSKELINK.
        exploit SIMDEF; eauto. i. des. clarify. des_ifs. esplits; eauto.
    + econs; ss.
    + refl.
    + instantiate (1:=top4). ss.

  - i. ss. clear SOUND HISTORY.
    exists (SimMemInjInvC.unlift' sm_arg sm_ret).
    inv AFTERSRC. inv MATCH. inv MATCHST.
    esplits; eauto.
    + econs; eauto. inv SIMRET; ss.
    + inv SIMRET; ss. econs; eauto. econs; eauto.
      { eapply inject_typify; et. }
      ss. eapply match_cont_incr; try eassumption.
      inv MLE. inv MLE1. inv MLE0. inv MLE. etrans; eauto.
    + refl.

  - i. ss. inv FINALSRC. inv MATCH. inv MATCHST. inv CONT.
    esplits; eauto.
    + econs.
    + econs; eauto.
    + refl.

  - left. i. split.
    + eapply modsem2_receptive.
    + ii. inv MATCH. destruct sm0 as [sm0 mem_inv_src mem_inv_tgt].
      cinv MWF. cinv WF0. ss.
      exploit clight_step_preserve_injection2; try eassumption.
      { instantiate (1:=cgenv skenv_link_tgt clight). ss. }
      { eapply function_entry2_inject. ss. }
      { inv SIMSKENV. exploit SimSymbDropInv.sim_skenv_symbols_inject; eauto. }
      { inv SIMSKENV. ss. rpapply SimSymbDropInv_match_globals; eauto. } i. des.
      exploit SimMemInjC.parallel_gen; eauto. i. des.
      hexploit SimMemInjInv.le_inj_wf_wf; eauto. intros MWFINV0.

      esplits; eauto.
      * left. apply plus_one. econs; ss; eauto.
        eapply modsem2_determinate.
      * instantiate (1:=SimMemInjInv.mk _ _ _). econs; ss; eauto.
      * econs; ss; eauto.
Qed.

End INJINV.