Require Import syntax.
Require Import alist.
Require Import FMapWeakList.

Require Import Classical.
Require Import Coqlib.
Require Import infrastructure.
Require Import Metatheory.
Import LLVMsyntax.
Import LLVMinfra.
Require Import opsem.

Require Import sflib.
Require Import paco.
Import Opsem.

Require Import TODO.
Require Import Exprs.
Require Import Hints.
Require Import Postcond.
Require Import Validator.
Require Import GenericValues.
Require AssnMem.
Require AssnState.
Require Import Hints.
Require Import Infrules.

Set Implicit Arguments.

Section Filter.
  Definition filter
             (preserved: Exprs.Tag.t * id -> bool)
             (inv: AssnState.Unary.t): AssnState.Unary.t :=
    AssnState.Unary.update_ghost
      (filter_AL_atom (preserved <*> (pair Exprs.Tag.ghost)))
      (AssnState.Unary.update_previous
         (filter_AL_atom (preserved <*> (pair Exprs.Tag.previous)))
         inv).

  Lemma filter_subset_idT st_unary f id invst_unary val
        (VAL_SUBSET: (AssnState.Unary.sem_idT st_unary (filter f invst_unary) id = Some val)):
    <<VAL: (AssnState.Unary.sem_idT st_unary invst_unary id = Some val)>>.
  Proof.
    destruct id. destruct t; ss.
    - eapply lookup_AL_filter_some. exact VAL_SUBSET.
    - eapply lookup_AL_filter_some. exact VAL_SUBSET.
  Qed.

  Lemma filter_subset_valueT conf_unary st_unary f vt invst_unary val
        (VAL_SUBSET: (AssnState.Unary.sem_valueT
                        conf_unary st_unary
                        (filter f invst_unary) vt = Some val)):
    <<VAL: (AssnState.Unary.sem_valueT conf_unary st_unary invst_unary vt = Some val)>>.
  Proof.
    red. destruct vt; ss.
    eapply filter_subset_idT; eauto.
  Qed.

  Lemma filter_subset_list_valueT conf_unary st_unary f vts invst_unary val
        (VAL_SUBSET: (AssnState.Unary.sem_list_valueT
                        conf_unary st_unary
                        (filter f invst_unary) vts = Some val)):
    <<VAL: (AssnState.Unary.sem_list_valueT conf_unary st_unary invst_unary vts = Some val)>>.
  Proof.
    red. revert val VAL_SUBSET. induction vts; i; ss. destruct a.
    Ltac exploit_with H x :=
      (exploit H; [exact x|]; eauto; ii; des).
    des_ifs; ss;
      (all_once exploit_with filter_subset_valueT);
      (exploit IHvts; eauto; i); clarify.
  Qed.

  Lemma filter_subset_expr conf_unary st_unary f expr invst_unary val
        (VAL_SUBSET: (AssnState.Unary.sem_expr
                        conf_unary st_unary
                        (filter f invst_unary) expr = Some val)):
    <<VAL: (AssnState.Unary.sem_expr conf_unary st_unary invst_unary expr = Some val)>>.
  Proof.
    red.
    Ltac exploit_filter_subset_with x :=
      match (type of x) with
      | (AssnState.Unary.sem_valueT _ _ _ _ = Some _) =>
        (exploit filter_subset_valueT; [exact x|]; eauto; ii; des)
      | (AssnState.Unary.sem_list_valueT _ _ _ _ = Some _) =>
        (exploit filter_subset_list_valueT; [exact x|]; eauto; ii; des)
      end.
    Time destruct expr; ss;
      des_ifs; ss; (all_once exploit_filter_subset_with); clarify.
  (* exploit_with: Finished transaction in 25.39 secs (25.194u,0.213s) (successful) *)
  (* exploit_with_fast: Finished transaction in 7.575 secs (7.536u,0.044s) (successful) *)
  Qed.

  Lemma filter_preserved_valueT
        conf_unary st_unary invst_unary vt val f
        (VAL: AssnState.Unary.sem_valueT conf_unary st_unary invst_unary vt = Some val)
        (PRESERVED: (sflib.is_true (List.forallb f (Exprs.ValueT.get_idTs vt)))):
    <<VAL: AssnState.Unary.sem_valueT conf_unary st_unary (filter f invst_unary) vt = Some val>>.
  Proof.
    red. destruct vt; ss. repeat (des_bool; des).
    unfold AssnState.Unary.sem_idT. destruct x. s.
    destruct t; ss.
    - rewrite lookup_AL_filter_spec in *. des_ifs.
      unfold compose, Tag.t, Ords.id.t in *. rewrite PRESERVED in *. clarify.
    - rewrite lookup_AL_filter_spec in *. des_ifs.
      unfold compose, Tag.t, Ords.id.t in *. rewrite PRESERVED in *. clarify.
  Qed.

  Lemma filter_preserved_list_valueT
        conf_unary st_unary invst_unary vts val f
        (VAL: AssnState.Unary.sem_list_valueT conf_unary st_unary invst_unary vts = Some val)
        (PRESERVED: sflib.is_true (List.forallb
                                     (fun x => (List.forallb f (Exprs.ValueT.get_idTs x)))
                                     (List.map snd vts))):
    <<VAL: AssnState.Unary.sem_list_valueT conf_unary st_unary (filter f invst_unary) vts = Some val>>.
  Proof.
    revert val VAL PRESERVED. induction vts; i; ss.
    destruct a. ss. repeat (des_bool; des).
    des_ifs; ss.
    - (exploit filter_preserved_valueT; [exact Heq1| |]; eauto; ii; des).
      exploit IHvts; eauto; []; ii; des. clarify.
    - (exploit filter_preserved_valueT; [exact Heq1| |]; eauto; ii; des).
      exploit IHvts; eauto; []; ii; des. clarify.
    - (exploit filter_preserved_valueT; [exact Heq0| |]; eauto; ii; des).
      exploit IHvts; eauto; []; ii; des. clarify.
  Qed.

  Lemma filter_preserved_expr
        conf_unary st_unary invst_unary expr val f
        (VAL: AssnState.Unary.sem_expr conf_unary st_unary invst_unary expr = Some val)
        (PRESERVED: List.forallb f (Exprs.Expr.get_idTs expr)):
    <<VAL: AssnState.Unary.sem_expr conf_unary st_unary (filter f invst_unary) expr = Some val>>.
  Proof.
    red.
    unfold Exprs.Expr.get_idTs in *.
    eapply forallb_filter_map in PRESERVED. des.
    unfold is_true in PRESERVED. (* des_bool should kill it!!!!!!! KILL ALL is_true *)

    Ltac exploit_filter_preserved_with x :=
      match (type of x) with
      | (AssnState.Unary.sem_valueT _ _ (filter _ _) _ = _) => fail 1
      | (AssnState.Unary.sem_list_valueT _ _ (filter _ _) _ = _) => fail 1
      (* Above is REQUIRED in order to prevent inf loop *)
      | (AssnState.Unary.sem_valueT _ _ _ _ = Some _) =>
        (exploit filter_preserved_valueT; [exact x| |]; eauto; ii; des)
      | (AssnState.Unary.sem_list_valueT _ _ _ _ = Some _) =>
        (exploit filter_preserved_list_valueT; [exact x| |]; eauto; ii; des)
      end.

    Time destruct expr; ss;
      repeat (des_bool; des); des_ifs; clarify;
        (all_once exploit_filter_subset_with); clarify;
          (all_once exploit_filter_preserved_with); clarify.
  Qed.

  Lemma In_map_incl {A} (f: Exprs.ExprPair.t -> list A) x xs
        (IN: Exprs.ExprPairSet.In x xs):
    <<IN: List.incl (f x) (List.concat (List.map f (Exprs.ExprPairSet.elements xs)))>>.
  Proof.
    rewrite ExprPairSetFacts.elements_iff in IN. induction IN; ss.
    - subst. apply incl_appl. solve_leibniz. apply incl_refl.
    - apply incl_appr. ss.
  Qed.

  Lemma filter_AL_atom_preserves_wf_lc
        f mem lc
        (WF_LOCAL : memory_props.MemProps.wf_lc mem lc)
    : memory_props.MemProps.wf_lc mem (filter_AL_atom f lc).
  Proof.
    unfold memory_props.MemProps.wf_lc in *.
    i. exploit WF_LOCAL; eauto.
    eapply lookup_AL_filter_some; eauto.
  Qed.

  Lemma incl_implies_preserved
        conf st invst0 expr val inv
        (preserved: _ -> bool)
        (PRESERVED: forall id (ID: In id (Assertion.get_idTs_unary inv)), preserved id)
        (VAL: AssnState.Unary.sem_expr conf st invst0 expr = Some val)
        (INCL: incl (Exprs.Expr.get_idTs expr) (Assertion.get_idTs_unary inv)):
    <<PRESERVED: AssnState.Unary.sem_expr conf st (filter preserved invst0) expr = Some val>>.
  Proof.
    eapply filter_preserved_expr; eauto. apply forallb_forall. i.
    apply PRESERVED. apply INCL. ss.
  Qed.

  Lemma filter_spec
        conf st invst assnmem inv gmax public
        (preserved: _ -> bool)
        (PRESERVED: forall id (ID: In id (Assertion.get_idTs_unary inv)), preserved id)
        (STATE: AssnState.Unary.sem conf st invst assnmem gmax public inv):
    AssnState.Unary.sem conf st (filter preserved invst) assnmem gmax public inv.
  Proof.
    inv STATE. econs; eauto.
    - ii.
      exploit filter_subset_expr; eauto. i. des.
      exploit LESSDEF; eauto. i. des.
      exploit incl_implies_preserved; eauto.
      eapply incl_tran; [|eapply incl_tran]; swap 2 3.
      + apply incl_appr. apply incl_refl.
      + unfold Assertion.get_idTs_unary.
        apply incl_appl. apply incl_refl.
      + eapply In_map_incl in H. des. refine H.
    - inv NOALIAS. econs; i.
      + eapply DIFFBLOCK; eauto.
        * eapply filter_subset_valueT; eauto.
        * eapply filter_subset_valueT; eauto.
      + eapply NOALIAS0; eauto.
        * eapply filter_subset_valueT; eauto.
        * eapply filter_subset_valueT; eauto.
    - ii. exploit PRIVATE; eauto.
      eapply filter_subset_idT; eauto.
    - apply filter_AL_atom_preserves_wf_lc. eauto.
    - apply filter_AL_atom_preserves_wf_lc. eauto.
  Qed.
End Filter.

Lemma reduce_maydiff_lessdef_sound
      m_src m_tgt
      conf_src st_src
      conf_tgt st_tgt
      invst assnmem inv
      (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem inv)
      (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem):
  <<STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst assnmem
                            (reduce_maydiff_lessdef inv)>>.
Proof.
  inversion STATE. econs; eauto. ii.
  ss. rewrite IdTSetFacts.filter_b in NOTIN; [|solve_compat_bool].
  repeat (des_bool; des); ss; cycle 2.
  { exploit MAYDIFF; eauto. } clear MAYDIFF.
  apply ExprPairSetFacts.exists_iff in NOTIN; [|solve_compat_bool].
  red in NOTIN; des.
  apply ExprPairSetFacts.exists_iff in NOTIN0; [|solve_compat_bool].
  red in NOTIN0; des.
  apply AssnState.get_lhs_in_spec in NOTIN0.
  apply AssnState.get_rhs_in_spec in NOTIN.
  destruct x, x0. ss. des. subst.
  rename id0 into idt.

  (* src lessdef x, t0 --> t0's result exists *)
  inv SRC. clear NOALIAS UNIQUE PRIVATE.
  exploit LESSDEF; eauto; []; ii; des. clear LESSDEF.

  (* inject_expr t0, t1 --> t1's result exists *)
  exploit AssnState.Rel.inject_expr_spec; eauto; []; ii; des.

  (* tgt t1, x --> x's result exists *)
  inv TGT. clear NOALIAS UNIQUE PRIVATE.
  exploit LESSDEF; eauto; []; ii; des. clear LESSDEF.

  (* val_src >= val_a >= val_tgt >= val_b *)
  esplits; eauto.
  exploit GVs.inject_lessdef_compose; eauto; []; ii; des.
  exploit GVs.lessdef_inject_compose; try exact x0; eauto.
Qed.

Lemma reduce_maydiff_preserved_sem_idT st_src st_tgt
      invst inv id val_src val_tgt
  (VAL_SRC: AssnState.Unary.sem_idT st_src
              (filter (reduce_maydiff_preserved inv) (AssnState.Rel.src invst)) id =
            Some val_src)
  (VAL_TGT: AssnState.Unary.sem_idT st_tgt (AssnState.Rel.tgt invst) id = Some val_tgt):
  <<VAL_TGT: AssnState.Unary.sem_idT st_tgt
    (filter (reduce_maydiff_preserved inv) (AssnState.Rel.tgt invst)) id = Some val_tgt>>.
Proof.
  destruct id. unfold Ords.id.t in *. rename t0 into id.
  unfold AssnState.Unary.sem_idT in *. ss.
  unfold AssnState.Unary.sem_tag in *. ss.
  unfold compose in *.
  destruct t; ss.
  - rewrite <- VAL_TGT.
    rewrite lookup_AL_filter_spec in *.
    rewrite lookup_AL_filter_spec in VAL_SRC. (* WHY SHOULD I WRITE IT ONCE AGAIN?? *)
    des_ifs.
  - rewrite <- VAL_TGT.
    rewrite lookup_AL_filter_spec in *.
    rewrite lookup_AL_filter_spec in VAL_SRC. (* WHY SHOULD I WRITE IT ONCE AGAIN?? *)
    des_ifs.
Qed.

Lemma reduce_maydiff_non_physical_sound
      m_src m_tgt
      conf_src st_src
      conf_tgt st_tgt
      invst0 assnmem inv
      (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst0 assnmem inv)
      (MEM: AssnMem.Rel.sem conf_src conf_tgt st_src.(Mem) st_tgt.(Mem) assnmem):
  exists invst1,
    <<STATE: AssnState.Rel.sem conf_src conf_tgt st_src st_tgt invst1 assnmem
                              (reduce_maydiff_non_physical inv)>>.
Proof.
  exists (AssnState.Rel.update_both (filter (reduce_maydiff_preserved
                                         ((Assertion.get_idTs_unary inv.(Assertion.src))
                                            ++ (Assertion.get_idTs_unary inv.(Assertion.tgt))))) invst0).
  red.
  inv STATE.
  econs; ss; cycle 2.
  - ii. ss.
    rewrite IdTSetFacts.filter_b in NOTIN; [|solve_compat_bool].
    des_bool. des.
    + exploit MAYDIFF; eauto.
      { exploit filter_subset_idT; eauto. }
      i. des. esplits; eauto.
      eapply reduce_maydiff_preserved_sem_idT; eauto.
    + destruct id0. unfold Ords.id.t in *.
      rename t into __t__, t0 into __i__.
      unfold AssnState.Unary.sem_idT in VAL_SRC. ss.
      unfold AssnState.Unary.sem_tag in VAL_SRC. ss.
      unfold compose in *.
      destruct __t__; inv NOTIN.
      * rewrite lookup_AL_filter_spec in VAL_SRC.
        unfold Tag.t in *. rewrite H0 in VAL_SRC. ss.
      * rewrite lookup_AL_filter_spec in VAL_SRC.
        unfold Tag.t in *. rewrite H0 in VAL_SRC. ss.
  - apply filter_spec; ss. i.
    unfold reduce_maydiff_preserved. apply orb_true_iff. right.
    rewrite find_app.
    match goal with
    | [|- context[match ?g with | Some _ => _ | None => _ end]] =>
      let COND := fresh "COND" in
      destruct g eqn:COND
    end; ss.
    eapply find_none in COND; [|eauto].
    destruct (IdT.eq_dec id0 id0); ss.
  - apply filter_spec; ss. i.
    unfold reduce_maydiff_preserved. apply orb_true_iff. right.
    rewrite find_app.
    match goal with
    | [|- context[match ?g with | Some _ => _ | None => _ end]] =>
      let COND := fresh "COND" in
      destruct g eqn:COND
    end; ss.
    apply In_eq_find. ss.
Grab Existential Variables.
  { eauto. }
Qed.


From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality Streams.
Require Import Sequences IMP Compil MachDeterm.
Import ListNotations.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope list_scope.

(** We add nondeterministic interruption to the deterministic
    semantics, obtaining the full semantics for the machine. *)

(* States of the stack machine under full semantics. For simplicity,
we assume that interruption causes the program to step to a special
Intr configuration in one step. *)
Inductive config : Type :=
| OK: Determ.config -> config
| Intr: config.
Notation "$( pc , stk , s , g )" := (OK (pc, stk, s, g)).

(* Operational semantics of the stack machine: either the machine
steps according to the deterministic semantics, or it is
interrupted. *)
Inductive transition (C: code): config -> option event -> config -> Prop :=
| trans_determ : forall conf conf' eopt,
    Determ.transition C conf eopt conf' ->
    transition C (OK conf) eopt (OK conf')
| trans_intr : forall conf,
    transition C (OK conf) (Some ev_intr) Intr.

Definition transitions (C: code): config -> list event -> config -> Prop :=
  star (transition C).

(** The machine terminates normally on an Ihalt instruction, emitting trace tr. *)
Definition machine_terminates_ok (C: code) (s_init: store) (g_init: global_state)
           (tr: trace) (s_final: store) (g_final: global_state) : Prop :=
  exists pc, transitions C $(0, nil, s_init, g_init) tr $(pc, nil, s_final, g_final)
         /\ instr_at C pc = Some Ihalt.

(** The machine emits trace tr and is then interrupted. *)
Definition machine_intr (C: code) (s_init: store) (g_init: global_state)
           (tr : trace): Prop :=
  transitions C $(0, nil, s_init, g_init) tr Intr.

(** The machine emits trace tr then diverges silently. *)
Definition machine_diverges_silently
           (C: code) (s_init: store) (g_init: global_state) (tr: trace) : Prop :=
  diverges_silently (transition C) $(0, nil, s_init, g_init) tr.

(** The machine diverges with an infinte sequence of events itr. *)
Definition machine_diverges_with_inftrace (C: code) (s_init: store)
           (g_init: global_state) (itr: inftrace) : Prop :=
  infseq_with_inftrace (transition C) $(0, nil, s_init, g_init) itr.

(** The machine gets "stuck": it reaches a state from which it cannot
step but whose current instruction is not Ihalt.  *)
Definition machine_goes_wrong (C: code) (s_init: store) (g_init: global_state)
           (tr: trace) : Prop :=
  exists pc stk s g,
      transitions C $(0, nil, s_init, g_init) tr $(pc, stk, s, g)
   /\ irred (transition C) $(pc, stk, s, g)
   /\ (instr_at C pc <> Some Ihalt \/ stk <> nil).

(** The machine emits trace tr, then reaches a state from which no
further steps are possible. *)
Definition machine_terminates (C: code) (s_init: store) (g_init: global_state)
           (tr: trace) : Prop :=
    exists config', transitions C $(0, nil, s_init, g_init) tr config'
               /\ irred (transition C) config'.

(* If the machine terminates, it must have either terminated normally,
been interrupted, or gotten stuck. *)
Lemma machine_terminates_ok_intr_or_wrong: forall C s g tr,
    machine_terminates C s g tr ->
    (exists s' g', machine_terminates_ok C s g tr s' g') \/
    (machine_intr C s g tr) \/
    (machine_goes_wrong C s g tr).
Proof.
  intros. inversion H as (conf' & Htrans & Hirred); subst.
  destruct conf'.
  - destruct c as [[[pc' stk'] s'] g'].
    destruct (instr_at C pc') eqn:E; try destruct i;
      try (right; right; repeat eexists; eauto; left; congruence).
    destruct stk'.
    + left. repeat eexists; eauto.
    + right; right; repeat eexists; eauto; right; congruence.
  - right; left. now unfold machine_intr.
Qed.

Lemma no_trans_from_intr : forall C eopt config,
    ~(transition C Intr eopt config).
Proof.
  intuition; inversion H.
Qed.

Lemma intr_irred : forall C,
    irred (transition C) Intr.
Proof.
  unfold irred. auto using no_trans_from_intr.
Qed.

(** Proof of modified backward simulation between machine under
deterministic semantics and machine under full semantics. We show that
if the machine admits trace tr under full semantics, then either it
admits trace tr under deterministic semantics, or tr is a prefix of
some tr' followed by interruption and the machine admits tr' under
deterministic semantics. *)

(* Some helper lemmas *)
Lemma determ_implies_full_one: forall C conf eopt conf',
    Determ.transition C conf eopt conf' ->
    transition C (OK conf) eopt (OK conf').
Proof.
  econstructor; eauto.
Qed.

Lemma determ_implies_full: forall C conf tr conf',
    Determ.transitions C conf tr conf' ->
    transitions C (OK conf) tr (OK conf').
Proof.
  induction 1.
  - econstructor.
  - econstructor; eauto using transition.
  - eapply star_step_ev; eauto using transition.
Qed.

Lemma full_OK_implies_determ_one: forall C conf eopt conf',
    transition C (OK conf) eopt (OK conf') ->
    Determ.transition C conf eopt conf'.
Proof.
  inversion 1; subst; trivial.
Qed.

Lemma full_OK_implies_determ: forall C conf tr conf',
    transitions C (OK conf) tr (OK conf') ->
    Determ.transitions C conf tr conf'.
Proof.
  intros until 1; dependent induction H.
  - econstructor.
  - destruct b.
    + specialize (IHstar c conf').
      apply star_step with (b := c).
      now apply full_OK_implies_determ_one.
      now apply IHstar.
    + inversion H.
  - destruct b.
    + specialize (IHstar c conf').
      apply star_step_ev with (b := c).
      now apply full_OK_implies_determ_one.
      now apply IHstar.
    + exfalso. inversion H0; subst; inversion H1.
Qed.

Lemma full_OK_implies_determ_plus: forall C conf tr conf',
    plus (transition C) (OK conf) tr (OK conf') ->
    plus (Determ.transition C) conf tr conf'.
Proof.
  intros. inversion H.
  - destruct b.
    + apply plus_left with (b := c0).
      now apply full_OK_implies_determ_one.
      now apply full_OK_implies_determ.
    + inversion H1; inversion H5.
 - destruct b.
    + apply plus_left_ev with (b := c0).
      now apply full_OK_implies_determ_one.
      now apply full_OK_implies_determ.
    + inversion H1; inversion H5.
Qed.

Lemma irred_implies_determ_irred: forall C conf,
    irred (transition C) (OK conf) -> irred (Determ.transition C) conf.
Proof.
  intros.
  unfold irred in *. intros.
  specialize (H (OK b) eo). intuition.
  apply H. now apply determ_implies_full_one.
Qed.

Definition wrong_implies_determ_wrong: forall C s g tr,
    machine_goes_wrong C s g tr ->
    Determ.machine_goes_wrong C s g tr.
Proof.
  intros. unfold machine_goes_wrong in H. unfold Determ.machine_goes_wrong.
  destruct H as (pc' & stk' & s' & g' & Htrans & Hirred & Hinsstk).
  exists pc', stk', s', g'.
  repeat split.
  - now apply full_OK_implies_determ.
  - now apply irred_implies_determ_irred.
  - easy.
Qed.

Local Hint Constructors step Determ.transition transition star plus : code.
Local Hint Unfold imp_terminates imp_diverges_silently imp_diverges_with_inftrace
      Determ.machine_terminates Determ.machine_diverges_silently Determ.machine_diverges_with_inftrace
      Determ.transitions machine_terminates machine_diverges_silently machine_diverges_with_inftrace transitions : code.
Local Hint Resolve full_OK_implies_determ wrong_implies_determ_wrong irred_implies_determ_irred : code.

Lemma full_Intr_implies_prefix_OK: forall C conf tr,
    transitions C (OK conf) tr Intr ->
    exists conf' tr', transitions C (OK conf) tr' (OK conf') /\
                 transition C (OK conf') (Some ev_intr) Intr /\
                 tr = tr' ++ [ev_intr].
Proof.
  intros until 1; dependent induction H; intros.
  - destruct b.
    + assert (OK c = OK c) by congruence. assert (Intr = Intr) by congruence.
      specialize (IHstar c H1 H2).
      destruct IHstar as (conf' & tr' & Hok & Hintr & Ht).
      exists conf', tr'. split; eauto 10. econstructor; eauto.
    + inversion H.
  - destruct b.
    + assert (OK c = OK c) by congruence. assert (Intr = Intr) by congruence.
      specialize (IHstar c H1 H2).
      destruct IHstar as (conf' & tr' & Hok & Hintr & Ht).
      exists conf', (e :: tr'). repeat split; eauto 10. eapply star_step_ev; eauto.
      rewrite Ht. now apply app_comm_cons.
    + inversion H; subst.
      exists conf, []. repeat split. econstructor. eauto.
      cbn. inversion H0; subst; auto; inversion H1.
Qed.

(** Modified backward simulation between deterministic and full
semantics, for all three valid behaviors. *)
Theorem prefix_correct_full_to_determ_semantics: forall C s g tr,
    machine_terminates C s g tr ->
    (exists s' g', Determ.machine_terminates C s g tr s' g')
    \/ (exists m, tr = m ++ [ev_intr] /\ Determ.machine_admits_finite C s g m)
    \/ (Determ.machine_goes_wrong C s g tr).
Proof.
  intros.
  apply machine_terminates_ok_intr_or_wrong in H. destruct H; [ | destruct H ].
  - left. destruct H as (s' & g' & H). exists s', g'.
    unfold machine_terminates_ok in H. unfold Determ.machine_terminates.
    destruct H as (pc & Htrans & Hinstr).
    exists pc; split; eauto using full_OK_implies_determ.
  - right; left. unfold machine_intr in H.
    apply full_Intr_implies_prefix_OK in H.
    destruct H as (conf' & tr' & Hok & Hintr & Htr). exists tr'; split; auto.
    unfold Determ.machine_admits_finite. exists conf'.
    eauto using full_OK_implies_determ.
  - right; right; auto using wrong_implies_determ_wrong.
Qed.

Lemma divergence_implies_determ_divergence_silent: forall C s g tr,
    machine_diverges_silently C s g tr ->
    Determ.machine_diverges_silently C s g tr.
Proof.
  unfold Determ.machine_diverges_silently, machine_diverges_silently, diverges_silently. intros.
  destruct H as (b & Hstar & Hinf). destruct b.
  - exists c. split. now apply full_OK_implies_determ.
    assert (forall C c, infseq_silent (transition C) (OK c) -> infseq_silent (Determ.transition C) c). {
      clear. cofix CIH; intros.
      inversion H; subst. destruct b; inversion H0; subst.
      econstructor; eauto.
    }
    eauto.
  - inversion Hinf. inversion H.
Qed.

Lemma divergence_implies_determ_divergence_inftrace: forall C s g itr,
    machine_diverges_with_inftrace C s g itr ->
    Determ.machine_diverges_with_inftrace C s g itr.
Proof.
  unfold machine_diverges_with_inftrace, Determ.machine_diverges_with_inftrace. intros.
  apply infseq_with_inftrace_coinduction_principle with
      (X := fun conf tr => infseq_with_inftrace (transition C) (OK conf) tr); auto.
  intros. inversion H0; subst.
  destruct b.
  - exists c, t0, it. repeat split; auto using full_OK_implies_determ_plus.
  - inversion H3; subst. inversion H4; subst; inversion H7.
Qed.

(** Top-level compiler correctness theorems for all three types of behavior. *)
Theorem compile_program_correct_terminating: forall c s g tr,
    machine_terminates (compile_program c) s g tr ->
    (exists s' g', imp_terminates c s g tr s' g')
    \/ (exists m, tr = m ++ [ev_intr] /\ imp_admits_finite c s g m).
Proof.
  intros.
  apply prefix_correct_full_to_determ_semantics in H. destruct H; [ | destruct H ].
  - left. destruct H as (s' & g' & Hdet). exists s', g'.
    now apply Determ.compile_program_correct_terminating_backward.
  - right. destruct H as (m & Htr & Hdet). exists m; split; auto.
    unfold Determ.machine_admits_finite in Hdet. destruct Hdet as (machconf2 & Hdet).
    apply Determ.compile_program_correct_admits_finite in Hdet.
    destruct Hdet as (impconf2 & Hstep).
    unfold imp_admits_finite. eauto.
  - now apply Determ.compile_program_never_goes_wrong in H.
Qed.

Theorem compile_program_correct_diverging_silently: forall c s g tr,
    machine_diverges_silently (compile_program c) s g tr ->
    imp_diverges_silently c s g tr.
Proof.
  intros.
  apply Determ.compile_program_correct_diverging_silently_backward.
  now apply divergence_implies_determ_divergence_silent.
Qed.

Theorem compile_program_correct_diverging_with_inftrace: forall c s g itr itr',
    machine_diverges_with_inftrace (compile_program c) s g itr ->
    imp_diverges_with_inftrace c s g itr' -> EqSt itr itr'.
Proof.
  intros.
  eapply Determ.compile_program_correct_diverging_with_inftrace_backward.
  eapply divergence_implies_determ_divergence_inftrace; eauto.
  eauto.
Qed.


(*
 * © 2019 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     AdversaryUniverse
     ChMaps
     Messages
     Maps
     Keys
     Tactics
     IdealWorld
     RealWorld
.

Import RealWorld.RealWorldNotations.
Import IdealWorld.IdealNotations.

Fixpoint content_eq {t__rw t__iw}
         (m__rw : RealWorld.message.message t__rw)
         (m__iw : IdealWorld.message.message t__iw) gks : Prop :=
  match (m__rw, m__iw) with
  | (RealWorld.message.Content c__rw, IdealWorld.message.Content c__iw) => c__rw = c__iw
  | (RealWorld.message.Permission (id, pk) , IdealWorld.message.Permission (IdealWorld.construct_access a _)) =>
    match (gks $? id) with
    | Some (Keys.MkCryptoKey _ _ Keys.SymKey) => a = (IdealWorld.construct_permission true true)
    | Some (Keys.MkCryptoKey id Keys.Signing Keys.AsymKey) => a = (IdealWorld.construct_permission true pk)
    | Some (Keys.MkCryptoKey id Keys.Encryption Keys.AsymKey) => a = (IdealWorld.construct_permission pk true)
    | _ => False
    end
  | (RealWorld.message.MsgPair m__rw1 m__rw2, IdealWorld.message.MsgPair m__iw1 m__iw2) =>
    content_eq m__rw1 m__iw1 gks /\ content_eq m__rw2 m__iw2 gks
  | _ => False
  end.

Definition resolve_perm (ps : IdealWorld.permissions) id :=
  match id with
  | ChMaps.Single ch => ps $? ch
  | ChMaps.Intersection ch1 ch2 =>
    match (ps $? ch1, ps $? ch2) with
    | (Some p1, Some p2) => Some (IdealWorld.perm_intersection p1 p2)
    | _ => None
    end
  end.

Definition not_replayed (cs : RealWorld.ciphers) (honestk : key_perms)
           (uid : user_id) (froms : RealWorld.recv_nonces) {t} (msg : RealWorld.crypto t) :=
  RealWorld.msg_honestly_signed honestk cs msg
  && RealWorld.msg_to_this_user cs (Some uid) msg
  && match msg_nonce_ok cs froms msg with
     | Some f => true
     | None   => false
     end.

Definition key_perms_from_known_ciphers (cs : RealWorld.ciphers) (mycs : RealWorld.my_ciphers) (ks0 : key_perms) :=
  fold_left (fun kys cid => match cs $? cid with
                         | Some (RealWorld.SigCipher _ _ _ m) => kys $k++ RealWorld.findKeysMessage m
                         | Some (RealWorld.SigEncCipher _ _ _ _ m) => kys $k++ RealWorld.findKeysMessage m
                         | None => kys
                         end) mycs ks0.

Definition key_perms_from_message_queue (cs : RealWorld.ciphers) (honestk: key_perms)
           (msgs : RealWorld.queued_messages) (uid : user_id) (froms : RealWorld.recv_nonces) (ks0 : key_perms) :=
  let cmsgs := clean_messages honestk cs (Some uid) froms msgs
  in  fold_left (fun kys '(existT _ _ m) => kys $k++ RealWorld.findKeysCrypto cs m) cmsgs ks0.

Inductive compat_perm : option bool -> bool -> Prop :=
| CompatEq :
    compat_perm (Some false) false
| CompatNone :
    compat_perm None false
| CompatTrue : forall sp,
    compat_perm sp true.


Require Import Coq.ZArith.BinInt.
Require Import Coq.Strings.String.
Require Import riscv.Utility.Monads. Import OStateOperations.
Require Import riscv.Utility.MonadNotations.
Require Import riscv.Spec.Decode.
Require Import riscv.Platform.Memory. (* should go before Program because both define loadByte etc *)
Require Import riscv.Spec.Machine.
Require Import riscv.Spec.Execute.
Require Import riscv.Utility.PowerFunc.
Require Import riscv.Utility.Utility.
Require Import Coq.Lists.List. Import ListNotations.
Require Import riscv.Platform.Minimal.
Require Import coqutil.Map.Interface.

Section Riscv.
  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Mem: map.map word byte}.
  Context {Registers: map.map Register word}.

  Local Notation empty_mem := (map.empty: Mem).

  Definition mkLogItemLoad(addr: word)(value: w32): LogItem :=
    ((empty_mem, "loadWord"%string, [addr]), (empty_mem, [int32ToReg value])).

  Definition mkLogItemStore(addr: word)(value: w32): LogItem :=
    ((empty_mem, "storeWord"%string, [addr; int32ToReg value]), (empty_mem, [])).

  Instance IsRiscvMachineL: RiscvProgram (OState RiscvMachine) word := {
      getRegister := getRegister;
      setRegister := setRegister;
      getPC := getPC;
      setPC := setPC;
      loadByte   := loadByte;
      loadHalf   := loadHalf;
      loadWord kind a :=
        Bind get
             (fun m =>
                Bind (Monad := (OState_Monad _)) (* why does Coq infer OStateND_Monad?? *)
                     (loadWord kind a)
                     (fun res =>
                        Bind (Monad := (OState_Monad _)) (* why does Coq infer OStateND_Monad?? *)
                             (put (withLogItem (mkLogItemLoad a res) m))
                             (fun _ => Return res)));
(*
        m <- get;
        res <- (loadWord kind a);
        put (withLogItem (mkLogItemLoad a res));;
        Return res;
*)

      loadDouble := loadDouble;
      storeByte   := storeByte;
      storeHalf   := storeHalf;

      storeWord kind a v :=
        Bind get
             (fun m =>
                Bind (Monad := (OState_Monad _)) (* why does Coq infer OStateND_Monad?? *)
                     (put (withLogItem (mkLogItemStore a v) m))
                     (fun (_: unit) =>
                        storeWord kind a v));

      storeDouble := storeDouble;
      makeReservation := makeReservation;
      clearReservation := clearReservation;
      checkReservation := checkReservation;
      getCSRField := getCSRField;
      setCSRField := setCSRField;
      getPrivMode := getPrivMode;
      setPrivMode := setPrivMode;
      fence := fence;

      endCycleNormal := endCycleNormal;
      endCycleEarly{A} := @endCycleEarly _ _ _ _ _ A;
  }.

End Riscv.

#[global] Existing Instance IsRiscvMachineL. (* needed because it was defined inside a Section *)


From Coq Require Import String List ZArith.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.
From compcert Require Import Maps Linking.

Require Import sflib.
Require Import StdlibExt.

Require Import NWSysModel.
Require Import RTSysEnv.
Require main_prm config_prm.
Require Import LinkLemmas.

Set Nested Proofs Allowed.

Local Open Scope Z_scope.

Local Opaque Z.of_nat Byte.unsigned nth.
(* main_p.ip_init_data *)

Local Transparent Linker_program Linker_prog Linker_def Linker_fundef Linker_varinit Ctypes.Linker_fundef Linker_vardef Linker_types.
Local Transparent external_function_eq calling_convention_eq signature_eq typ_eq rettype_eq.

Local Opaque in_dec zeq.

Lemma link_v_IP_ADDR
      nt nmc ip_bs
  : link_vardef (main_prm.v_IP_ADDR nt nmc)
                (config_prm.v_IP_ADDR nt nmc ip_bs) =
    Some (config_prm.v_IP_ADDR nt nmc ip_bs).
Proof.
  unfold main_prm.v_IP_ADDR, config_prm.v_IP_ADDR.
  unfold link_vardef. ss.
  destruct (zeq (nt + nmc) (nt + nmc)); ss.
Qed.

Lemma link_v_MCAST_MEMBER
      mnt mnmc mfs
  : link_vardef (main_prm.v_MCAST_MEMBER mnt mnmc)
                (config_prm.v_MCAST_MEMBER mnt mnmc mfs) =
    Some (config_prm.v_MCAST_MEMBER mnt mnmc mfs).
Proof.
  unfold main_prm.v_MCAST_MEMBER, config_prm.v_MCAST_MEMBER.
  simpl.
  unfold link_vardef. ss.
  destruct (zeq mnmc mnmc); ss.
  destruct (zeq mnt mnt); ss.
Qed.

Section PROGRAMS_OF_SYSTEM.

  Context `{SystemEnv}.

  Definition main_prog: Clight.program :=
    main_prm.prog (Z.of_nat msg_size_k)
                  (Z.of_nat max_num_tasks)
                  (Z.of_nat max_num_mcasts).

  Definition config_prog: Clight.program :=
    config_prm.prog
      (Z.of_nat max_num_tasks) (Z.of_nat max_num_mcasts)
      (Z.of_nat period) (Z.of_nat max_clock_skew) (Z.of_nat max_nw_delay)
      (Z.of_nat num_tasks) (Z.of_nat num_mcasts) (Z.of_nat msg_size)
      (Z.of_nat port) dest_ips_brep mcast_memflags.

  Lemma main_config_link_check_ok
        dm1 dm2
        (DM1: dm1 = prog_defmap main_prog)
        (DM2: dm2 = prog_defmap config_prog)
    : PTree_Properties.for_all
        dm1 (link_prog_check main_prog config_prog) = true.
  Proof.
    apply PTree_Properties.for_all_correct.
    intros id gd SOME.
    rewrite DM1 in SOME.
    unfold prog_defmap in SOME. ss.
    apply PTree_Properties.in_of_list in SOME. ss.
    des; clarify.
    - unfold link_prog_check.
      unfold prog_defmap. ss.

      assert (IN_PUB1: In main_prm._IP_ADDR
                          main_prm.public_idents).
      { unfold main_prm.public_idents. ss.
        repeat match goal with
               | |- ?a = ?b \/ _ =>
                 match a with
                 | b => left
                 | _ => right
                 end
               end.
        reflexivity. }

      assert (IN_PUB2: In main_prm._IP_ADDR
                          config_prm.public_idents).
      { unfold config_prm.public_idents. ss.
        repeat match goal with
               | |- ?a = ?b \/ _ =>
                 match a with
                 | config_prm._IP_ADDR => left
                 | _ => right
                 end
               end.
        reflexivity. }
      desf.

      rewrite link_v_IP_ADDR in *.
      congruence.
    - unfold link_prog_check.
      unfold prog_defmap. ss.

      assert (IN_PUB1: In main_prm._MCAST_MEMBER
                          main_prm.public_idents).
      { unfold main_prm.public_idents. ss.
        repeat match goal with
               | |- ?a = ?b \/ _ =>
                 match a with
                 | b => left
                 | _ => right
                 end
               end.
        reflexivity. }

      assert (IN_PUB2: In main_prm._MCAST_MEMBER
                          config_prm.public_idents).
      { unfold config_prm.public_idents. ss.
        repeat match goal with
               | |- ?a = ?b \/ _ =>
                 match a with
                 | config_prm._MCAST_MEMBER => left
                 | _ => right
                 end
               end.
        reflexivity. }
      desf.

      rewrite link_v_MCAST_MEMBER in *.
      congruence.
  Qed.

  (* Set Debug Cbv. *)
  (* Local Opaque Bool.bool_dec eq_ind eq_ind_r. *)
  (* Local Opaque link_prog_merge. *)

  Definition mw_AST_prog: AST.program Clight.fundef type :=
    let p1 := main_prog in
    let p2 := config_prog in
    let dm1 := prog_defmap p1 in
    let dm2 := prog_defmap p2 in
    {|
    AST.prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2);
    AST.prog_public := AST.prog_public p1 ++ AST.prog_public p2;
    AST.prog_main := AST.prog_main p1 |}.

  Lemma mw_AST_prog_linked
    : link_prog main_prog config_prog = Some mw_AST_prog.
  Proof.
    unfold link_prog.
    erewrite main_config_link_check_ok; eauto.
  Qed.

  Arguments Z.mul: simpl nomatch.

  Definition prog_mw_types : list composite_definition.
  Proof.
    let k := eval cbn in (link_composite_defs
                            (prog_types main_prog)
                            (prog_types config_prog)) in
        match k with
        | Some ?a => exact a
        end.
  Defined.

  Lemma prog_mw_types_linked
    : link_composite_defs (prog_types main_prog)
                          (prog_types config_prog) =
      Some prog_mw_types.
  Proof. ss. Qed.

  Definition prog_mw: Clight.program :=
    let p1 := main_prog in
    let p2 := config_prog in
    mkprogram prog_mw_types
              (PTree.elements (PTree.combine link_prog_merge (prog_defmap p1) (prog_defmap p2)))
              (AST.prog_public p1 ++ AST.prog_public p2)
              (AST.prog_main p1)
              I
  .

  Lemma prog_mw_linked
    : link_program main_prog config_prog = Some prog_mw.
  Proof.
    apply link_program_eq; ss.
    apply mw_AST_prog_linked.
  Qed.

End PROGRAMS_OF_SYSTEM.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, 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 INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for code linearization *)

Require Import Coqlib.
Require Import Maps.
Require Import Ordered.
Require Import FSets.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Errors.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import LTL.
Require Import LTLtyping.
Require Import LTLin.
Require Import Linearize.
Require Import Lattice.

Module NodesetFacts := FSetFacts.Facts(Nodeset).

Section LINEARIZATION.

Context `{Hcc: CompilerConfiguration}.
Variable prog: LTL.program.
Variable tprog: LTLin.program.

Hypothesis TRANSF: transf_program prog = OK tprog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  exists tf,
  Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_transf_partial transf_fundef _ TRANSF).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  exists tf,
  Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (Genv.find_symbol_transf_partial transf_fundef _ TRANSF).

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof (Genv.find_var_info_transf_partial transf_fundef _ TRANSF).

Lemma sig_preserved:
  forall f tf,
  transf_fundef f = OK tf ->
  LTLin.funsig tf = LTL.funsig f.
Proof.
  unfold transf_fundef, transf_partial_fundef; intros.
  destruct f. monadInv H. monadInv EQ. reflexivity.
  inv H. reflexivity.
Qed.

Lemma stacksize_preserved:
  forall f tf,
  transf_function f = OK tf ->
  LTLin.fn_stacksize tf = LTL.fn_stacksize f.
Proof.
  intros. monadInv H. auto.
Qed.

Lemma find_function_translated:
  forall ros ls f,
  LTL.find_function ge ros ls = Some f ->
  exists tf,
  find_function tge ros ls = Some tf /\ transf_fundef f = OK tf.
Proof.
  unfold LTL.find_function; intros; destruct ros; simpl.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

(** * Correctness of reachability analysis *)

(** The entry point of the function is reachable. *)

Lemma reachable_entrypoint:
  forall f, (reachable f)!!(f.(fn_entrypoint)) = true.
Proof.
  intros. unfold reachable.
  caseEq (reachable_aux f).
  unfold reachable_aux; intros reach A.
  assert (LBoolean.ge reach!!(f.(fn_entrypoint)) true).
  eapply DS.fixpoint_entry. eexact A. auto with coqlib.
  unfold LBoolean.ge in H. tauto.
  intros. apply PMap.gi.
Qed.

(** The successors of a reachable instruction are reachable. *)

Lemma reachable_successors:
  forall f pc pc' i,
  f.(LTL.fn_code)!pc = Some i -> In pc' (successors_instr i) ->
  (reachable f)!!pc = true ->
  (reachable f)!!pc' = true.
Proof.
  intro f. unfold reachable.
  caseEq (reachable_aux f).
  unfold reachable_aux. intro reach; intros.
  assert (LBoolean.ge reach!!pc' reach!!pc).
  change (reach!!pc) with ((fun pc r => r) pc (reach!!pc)).
  eapply DS.fixpoint_solution. eexact H.
  unfold Kildall.successors_list, successors. rewrite PTree.gmap1.
  rewrite H0; auto.
  elim H3; intro. congruence. auto.
  intros. apply PMap.gi.
Qed.

(** * Properties of node enumeration *)

(** An enumeration of CFG nodes is correct if the following conditions hold:
- All nodes for reachable basic blocks must be in the list.
- The list is without repetition (so that no code duplication occurs).

We prove that the result of the [enumerate] function satisfies both
conditions. *)

Lemma nodeset_of_list_correct:
  forall l s s',
  nodeset_of_list l s = OK s' ->
  list_norepet l
  /\ (forall pc, Nodeset.In pc s' <-> Nodeset.In pc s \/ In pc l)
  /\ (forall pc, In pc l -> ~Nodeset.In pc s).
Proof.
  induction l; simpl; intros.
  inv H. split. constructor. split. intro; tauto. intros; tauto.
  generalize H; clear H; caseEq (Nodeset.mem a s); intros.
  inv H0.
  exploit IHl; eauto. intros [A [B C]].
  split. constructor; auto. red; intro. elim (C a H1). apply Nodeset.add_1. hnf. auto.
  split. intros. rewrite B. rewrite NodesetFacts.add_iff.
  unfold Nodeset.E.eq. unfold OrderedPositive.eq. tauto.
  intros. destruct H1. subst pc. rewrite NodesetFacts.not_mem_iff. auto.
  generalize (C pc H1). rewrite NodesetFacts.add_iff. tauto.
Qed.

Lemma check_reachable_correct:
  forall f reach s pc i,
  check_reachable f reach s = true ->
  f.(LTL.fn_code)!pc = Some i ->
  reach!!pc = true ->
  Nodeset.In pc s.
Proof.
  intros f reach s.
  assert (forall l ok,
    List.fold_left (fun a p => check_reachable_aux reach s a (fst p) (snd p)) l ok = true ->
    ok = true /\
    (forall pc i,
     In (pc, i) l ->
     reach!!pc = true ->
     Nodeset.In pc s)).
  induction l; simpl; intros.
  split. auto. intros. destruct H0.
  destruct a as [pc1 i1]. simpl in H.
  exploit IHl; eauto. intros [A B].
  unfold check_reachable_aux in A.
  split. destruct (reach!!pc1). elim (andb_prop _ _ A). auto. auto.
  intros. destruct H0. inv H0. rewrite H1 in A. destruct (andb_prop _ _ A).
  apply Nodeset.mem_2; auto.
  eauto.

  intros pc i. unfold check_reachable. rewrite PTree.fold_spec. intros.
  exploit H; eauto. intros [A B]. eapply B; eauto.
  apply PTree.elements_correct. eauto.
Qed.

Lemma enumerate_complete:
  forall f enum pc i,
  enumerate f = OK enum ->
  f.(LTL.fn_code)!pc = Some i ->
  (reachable f)!!pc = true ->
  In pc enum.
Proof.
  intros until i. unfold enumerate.
  set (reach := reachable f).
  intros. monadInv H.
  generalize EQ0; clear EQ0. caseEq (check_reachable f reach x); intros; inv EQ0.
  exploit check_reachable_correct; eauto. intro.
  exploit nodeset_of_list_correct; eauto. intros [A [B C]].
  rewrite B in H2. destruct H2. elim (Nodeset.empty_1 H2). auto.
Qed.

Lemma enumerate_norepet:
  forall f enum,
  enumerate f = OK enum ->
  list_norepet enum.
Proof.
  intros until enum. unfold enumerate.
  set (reach := reachable f).
  intros. monadInv H.
  generalize EQ0; clear EQ0. caseEq (check_reachable f reach x); intros; inv EQ0.
  exploit nodeset_of_list_correct; eauto. intros [A [B C]]. auto.
Qed.

(** * Properties related to labels *)

(** If labels are globally unique and the LTLin code [c] contains
  a subsequence [Llabel lbl :: c1], then [find_label lbl c] returns [c1].
*)

Fixpoint unique_labels (c: code) : Prop :=
  match c with
  | nil => True
  | Llabel lbl :: c => ~(In (Llabel lbl) c) /\ unique_labels c
  | i :: c => unique_labels c
  end.

Lemma find_label_unique:
  forall lbl c1 c2 c3,
  is_tail (Llabel lbl :: c1) c2 ->
  unique_labels c2 ->
  find_label lbl c2 = Some c3 ->
  c1 = c3.
Proof.
  induction c2.
  simpl; intros; discriminate.
  intros c3 TAIL UNIQ. simpl.
  generalize (is_label_correct lbl a). case (is_label lbl a); intro ISLBL.
  subst a. intro. inversion TAIL. congruence.
  elim UNIQ; intros. elim H4. apply is_tail_in with c1; auto.
  inversion TAIL. congruence. apply IHc2. auto.
  destruct a; simpl in UNIQ; tauto.
Qed.

(** Correctness of the [starts_with] test. *)

Lemma starts_with_correct:
  forall lbl c1 c2 c3 s f sp ls m,
  is_tail c1 c2 ->
  unique_labels c2 ->
  starts_with lbl c1 = true ->
  find_label lbl c2 = Some c3 ->
  plus step tge (State s f sp c1 ls m)
             E0 (State s f sp c3 ls m).
Proof.
  induction c1.
  simpl; intros; discriminate.
  simpl starts_with. destruct a; try (intros; discriminate).
  intros.
  apply plus_left with E0 (State s f sp c1 ls m) E0.
  simpl. constructor.
  simpl in H1;
  destruct (peq lbl l).
  subst l. replace c3 with c1. constructor.
  apply find_label_unique with lbl c2; auto.
  apply plus_star.
  apply IHc1 with c2; auto. eapply is_tail_cons_left; eauto.
  traceEq.
Qed.

(** Connection between [find_label] and linearization. *)

Lemma find_label_add_branch:
  forall lbl k s,
  find_label lbl (add_branch s k) = find_label lbl k.
Proof.
  intros. unfold add_branch. destruct (starts_with s k); auto.
Qed.

Lemma find_label_lin_instr:
  forall lbl k b,
  find_label lbl (linearize_instr b k) = find_label lbl k.
Proof.
  intros lbl k. generalize (find_label_add_branch lbl k); intro.
  induction b; simpl; auto.
  case (starts_with n k); simpl; auto.
Qed.

Lemma find_label_lin_rec:
  forall f enum pc b,
  In pc enum ->
  f.(LTL.fn_code)!pc = Some b ->
  exists k, find_label pc (linearize_body f enum) = Some (linearize_instr b k).
Proof.
  induction enum; intros.
  elim H.
  case (peq a pc); intro.
  subst a. exists (linearize_body f enum).
  simpl. rewrite H0. simpl. rewrite peq_true. auto.
  assert (In pc enum). simpl in H. tauto.
  elim (IHenum pc b H1 H0). intros k FIND.
  exists k. simpl. destruct (LTL.fn_code f)!a.
  simpl. rewrite peq_false. rewrite find_label_lin_instr. auto. auto.
  auto.
Qed.

Lemma find_label_lin:
  forall f tf pc b,
  transf_function f = OK tf ->
  f.(LTL.fn_code)!pc = Some b ->
  (reachable f)!!pc = true ->
  exists k,
  find_label pc (fn_code tf) = Some (linearize_instr b k).
Proof.
  intros. monadInv H. simpl.
  rewrite find_label_add_branch. apply find_label_lin_rec.
  eapply enumerate_complete; eauto. auto.
Qed.

Lemma find_label_lin_inv:
  forall f tf pc b k,
  transf_function f = OK tf ->
  f.(LTL.fn_code)!pc = Some b ->
  (reachable f)!!pc = true ->
  find_label pc (fn_code tf) = Some k ->
  exists k', k = linearize_instr b k'.
Proof.
  intros. exploit find_label_lin; eauto. intros [k' FIND].
  exists k'. congruence.
Qed.

Lemma find_label_lin_succ:
  forall f tf s,
  transf_function f = OK tf ->
  valid_successor f s ->
  (reachable f)!!s = true ->
  exists k,
  find_label s (fn_code tf) = Some k.
Proof.
  intros. destruct H0 as [i AT].
  exploit find_label_lin; eauto. intros [k FIND].
  exists (linearize_instr i k); auto.
Qed.

(** Unique label property for linearized code. *)

Lemma label_in_add_branch:
  forall lbl s k,
  In (Llabel lbl) (add_branch s k) -> In (Llabel lbl) k.
Proof.
  intros until k; unfold add_branch.
  destruct (starts_with s k); simpl; intuition congruence.
Qed.

Lemma label_in_lin_instr:
  forall lbl k b,
  In (Llabel lbl) (linearize_instr b k) -> In (Llabel lbl) k.
Proof.
  induction b; simpl; intros;
  try (apply label_in_add_branch with n; intuition congruence);
  try (intuition congruence).
  destruct (starts_with n k); simpl in H.
  apply label_in_add_branch with n; intuition congruence.
  apply label_in_add_branch with n0; intuition congruence.
Qed.

Lemma label_in_lin_rec:
  forall f lbl enum,
  In (Llabel lbl) (linearize_body f enum) -> In lbl enum.
Proof.
  induction enum.
  simpl; auto.
  simpl. destruct (LTL.fn_code f)!a.
  simpl. intros [A|B]. left; congruence.
  right. apply IHenum. eapply label_in_lin_instr; eauto.
  intro; right; auto.
Qed.

Lemma unique_labels_add_branch:
  forall lbl k,
  unique_labels k -> unique_labels (add_branch lbl k).
Proof.
  intros; unfold add_branch.
  destruct (starts_with lbl k); simpl; intuition.
Qed.

Lemma unique_labels_lin_instr:
  forall k b,
  unique_labels k -> unique_labels (linearize_instr b k).
Proof.
  induction b; intro; simpl; auto; try (apply unique_labels_add_branch; auto).
  case (starts_with n k); simpl; apply unique_labels_add_branch; auto.
Qed.

Lemma unique_labels_lin_rec:
  forall f enum,
  list_norepet enum ->
  unique_labels (linearize_body f enum).
Proof.
  induction enum.
  simpl; auto.
  intro. simpl. destruct (LTL.fn_code f)!a.
  simpl. split. red. intro. inversion H. elim H3.
  apply label_in_lin_rec with f.
  apply label_in_lin_instr with i. auto.
  apply unique_labels_lin_instr. apply IHenum. inversion H; auto.
  apply IHenum. inversion H; auto.
Qed.

Lemma unique_labels_transf_function:
  forall f tf,
  transf_function f = OK tf ->
  unique_labels (fn_code tf).
Proof.
  intros. monadInv H. simpl.
  apply unique_labels_add_branch.
  apply unique_labels_lin_rec. eapply enumerate_norepet; eauto.
Qed.

(** Correctness of [add_branch]. *)

Lemma is_tail_find_label:
  forall lbl c2 c1,
  find_label lbl c1 = Some c2 -> is_tail c2 c1.
Proof.
  induction c1; simpl.
  intros; discriminate.
  case (is_label lbl a). intro. injection H; intro. subst c2.
  constructor. constructor.
  intro. constructor. auto.
Qed.

Lemma is_tail_add_branch:
  forall lbl c1 c2, is_tail (add_branch lbl c1) c2 -> is_tail c1 c2.
Proof.
  intros until c2. unfold add_branch. destruct (starts_with lbl c1).
  auto. eauto with coqlib.
Qed.

Lemma add_branch_correct:
  forall lbl c k s f tf sp ls m,
  transf_function f = OK tf ->
  is_tail k tf.(fn_code) ->
  find_label lbl tf.(fn_code) = Some c ->
  plus step tge (State s tf sp (add_branch lbl k) ls m)
             E0 (State s tf sp c ls m).
Proof.
  intros. unfold add_branch.
  caseEq (starts_with lbl k); intro SW.
  eapply starts_with_correct; eauto.
  eapply unique_labels_transf_function; eauto.
  apply plus_one. apply exec_Lgoto. auto.
Qed.

(** * Correctness of linearization *)

(** The proof of semantic preservation is a simulation argument
  based on diagrams of the following form:
<<
           st1 --------------- st2
            |                   |
           t|                  +|t
            |                   |
            v                   v
           st1'--------------- st2'
>>
  The invariant (horizontal lines above) is the [match_states]
  predicate defined below.  It captures the fact that the flow
  of data is the same in the source and linearized codes.
  Moreover, whenever the source state is at node [pc] in its
  control-flow graph, the transformed state is at a code
  sequence [c] that starts with the label [pc]. *)

Inductive match_stackframes: LTL.stackframe -> LTLin.stackframe -> Prop :=
  | match_stackframe_intro:
      forall res f sp pc ls tf c,
      transf_function f = OK tf ->
      (reachable f)!!pc = true ->
      valid_successor f pc ->
      is_tail c (fn_code tf) ->
      wt_function f ->
      match_stackframes
        (LTL.Stackframe res f sp ls pc)
        (LTLin.Stackframe res tf sp ls (add_branch pc c)).

Inductive match_states: LTL.state -> LTLin.state -> Prop :=
  | match_states_intro:
      forall s f sp pc ls m tf ts c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (AT: find_label pc (fn_code tf) = Some c)
        (WTF: wt_function f),
      match_states (LTL.State s f sp pc ls m)
                   (LTLin.State ts tf sp c ls m)
  | match_states_call:
      forall s f ls m tf ts,
      list_forall2 match_stackframes s ts ->
      transf_fundef f = OK tf ->
      wt_fundef f ->
      match_states (LTL.Callstate s f ls m)
                   (LTLin.Callstate ts tf ls m)
  | match_states_return:
      forall s ls m ts,
      list_forall2 match_stackframes s ts ->
      match_states (LTL.Returnstate s ls m)
                   (LTLin.Returnstate ts ls m).

Hypothesis wt_prog: wt_program prog.

Theorem transf_step_correct:
  forall s1 t s2, LTL.step ge s1 t s2 ->
  forall s1' (MS: match_states s1 s1'),
  exists s2', plus LTLin.step tge s1' t s2' /\ match_states s2 s2'.
Proof.
  induction 1; intros; try (inv MS);
  try (generalize (wt_instrs _ WTF _ _ H); intro WTI).
  (* Lnop *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT'].
  econstructor; split.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_find_label. eauto.
  econstructor; eauto.
  (* Lop *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT'].
  econstructor; split.
  eapply plus_left'.
  eapply @exec_Lop with (v := v); eauto.
  rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  traceEq.
  econstructor; eauto.
  (* Lload *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT'].
  econstructor; split.
  eapply plus_left'.
  apply exec_Lload with a.
  rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
  eauto.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  traceEq.
  econstructor; eauto.
  (* Lstore *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT'].
  econstructor; split.
  eapply plus_left'.
  apply exec_Lstore with a.
  rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
  eauto.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  traceEq.
  econstructor; eauto.
  (* Lcall *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl; auto.
  assert (VALID: valid_successor f pc'). inv WTI; auto.
  exploit find_function_translated; eauto. intros [tf' [A B]].
  econstructor; split.
  apply plus_one. eapply @exec_Lcall with (f' := tf'); eauto.
  symmetry; apply sig_preserved; auto.
  econstructor; eauto.
  constructor; auto. econstructor; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  destruct ros; simpl in H0.
  eapply Genv.find_funct_prop; eauto.
  destruct (Genv.find_symbol ge i); try discriminate.
  eapply Genv.find_funct_ptr_prop; eauto.

  (* Ltailcall *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  exploit find_function_translated; eauto. intros [tf' [A B]].
  econstructor; split.
  apply plus_one. eapply @exec_Ltailcall with (f' := tf'); eauto.
  symmetry; apply sig_preserved; auto.
  rewrite (stacksize_preserved _ _ TRF). eauto.
  econstructor; eauto.
  destruct ros; simpl in H0.
  eapply Genv.find_funct_prop; eauto.
  destruct (Genv.find_symbol ge i); try discriminate.
  eapply Genv.find_funct_ptr_prop; eauto.

  (* Lbuiltin *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT'].
  econstructor; split.
  eapply plus_left'.
  eapply exec_Lbuiltin.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  traceEq.
  econstructor; eauto.

  (* Lcond *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  destruct b.
  (* true *)
  assert (REACH': (reachable f)!!ifso = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; eauto. intros [c'' AT'].
  destruct (starts_with ifso c').
  econstructor; split.
  eapply plus_left'.
  eapply exec_Lcond_false; eauto.
  rewrite eval_negate_condition; rewrite H0; auto.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  traceEq.
  econstructor; eauto.
  econstructor; split.
  apply plus_one. eapply exec_Lcond_true; eauto.
  econstructor; eauto.
  (* false *)
  assert (REACH': (reachable f)!!ifnot = true).
  eapply reachable_successors; eauto. simpl; auto.
  exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT'].
  destruct (starts_with ifso c').
  econstructor; split.
  apply plus_one. eapply exec_Lcond_true; eauto.
  rewrite eval_negate_condition; rewrite H0; auto.
  econstructor; eauto.
  econstructor; split.
  eapply plus_left'.
  eapply exec_Lcond_false; eauto.
  eapply add_branch_correct; eauto.
  eapply is_tail_add_branch. eapply is_tail_cons_left.
  eapply is_tail_find_label. eauto.
  traceEq.
  econstructor; eauto.

  (* Ljumptable *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  assert (REACH': (reachable f)!!pc' = true).
  eapply reachable_successors; eauto. simpl. eapply list_nth_z_in; eauto.
  exploit find_label_lin_succ; eauto.
  inv WTI. apply H6. eapply list_nth_z_in; eauto.
  intros [c'' AT'].
  econstructor; split.
  apply plus_one. eapply exec_Ljumptable; eauto.
  econstructor; eauto.

  (* Lreturn *)
  destruct (find_label_lin_inv _ _ _ _ _ TRF H REACH AT) as [c' EQ].
  simpl in EQ. subst c.
  econstructor; split.
  apply plus_one. eapply exec_Lreturn; eauto.
  rewrite (stacksize_preserved _ _ TRF). eauto.
  econstructor; eauto.

  (* internal function *)
  assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true).
    apply reachable_entrypoint.
  inv H7. monadInv H6.
  exploit find_label_lin_succ; eauto. inv H1; auto. intros [c'' AT'].
  generalize EQ; intro. monadInv EQ0. econstructor; simpl; split.
  eapply plus_left'.
  eapply exec_function_internal; eauto.
  simpl. eapply add_branch_correct. eauto.
  simpl. eapply is_tail_add_branch. constructor. eauto.
  traceEq.
  econstructor; eauto.

  (* external function *)
  monadInv H6. econstructor; split.
  apply plus_one. eapply exec_function_external; eauto.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  econstructor; eauto.

  (* return *)
  inv H3. inv H1.
  exploit find_label_lin_succ; eauto. intros [c' AT].
  econstructor; split.
  eapply plus_left'.
  eapply exec_return; eauto.
  eapply add_branch_correct; eauto. traceEq.
  econstructor; eauto.
Qed.

Lemma transf_initial_states:
  forall st1, LTL.initial_state prog st1 ->
  exists st2, LTLin.initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intros [tf [A B]].
  exists (Callstate nil tf nil m0); split.
  econstructor; eauto. eapply Genv.init_mem_transf_partial; eauto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  symmetry. apply (transform_partial_program_main transf_fundef _ TRANSF).
  rewrite <- H3. apply sig_preserved. auto.
  constructor. constructor. auto.
  eapply Genv.find_funct_ptr_prop; eauto.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> LTL.final_state st1 r -> LTLin.final_state st2 r.
Proof.
  intros. inv H0. inv H. inv H4. constructor.
Qed.

Theorem transf_program_correct:
  forward_simulation (LTL.semantics prog) (LTLin.semantics tprog).
Proof.
  eapply forward_simulation_plus.
  eexact symbols_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  eexact transf_step_correct.
Qed.

End LINEARIZATION.


Require Import CertiGraph.lib.Coqlib.
Require Export VST.floyd.proofauto.
Require Import CertiGraph.mark.env_mark_bin.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.GraphBin.
Require Import CertiGraph.msl_application.Graph_Mark.
Require Import CertiGraph.msl_application.DagBin_Mark.
Require Import CertiGraph.floyd_ext.share.
Require Import CertiGraph.mark.spatial_graph_bin_mark.
Require Import VST.msl.wand_frame.
Require Import VST.floyd.reassoc_seq.
Require Import VST.floyd.field_at_wand.

Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

(* Using unit for DE and DG, inspired by Graph *)
Notation dag sh x g := (@reachable_dag_vertices_at _ _ _ _ _ _ unit unit _ mpred (@SGP pSGG_VST bool unit (sSGG_VST sh)) (SGA_VST sh) x g).
Notation Graph := (@Graph pSGG_VST bool unit unit).
#[local] Existing Instances MGS binGraph maGraph finGraph RGF.

Definition mark_spec :=
 DECLARE _mark
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [tptr (Tstruct _Node noattr)]
          PROP  (weak_valid g x)
          PARAMS (pointer_val_val x)
          GLOBALS ()
          SEP   (dag sh x g)
  POST [ Tvoid ]
      EX g': Graph,
        PROP (mark x g g')
        LOCAL()
        SEP (dag sh x g').

Definition main_spec :=
 DECLARE _main
  WITH u : globals
  PRE  [] main_pre prog tt u
  POST [ tint ] main_post prog u.

Definition Gprog : funspecs := ltac:(with_library prog [mark_spec ; main_spec]).

Lemma dag_local_facts: forall sh x (g: Graph), weak_valid g x -> dag sh x g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. destruct H.
  - simpl in H. subst x. entailer!.
  - destruct (vgamma g x) as [[d l] r] eqn:?.
    pose proof (@root_unfold _ (sSGG_VST sh) g x d l r H Heqp); clear -H0.
    simpl in *. rewrite H0. entailer!.
Qed.

Lemma body_mark: semax_body Vprog Gprog f_mark mark_spec.
Proof.
  start_function.
  remember (vgamma g x) as dlr eqn:?H.
  destruct dlr as [[d l] r].
  rename H0 into H_GAMMA_g; symmetry in H_GAMMA_g.
  rename H into H_weak_valid.

  forward_if  (* if (x == 0) *)
    (PROP  (pointer_val_val x <> nullval)
     LOCAL (temp _x (pointer_val_val x))
     SEP   (dag sh x g)).
  - apply denote_tc_test_eq_split. 2: entailer!. apply dag_local_facts; auto.
  - (* return *) forward. Exists g. entailer!. destruct x. 1: simpl in H; inversion H. apply (mark_null_refl g).
  - (* skip *) forward. entailer!.
  - Intros. assert (vvalid g x) as gx_vvalid. {
      destruct H_weak_valid; [| auto].
      unfold is_null_SGBA in H0; simpl in H0; subst x.
      exfalso. apply H. auto.
    } assert (isptr (pointer_val_val x) /\ exists b i, x = ValidPointer b i). {
      destruct x. 2: exfalso; apply H; reflexivity. split; simpl; auto.
      exists b, i. reflexivity.
    } destruct H0 as [? [b [i ?]]]. clear H0 H_weak_valid.
    pose proof (@root_unfold _ (sSGG_VST sh) g x d l r gx_vvalid).
    simpl in H0. simpl reachable_dag_vertices_at.
    erewrite H0 by eauto. Intros.
    change (vertex_at x (d, l, r)) with
        (@data_at CompSpecs sh node_type
                  (Vint (Int.repr (if d then 1 else 0)), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)).
    forward. (* root_mark = x -> m; *)
    eapply semax_pre with
        (PROP  ()
               LOCAL
               (temp _root_mark (Vint (Int.repr (if d then 1 else 0)));
                temp _x (pointer_val_val x))
               SEP  (dag sh x g)).
    1: { pose proof (@root_unfold _ (sSGG_VST sh) g x d l r gx_vvalid).
         simpl in H2. simpl reachable_dag_vertices_at.
         erewrite H2 by eauto; simpl vertex_at; entailer!.
         }
    forward_if  (* if (root_mark == 1) *)
      (PROP (d = false)
            LOCAL (temp _x (pointer_val_val x))
            SEP (dag sh x g)).
    + forward. (* return *) Exists g. entailer!.
      eapply (mark_vgamma_true_refl g); eauto.
      now destruct d.
    + forward. (* skip; *) entailer!.
      now destruct d.
    +
      pose proof (@root_unfold _ (sSGG_VST sh) g x d l r gx_vvalid).
      simpl in H2. simpl reachable_dag_vertices_at.
      erewrite H2 by eauto.
      Intros. subst d.
      change (vertex_at x (false, l, r)) with
          (@data_at CompSpecs sh node_type
                    (Vint (Int.repr 0), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)).
      forward. (* l = x -> l; *) 1: entailer!; destruct l; simpl; auto.
      forward. (* r = x -> r; *) 1: entailer!; destruct r; simpl; auto.
      forward. (* x -> d = 1; *)
      pose proof Graph_vgen_true_mark1 g x _ _ H_GAMMA_g gx_vvalid.
      apply semax_pre with
          (PROP  ()
                 LOCAL (temp _r (pointer_val_val r);
                        temp _l (pointer_val_val l);
                        temp _x (pointer_val_val x))
                 SEP (dag sh x (Graph_vgen g x true))).
      1: { pose proof (@root_update_unfold _ (sSGG_VST sh) g).
           simpl in H4. simpl reachable_dag_vertices_at.
           erewrite H4 by eauto; simpl vertex_at; entailer!. }
           forget (Graph_vgen g x true) as g1.
      assert (weak_valid g1 l) by (eapply left_weak_valid; eauto).
      (* mark(l); *)
      localize [dag sh l g1].
      forward_call (sh, g1, l).
      Intros g2.
      unlocalize [dag sh x g2] using g2 assuming H5.
      1: { subst.
           pose proof (@dag_ramify_left _ (sSGG_VST sh) g g1 (ValidPointer b i) l r gx_vvalid H_GAMMA_g H3).
           simpl reachable_dag_vertices_at in *.
           eapply H1.
      }
       assert (weak_valid g2 r) by (eapply right_weak_valid; eauto).
      (* mark(r); *)
      localize [dag sh r g2].
      forward_call (sh, g2, r).
      Intros g3.
      unlocalize [dag sh x g3] using g3 assuming H7.
      1: { subst.
           pose proof (@dag_ramify_right _ (sSGG_VST sh) g
                         _ _ _ _ _ gx_vvalid H_GAMMA_g H3 H5).
           simpl reachable_dag_vertices_at in *; eapply H1.
           }
      (* ( return; ) *)
      Exists g3. entailer!.
      apply (mark1_mark_left_mark_right g g1 g2 g3 (ValidPointer b i) l r); auto.
Qed. (* Original: 114 seconds; VST 2.*: 2.739 secs *)


Require Import VST.concurrency.dry_machine.
Require Import VST.concurrency.erased_machine.
Require Import VST.concurrency.threads_lemmas.
Require Import VST.concurrency.permissions.
Require Import VST.concurrency.semantics.
Require Import VST.concurrency.concurrent_machine.
Require Import compcert.common.Globalenvs.
Require Import compcert.lib.Axioms.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Import Concur.

Module Type MachinesSig.
  Declare Module SEM: Semantics.

  Module DryMachine := DryMachineShell SEM.
  Module ErasedMachine := ErasedMachineShell SEM.

  Module DryConc := CoarseMachine mySchedule DryMachine.
  Module FineConc := FineMachine mySchedule DryMachine.
  (** SC machine*)
  Module SC := FineMachine mySchedule ErasedMachine.

  Import DryMachine ThreadPool.
  Global Ltac pf_cleanup :=
    repeat match goal with
           | [H1: invariant ?X, H2: invariant ?X |- _] =>
             assert (H1 = H2) by (by eapply proof_irr);
               subst H2
           | [H1: mem_compatible ?TP ?M, H2: mem_compatible ?TP ?M |- _] =>
             assert (H1 = H2) by (by eapply proof_irr);
               subst H2
           | [H1: is_true (leq ?X ?Y), H2: is_true (leq ?X ?Y) |- _] =>
             assert (H1 = H2) by (by eapply proof_irr); subst H2
           | [H1: containsThread ?TP ?M, H2: containsThread ?TP ?M |- _] =>
             assert (H1 = H2) by (by eapply proof_irr); subst H2
           | [H1: containsThread ?TP ?M,
                  H2: containsThread (@updThreadC _ ?TP _ _) ?M |- _] =>
             apply cntUpdateC' in H2;
               assert (H1 = H2) by (by eapply cnt_irr); subst H2
           | [H1: containsThread ?TP ?M,
                  H2: containsThread (@updThread _ ?TP _ _ _) ?M |- _] =>
             apply cntUpdate' in H2;
               assert (H1 = H2) by (by eapply cnt_irr); subst H2
           end.

End MachinesSig.

Module Type AsmContext (SEM : Semantics)
       (Machines : MachinesSig with Module SEM := SEM).

  Import Machines.
  Parameter initU: mySchedule.schedule.

  Parameter init_mem : option Memory.Mem.mem.
  Definition init_perm  :=
    match init_mem with
    | Some m => Some (getCurPerm m, empty_map)
    | None => None
    end.

  Parameter the_ge : SEM.G.

  Definition coarse_semantics:=
    DryConc.MachineSemantics initU init_perm.

  Definition fine_semantics:=
    FineConc.MachineSemantics initU init_perm.

  Definition sc_semantics :=
    SC.MachineSemantics initU None.

  Definition tpc_init f arg := initial_core coarse_semantics 0 the_ge f arg.
  Definition tpf_init f arg := initial_core fine_semantics 0 the_ge f arg.
  Definition sc_init f arg := initial_core sc_semantics 0 the_ge f arg.

End AsmContext.


Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.finfun Ssreflect.fintype Ssreflect.ssrnat Ssreflect.eqtype Ssreflect.seq Ssreflect.tuple.
Require Import Ssreflect.path Ssreflect.fingraph  Ssreflect.finset.
Require Import x86proved.x86.procstate x86proved.x86.procstatemonad x86proved.bitsrep x86proved.bitsops x86proved.bitsprops x86proved.bitsopsprops.
Require Import x86proved.spred x86proved.septac x86proved.spec x86proved.safe x86proved.x86.basic x86proved.x86.program x86proved.x86.macros x86proved.x86.call.
Require Import x86proved.x86.instr x86proved.monad x86proved.reader x86proved.writer x86proved.x86.procstate x86proved.x86.procstatemonad x86proved.x86.mem x86proved.x86.exn x86proved.x86.eval x86proved.x86.instrcodec
               x86proved.monadinst x86proved.x86.ioaction x86proved.bitsrep x86proved.bitsops x86proved.x86.eval x86proved.x86.step x86proved.pointsto x86proved.cursor.
Require Import x86proved.x86.program x86proved.x86.programassem x86proved.x86.reg x86proved.x86.instrsyntax x86proved.x86.instrrules.
Require Import x86proved.spectac x86proved.charge.iltac x86proved.triple.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(****************************************************************)
(* C-style strings                                              *)
(****************************************************************)

Definition CString (s: seq DWORD) := all (fun x => x != #0) s.

Lemma snocCString
        (l1 : seq DWORD)(H: CString l1)
        (c : DWORD)(_ : c != #0):
  CString (l1 ++ [:: c]).
Proof.
  rewrite /CString.
  rewrite all_cat; apply /andP.
  split; first by rewrite /CString in H; exact: H.
  rewrite all_seq1.
  done.
Qed.

Lemma snocMem (lo pd: DWORD)(l1 : seq DWORD)(c: DWORD):
  pd :-> c ** lo -- pd :-> l1 |-- lo -- next (pd +# 3) :-> (cat l1 [:: c]).
Proof.
  rewrite ->seqMemIsCat.
  rewrite pairMemIsPair.
  apply lexistsR with (x := pd).
  rewrite ->seqMemIsCons.
  ssimpl. rewrite /pointsTo; apply lexistsL => q.
  rewrite -> memIsFixed. sdestruct => AP. sbazooka.
  rewrite ->seqMemIsNil. apply apart_addBn_next in AP.
 sbazooka.
Qed.

Lemma catCString (l1: seq DWORD) (H1: CString l1) l2 (H2: CString l2):
  CString (l1 ++ l2).
Proof.
   rewrite /CString.
   rewrite /CString in H1, H2.
   by rewrite all_cat H1 H2.
Qed.

Definition memToS {R} {_:MemIs R} p q (s: seq DWORD) :=
    CString s
/\\ p -- q :-> s
 ** q :-> (#0: DWORD).

Definition pointsToS {R} {_:MemIs R} p (s: seq DWORD) :=
  Exists q: DWORD, memToS p q s.

Notation "p '--' q ':-S>' x" := (memToS p q x)
    (at level 50, q at next level,  no associativity).
Notation "p ':-S>' x" := (pointsToS p x)
    (at level 50,  no associativity).

Lemma caseString_nil (q r: DWORD):
  q -- r :-S> [::] |-- q == r /\\ r :-> (#0: DWORD).
Proof.
  rewrite /memToS [CString _]/= /cat; sdestruct=> _.
  rewrite seqMemIsNil.
  sdestruct=> /eqP eq.
  sbazooka.
Qed.

Lemma caseString_cons (q r: DWORD)(c: DWORD)(cs: seq DWORD) :
  q -- r :-S> [:: c & cs] |-- (c != #0) /\\ q :-> c ** next (q +# 3) -- r :-S> cs.
Proof.
  rewrite /memToS.
  rewrite /CString /all-/all.
  rewrite seqMemIsCons.
  sdestruct=> /andP [cn0 cstr].
  sdestruct=> q'.
  ssplit.
    * exact: cn0.
    * sbazooka.
      rewrite ->memIsFixed; sdestruct=> H. apply apart_addBn_next in H. rewrite H.
      rewrite /pointsTo.
      sbazooka.
Qed.

Lemma splitString (q r: DWORD)(l2: seq DWORD):
     q -- r :-S> l2
 |--   ((l2 == [::]) && (q == r) /\\ q :-> (#0: DWORD))
  \\// (Exists c: DWORD, Exists cs: seq DWORD,
        ((l2 == [:: c & cs])
      && (c != (#0: DWORD))
      /\\ q :-> c ** next (q +# 3) -- r :-S>  cs)).
Proof.
  case: l2.
  * (* CASE: l2 =~ [::] *)
    apply lorR1.
    rewrite ->caseString_nil.
    sdestruct=> /eqP <-.
    sbazooka.
    by apply /andP; split; done.

  * (* CASE: l2 =~ [:: c & cs ] *)
    move=> c cs.
    apply lorR2.
    apply lexistsR with (x := c);
      apply lexistsR with (x := cs).
    rewrite ->caseString_cons.
    sbazooka.
    by apply /andP; split; done.
Qed.

Lemma emptyString (lo hi: DWORD)(l: seq DWORD)(_ : CString l):
  hi :-> (#0: DWORD) ** lo -- hi :-> l  |-- lo -- hi :-S> l.
Proof.
  rewrite /memToS.
  ssplit; first by done.
  sbazooka.
Qed.

Lemma catString (lo hi pd: DWORD)(l1 l2: seq DWORD)(_: CString l1):
  lo -- pd :-> l1 ** pd -- hi :-S> l2
     |-- lo -- hi :-S> (cat l1 l2).
Proof.
  rewrite /memToS.
  rewrite ->seqMemIsCat. rewrite pairMemIsPair.
  sdestruct=> l2IsString; ssplit; last by sbazooka.
  rewrite /CString.
  rewrite all_cat; apply /andP; split; by exact.
Qed.

Lemma memIsNextS (p q q' : DWORD) l : next p = mkCursor q' ->
  next p -- q :-S> l |-- p+#1 -- q :-S> l.
Proof. move => H0.
destruct l.
+ rewrite /memToS !seqMemIsNil.
  sdestructs => H H'. sbazooka. by rewrite (nextIsInc H').
+ rewrite /memToS !seqMemIsCons.
  sdestructs => H H'. sbazooka. have H1 := nextIsInc H0. by  rewrite H0 -H1.
Qed.