(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it 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 program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From compcert Require Import AST Integers Values Memory.

From bpf.comm Require Import BinrBPF Monad.
From bpf.verifier.comm Require Import state.
From Coq Require Import ZArith.

Definition eval_ins_len : M state.state nat := fun st => Some (eval_ins_len st, st).

Definition eval_ins (idx: int) : M state.state int64 := fun st =>
  if (Int.cmpu Clt idx (Int.repr (Z.of_nat (ins_len st)))) then
    Some (eval_ins idx st, st)
  else
    None.


From stdpp Require Import finite decidable.
From iris.prelude Require Import options.
From iris.algebra Require Import excl_auth.
From iris.bi Require Import bi.
From iris.base_logic.lib Require Import invariants.
From iris.proofmode Require Import tactics.
From trillium.prelude Require Export finitary quantifiers sigma classical_instances.
From trillium.fairness Require Import fairness fair_termination fairness_finiteness.
From trillium.program_logic Require Export weakestpre.
From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode.
From trillium.fairness.heap_lang Require Import notation.

Import derived_laws_later.bi.

Set Default Proof Using "Type".

(** The program verify liveness for *)
(** Recursion is "off by one" to allow immediate termination after storing 0 *)
Definition decr_loop_prog (l : loc) : val :=
  rec: "go" <> :=
    let: "x" := !#l in
    if: "x" = #1 then #l <- ("x" - #1)
    else #l <- ("x" - #1);; "go" #().
Definition choose_nat_prog (l : loc) : val :=
  λ: <>,
     #l <- (ChooseNat + #1);;
     decr_loop_prog l #().

(** The model state *)
Inductive CN := Start | N (n : nat).

(** A mapping of model state to "program state" *)
Definition CN_Z (cn : CN) : Z :=
  match cn with
  | Start => -1
  | N n => n
  end.

#[global] Instance CN_eqdec: EqDecision CN.
Proof. solve_decision. Qed.

#[global] Instance CN_inhabited: Inhabited CN.
Proof. exact (populate Start). Qed.

Inductive cntrans : CN → option unit → CN -> Prop :=
| start_trans n : cntrans Start (Some ()) (N n)
| decr_trans n : cntrans (N $ S n) (Some ()) (N n).

(* Free construction of the active labels on each state by [cntrans] *)
Definition cn_live_roles (cn : CN) : gset unit :=
  match cn with N 0 => ∅ | _ => {[ () ]} end.

Lemma cn_live_spec_holds s ρ s' : cntrans s (Some ρ) s' -> ρ ∈ cn_live_roles s.
Proof. destruct s; [set_solver|]. destruct n; [|set_solver]. inversion 1. Qed.

Definition cn_fair_model : FairModel.
Proof.
  refine({|
            fmstate := CN;
            fmrole := unit;
            fmtrans := cntrans;
            live_roles := cn_live_roles;
            fm_live_spec := cn_live_spec_holds;
          |}).
Defined.

(** Show that the model is fairly terminating *)

Inductive cn_order : CN → CN → Prop :=
  | cn_order_Start cn : cn_order cn Start
  | cn_order_N (n1 n2 : nat) : n1 ≤ n2 → cn_order (N n1) (N n2).

Local Instance the_order_po: PartialOrder cn_order.
Proof.
  split.
  - split.
    + by intros []; constructor.
    + intros [] [] [] Hc12 Hc23; try constructor.
      * inversion Hc23.
      * inversion Hc12.
      * inversion Hc23.
      * inversion Hc12. inversion Hc23. simplify_eq. lia.
  - intros [] []; inversion 1; simplify_eq; try eauto; try inversion 1.
    simplify_eq. f_equal. lia.
Qed.

Definition cn_decreasing_role (s : fmstate cn_fair_model) : unit :=
  match s with | _ => () end.

#[local] Program Instance cn_model_terminates :
  FairTerminatingModel cn_fair_model :=
  {|
    ftm_leq := cn_order;
    ftm_decreasing_role := cn_decreasing_role;
  |}.
Next Obligation.
  assert (∀ n, Acc (strict cn_order) (N n)).
  { intros n.
    induction n as [n IHn] using lt_wf_ind.
    constructor. intros cn [Hcn1 Hcn2].
    inversion Hcn1 as [|n1 n2]; simplify_eq.
    destruct (decide (n = n1)) as [->|Hneq]; [done|].
    apply IHn. lia. }
  constructor. intros [] [Hc1 Hc2]; [|done].
  inversion Hc1; simplify_eq. done.
Qed.
Next Obligation.
  intros cn [ρ' [cn' Htrans]].
  split.
  - rewrite /cn_decreasing_role. simpl. rewrite /cn_live_roles.
    destruct cn; [set_solver|].
    destruct n; [inversion Htrans|set_solver].
  - intros cn'' Htrans'.
    destruct cn.
    + split; [constructor|].
      intros Hrel. inversion Hrel; simplify_eq. inversion Htrans'.
    + split.
      * destruct cn''.
        -- inversion Htrans'.
        -- inversion Htrans'; simplify_eq. constructor. lia.
      * intros Hrel.
        inversion Htrans'; simplify_eq.
        inversion Hrel; simplify_eq.
        lia.
Qed.
Next Obligation. done. Qed.
Next Obligation.
  intros cn1 ρ cn2 Htrans.
  destruct cn1.
  - inversion Htrans; simplify_eq. constructor.
  - inversion Htrans; simplify_eq. constructor. lia.
Qed.

Definition cn_model : LiveModel heap_lang cn_fair_model :=
  {| lm_fl _ := 40%nat |}.

(** Determine additional restriction on relation to obtain finite branching *)
Definition ξ_cn (l:loc) (extr : execution_trace heap_lang)
           (auxtr : finite_trace cn_fair_model (option unit)) :=
  ∃ (cn:CN), (trace_last extr).2.(heap) !!! l = #(CN_Z cn) ∧
             (trace_last auxtr) = cn.

(** Verify that the program refines the model *)

(* Set up necessary RA constructions *)
Class choose_natG Σ := ChooseNatG { choose_nat_G :> inG Σ (excl_authR ZO) }.

Definition choose_natΣ : gFunctors :=
  #[ heapΣ cn_fair_model; GFunctor (excl_authR ZO) ].

Global Instance subG_choosenatΣ {Σ} : subG choose_natΣ Σ → choose_natG Σ.
Proof. solve_inG. Qed.

Definition Ns := nroot .@ "choose_nat".

Section proof.
  Context `{!heapGS Σ cn_model, choose_natG Σ}.

  (** Determine invariant so we can eventually derive ξ_cn from it *)
  Definition choose_nat_inv_inner (γ : gname) (l:loc) : iProp Σ :=
    ∃ (cn:CN), frag_model_is cn ∗ l ↦ #(CN_Z cn) ∗ own γ (●E (CN_Z cn)).

  Definition choose_nat_inv (γ : gname) (l:loc) :=
    inv Ns (choose_nat_inv_inner γ l).

  Lemma decr_loop_spec γ tid l (n:nat) (f:nat) :
    7 ≤ f → f ≤ 38 →
    choose_nat_inv γ l -∗
    {{{ has_fuel tid () f ∗ frag_free_roles_are ∅ ∗
        own γ (◯E (Z.of_nat (S n))) }}}
      decr_loop_prog l #() @ tid ; ⊤
    {{{ RET #(); tid ↦M ∅ }}}.
  Proof.
    iIntros (Hle1 Hle2) "#IH".
    iIntros "!>" (Φ) "(Hf & Hr & Hm) HΦ".
    iInduction n as [|n] "IHn".
    { wp_lam.
      (* Load - with invariant *)
      wp_bind (Load _).
      iApply wp_atomic.
      iInv Ns as ">HI" "Hclose".
      iDestruct "HI" as (cn) "(Hs & Hl & Hcn)".
      iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L.
      iModIntro.
      wp_load.
      iModIntro.
      iMod ("Hclose" with "[Hs Hl Hcn]") as "_"; [ iExists _; iFrame | ].
      iModIntro.
      rewrite Hvalid. clear cn Hvalid.
      (* Store - with invariant *)
      wp_pures.
      replace (Z.of_nat 1 - 1)%Z with 0%Z by lia.
      wp_bind (Store _ _).
      iApply wp_atomic.
      iInv Ns as ">HI" "Hclose".
      iDestruct "HI" as (cn) "(Hs & Hl & Hcn)".
      iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L.
      iModIntro.
      assert (cn = N 1) as ->.
      { destruct cn; inversion Hvalid. by simplify_eq. }
      (* Update the model state to maintain program correspondence *)
      iApply (wp_store_step_singlerole _ _ (():fmrole cn_fair_model) (f - 7) (f-3)
               with "[$Hl $Hs $Hr Hf]").
      { simpl. lia. }
      { constructor. }
      { set_solver. }
      { replace (f - 1 - 1 - 1 - 1 - 1 - 1 - 1)%nat with (f - 7)%nat by lia.
        by rewrite has_fuel_fuels. }
      iIntros "!> (Hl & Hs & Hr & Hf)".
      iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]".
      { apply (excl_auth_update _ _ 0%Z). }
      iMod ("Hclose" with "[Hs Hl Hcn]") as "_".
      { iExists (N 0). iFrame. }
      iModIntro.
      simpl.
      destruct (decide (() ∈ ∅)); [set_solver|].
      by iApply "HΦ". }
    wp_lam.
    (* Load - with invariant *)
    wp_bind (Load _).
    iApply wp_atomic.
    iInv Ns as ">HI" "Hclose".
    iModIntro.
    iDestruct "HI" as (cn) "(Hs & Hl & Hcn)".
    wp_load.
    iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L.
    iModIntro. iMod ("Hclose" with "[Hs Hl Hcn]") as "_".
    { iExists _. iFrame. }
    iModIntro.
    rewrite Hvalid. clear cn Hvalid.
    wp_pures.
    case_bool_decide as Heq; [inversion Heq; lia|clear Heq].
    wp_pures.
    replace (Z.of_nat (S (S n))  - 1)%Z with (Z.of_nat (S n)) %Z by lia.
    (* Store - with invariant *)
    wp_bind (Store _ _).
    iApply wp_atomic.
    iInv Ns as ">HI" "Hclose".
    iModIntro.
    iDestruct "HI" as (cn) "(Hs & Hl & Hcn)".
    iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L.
    assert (cn = N (S (S n))) as ->.
    { destruct cn; inversion Hvalid. by simplify_eq. }
    (* Update the model state to maintain program correspondence *)
    iApply (wp_store_step_singlerole _ _ (():fmrole cn_fair_model) (f - 7)
                                     (f+2) with "[$Hl $Hs $Hr Hf]").
    { simpl. lia. }
    { constructor. }
    { set_solver. }
    { replace (f - 1 - 1 - 1 - 1 - 1 - 1 - 1)%nat with (f - 7)%nat by lia.
      rewrite has_fuel_fuels. done. }
    iIntros "!> (Hl & Hs & Hr & Hf)".
    iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]".
    { apply (excl_auth_update _ _ (Z.of_nat (S n))%Z). }
    iMod ("Hclose" with "[Hs Hl Hcn]") as "_".
    { iExists (N (S n)). iFrame. }
    iModIntro.
    simpl. destruct (decide (() ∈ {[()]})); [|set_solver].
    wp_pures.
    replace (f + 2 - 1 - 1)%nat with f by lia.
    by iApply ("IHn" with "Hf Hr Hm").
  Qed.

  Lemma choose_nat_spec γ l tid (f:nat) :
    12 ≤ f → f ≤ 40 →
    choose_nat_inv γ l -∗
    {{{ has_fuel tid () f ∗ frag_free_roles_are ∅ ∗ own γ (◯E (-1)%Z) }}}
      choose_nat_prog l #() @ tid
    {{{ RET #(); tid ↦M ∅ }}}.
  Proof.
    iIntros (Hle1 Hle2) "#IH".
    iIntros "!>" (Φ) "(Hf & Hr & Hm) HΦ".
    wp_lam.
    wp_bind ChooseNat.
    iApply (wp_choose_nat_nostep _ _ _ {[() := (f - 2)%nat]} with "[Hf]").
    { set_solver. }
    { rewrite -has_fuel_fuels_S has_fuel_fuels.
      replace (S (f - 2))%nat with (f - 1)%nat by lia. done. }
    iIntros "!>" (n) "Hf".
    wp_pures.
    (* Store - with invariant *)
    wp_bind (Store _ _).
    iApply wp_atomic.
    iInv Ns as ">HI" "Hclose".
    iModIntro.
    iDestruct "HI" as (cn) "(Hs & Hl & Hcn)".
    iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L.
    assert (cn = Start) as ->.
    { destruct cn; inversion Hvalid; [done|]. lia. }
    (* Update the model state to maintain program correspondence *)
    iApply (wp_store_step_singlerole _ _ (():fmrole cn_fair_model)
                                     (f - 3) (f-2) _ _ (N (S n))
             with "[$Hl $Hs $Hr Hf]").
    { simpl. lia. }
    { constructor. }
    { set_solver. }
    { replace (f - 2 - 1)%nat with (f - 3)%nat by lia.
      rewrite has_fuel_fuels. done. }
    iIntros "!> (Hl & Hs & Hr & Hf)".
    iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]".
    { apply (excl_auth_update _ _ (Z.of_nat (S n))%Z). }
    iMod ("Hclose" with "[Hs Hl Hcn]") as "_".
    { replace (Z.of_nat n + 1)%Z with (Z.of_nat (S n)) by lia.
      iExists (N (S n)). iFrame. }
    iModIntro.
    simpl. destruct (decide (() ∈ {[()]})); [|set_solver].
    wp_pures.
    rewrite -has_fuel_fuels.
    by iApply (decr_loop_spec with "IH [$Hm $Hr $Hf]"); [lia|lia|].
  Qed.

End proof.

(** Construct inverse mapping of program state to model state,
    to compute finite relation *)
Definition Z_CN (v : val) : CN :=
  match v with
  | LitV (LitInt z) =>
      match z with
      | Z0 => N 0
      | Zpos p => N (Pos.to_nat p)
      | Zneg _ => Start         (* Error case when z < -1 *)
      end
  | _ => Start                  (* Error case *)
  end.

Lemma Z_CN_CN_Z cn : Z_CN #(CN_Z cn) = cn.
Proof. destruct cn; [done|]; destruct n; [done|]=> /=; f_equal; lia. Qed.

(** Derive that program is related to model by
    [sim_rel_with_user cn_model (ξ_cn l) using Trillium adequacy *)
Lemma choose_nat_sim l :
  continued_simulation
    (sim_rel_with_user cn_model (ξ_cn l))
    (trace_singleton ([choose_nat_prog l #()],
                        {| heap := {[l:=#-1]};
                           used_proph_id := ∅ |}))
    (trace_singleton (initial_ls (LM := cn_model) Start 0%nat)).
Proof.
  assert (heapGpreS choose_natΣ cn_model) as HPreG.
  { apply _. }
  eapply (strong_simulation_adequacy
            choose_natΣ _ NotStuck _ _ _ ∅); [|set_solver|].
  { clear.
    apply rel_finitary_sim_rel_with_user_ξ.
    intros extr atr c' oζ.
    eapply finite_smaller_card_nat=> /=.
    eapply (in_list_finite [(Z_CN (heap c'.2 !!! l), None);
                            (Z_CN (heap c'.2 !!! l), Some ())]).
    (* TODO: Figure out why this does not unify with typeclass *)
    Unshelve. 2: intros x; apply make_proof_irrel.
    intros [cn o] [cn' [Hextr Hatr]].
    rewrite Hextr Z_CN_CN_Z -Hatr. destruct o; [destruct u|]; set_solver. }
  iIntros (?) "!> Hσ Hs Hr Hf".
  iMod (own_alloc) as (γ) "He"; [apply (excl_auth_valid (-1)%Z)|].
  iDestruct "He" as "[He● He○]".
  iMod (inv_alloc Ns ⊤ (choose_nat_inv_inner γ l) with "[He● Hσ Hs]") as "#IH".
  { iIntros "!>". iExists _. iFrame. by rewrite big_sepM_singleton. }
  iModIntro.
  iSplitL.
  { iApply (choose_nat_spec _ _ _ 40 with "IH [Hr Hf He○]");
      [lia|lia| |by eauto]=> /=.
    replace (∅ ∖ {[()]}) with (∅:gset unit) by set_solver.
    rewrite has_fuel_fuels gset_to_gmap_set_to_map. iFrame. }
  iIntros (ex atr c Hvalid Hex Hatr Hends Hξ Hstuck) "Hσ".
  iInv Ns as ">H".
  iDestruct "H" as (cn) "(Hf & Hl & H●)".
  iDestruct "Hσ" as (Hvalid') "[Hσ Hs]".
  iDestruct (gen_heap_valid with "Hσ Hl") as %Hlookup%lookup_total_correct.
  iDestruct (model_agree' with "Hs Hf") as %Hlast.
  iModIntro. iSplitL; [by iExists _; iFrame|].
  iApply fupd_mask_intro; [set_solver|]. iIntros "_".
  iPureIntro. exists cn.
  split; [done|].
  subst. by destruct atr.
Qed.

Theorem choose_nat_terminates l extr :
  trfirst extr = ([choose_nat_prog l #()],
                    {| heap := {[l:=#-1]};
                      used_proph_id := ∅ |}) →
  extrace_fairly_terminating extr.
Proof.
  intros Hexfirst.
  eapply heap_lang_continued_simulation_fair_termination; eauto.
  rewrite Hexfirst. eapply choose_nat_sim.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*           Layers of PM: Refinement Proof for PKContext              *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MPTInit layer and MPTBit layer*)
Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import LoadStoreSem2.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.
(*Require Import AsmImplTactic.*)
Require Import LayerCalculusLemma.
Require Import AbstractDataType.

Require Import PKContext.
Require Import KContextGenSpec.

(** * Definition of the refinement relation*)
Section Refinement.

  Local Open Scope string_scope.
  Local Open Scope error_monad_scope.
  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Notation HDATA := RData.
  Notation LDATA := RData.

  Notation HDATAOps := (cdata (cdata_ops := mshareintro_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := mshareintro_data_ops) LDATA).

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    (** ** Definition the refinement relation: relate_RData + match_RData *)
    Section REFINEMENT_REL.

        (** Relation between the kernel context pool and the underline memory*)
        Inductive match_KCtxtPool: stencil -> KContextPool -> mem -> meminj -> Prop :=
        | MATCH_KCTXTPOOL:
            forall kcp m b s f,
              (forall ofs,
                 0<= ofs < num_proc ->
                 forall n r,
                   ZtoPreg n = Some r
                   -> (exists v,
                         Mem.load Mint32 m b (ofs * 24 + n * 4) = Some v /\
                         Mem.valid_access m Mint32 b (ofs * 24 + n * 4) Writable /\
                         val_inject f (Val.load_result Mint32 (Pregmap.get r (ZMap.get ofs kcp))) v))
              -> find_symbol s KCtxtPool_LOC = Some b
              -> match_KCtxtPool s kcp m f.

        (** Relation between the new raw data at the higher layer with the mememory at lower layer*)
        Inductive match_RData: stencil -> HDATA -> mem -> meminj -> Prop :=
        | MATCH_RDATA:
            forall hadt m s f,
              match_KCtxtPool s (kctxt hadt) m f
              -> match_RData s hadt m f.

        (** Relation between raw data at two layers*)
        Record relate_RData (f: meminj) (hadt: HDATA) (ladt: LDATA) :=
          mkrelate_RData {
              flatmem_re: FlatMem.flatmem_inj (HP hadt) (HP ladt);
              vmxinfo_re: vmxinfo hadt = vmxinfo ladt;
              devout_re: devout hadt = devout ladt;
              CR3_re:  CR3 hadt = CR3 ladt;
              ikern_re: ikern hadt = ikern ladt;
              pg_re: pg hadt = pg ladt;
              ihost_re: ihost hadt = ihost ladt;
              AC_re: AC hadt = AC ladt;
              ti_fst_re: (fst (ti hadt)) = (fst (ti ladt));
              ti_snd_re: val_inject f (snd (ti hadt)) (snd (ti ladt));
              LAT_re: LAT hadt = LAT ladt;
              nps_re: nps hadt = nps ladt;
              init_re: init hadt = init ladt;

              pperm_re: pperm ladt = pperm hadt;
              PT_re:  PT ladt = PT hadt;
              ptp_re: ptpool ladt = ptpool hadt;
              idpde_re: idpde ladt = idpde hadt;
              ipt_re: ipt ladt = ipt hadt;
              smspool_re: smspool ladt = smspool hadt
            }.

        Global Instance rel_ops: CompatRelOps HDATAOps LDATAOps :=
          {
            relate_AbData s f d1 d2 := relate_RData f d1 d2;
            match_AbData s d1 m f := match_RData s d1 m f;
            new_glbl := KCtxtPool_LOC :: nil
          }.

    End REFINEMENT_REL.

    (** ** Properties of relations*)
    Section Rel_Property.

      Lemma inject_match_correct:
        forall s d1 m2 f m2' j,
          match_RData s d1 m2 f ->
          Mem.inject j m2 m2' ->
          inject_incr (Mem.flat_inj (genv_next s)) j ->
          match_RData s d1 m2' (compose_meminj f j).
      Proof.
        inversion 1; subst; intros.
        inv H0.
        assert (HFB0: j b = Some (b, 0)).
        {
          eapply stencil_find_symbol_inject'; eauto.
        }
        econstructor; eauto; intros.
        econstructor; eauto; intros.
        specialize (H3 _ H0 _ _ H5).
        destruct H3 as [v1[HL1[HV1 HM]]].
        specialize (Mem.load_inject _ _  _ _ _ _ _ _ _ H1 HL1 HFB0).
        repeat rewrite Z.add_0_r.
        intros [v1'[HLD1' HV1']].
        refine_split'; eauto.
        specialize(Mem.valid_access_inject _ _  _ _ _ _ _ _ _ HFB0 H1 HV1).
        rewrite Z.add_0_r; trivial.
        eapply val_inject_compose; eauto.
      Qed.

      Lemma store_match_correct:
        forall s abd m0 m0' f b2 v v' chunk,
          match_RData s abd m0 f ->
          (forall i b,
             In i new_glbl ->
             find_symbol s i = Some b -> b <> b2) ->
          Mem.store chunk m0 b2 v v' = Some m0' ->
          match_RData s abd m0' f.
      Proof.
        intros. inv H. inv H2.
        econstructor; eauto.
        econstructor; eauto.
        intros. specialize (H _ H2 _ _ H4).
        destruct H as [v1[HL1[HV1 HM]]].
        eapply H0 in H3; simpl; eauto.
        repeat rewrite (Mem.load_store_other  _ _ _ _ _ _ H1); auto.
        refine_split'; eauto;
        eapply Mem.store_valid_access_1; eauto.
      Qed.

      Lemma storebytes_match_correct:
        forall s abd m0 m0' f b2 v v',
          match_RData s abd m0 f ->
          (forall i b,
             In i new_glbl ->
             find_symbol s i = Some b -> b <> b2) ->
          Mem.storebytes m0 b2 v v' = Some m0' ->
          match_RData s abd m0' f.
      Proof.
        intros. inv H. inv H2.
        econstructor; eauto.
        econstructor; eauto.
        intros. specialize (H _ H2 _ _ H4).
        destruct H as [v1[HL1[HV1 HM]]].
        eapply H0 in H3; simpl; eauto.
        repeat rewrite (Mem.load_storebytes_other _ _ _ _ _ H1); eauto.
        refine_split'; eauto;
        eapply Mem.storebytes_valid_access_1; eauto.
      Qed.

      Lemma free_match_correct:
        forall s abd m0 m0' f ofs sz b2,
          match_RData s abd m0 f->
          (forall i b,
             In i new_glbl ->
             find_symbol s i = Some b -> b <> b2) ->
          Mem.free m0 b2 ofs sz = Some m0' ->
          match_RData s abd m0' f.
      Proof.
        intros; inv H; inv H2.
        econstructor; eauto.
        econstructor; eauto.
        intros. specialize (H _ H2 _ _ H4).
        destruct H as [v1[HL1[HV1 HM]]].
        eapply H0 in H3; simpl; eauto.
        repeat rewrite (Mem.load_free _ _ _ _ _ H1); auto.
        refine_split'; eauto;
        eapply Mem.valid_access_free_1; eauto.
      Qed.

      Lemma alloc_match_correct:
        forall s abd m'0  m'1 f f' ofs sz b0 b'1,
          match_RData s abd m'0 f->
          Mem.alloc m'0 ofs sz = (m'1, b'1) ->
          f' b0 = Some (b'1, 0%Z) ->
          (forall b : block, b <> b0 -> f' b = f b) ->
          inject_incr f f' ->
          (forall i b,
             In i new_glbl ->
             find_symbol s i = Some b -> b <> b0) ->
          match_RData s abd m'1 f'.
      Proof.
        intros. rename H1 into HF1, H2 into HB. inv H; inv H1.
        econstructor; eauto.
        econstructor; eauto.
        intros. specialize (H _ H1 _ _ H5).
        destruct H as [v1[HL1[HV1 HM]]].
        refine_split'; eauto;
        try (apply (Mem.load_alloc_other _ _ _ _ _ H0));
        try (eapply Mem.valid_access_alloc_other); eauto.
      Qed.

      (** Prove that after taking one step, the refinement relation still holds*)
      Lemma relate_incr:
        forall abd abd' f f',
          relate_RData f abd abd'
          -> inject_incr f f'
          -> relate_RData f' abd abd'.
      Proof.
        inversion 1; subst; intros; inv H; constructor; eauto.
      Qed.

      Lemma relate_kernel_mode:
        forall abd abd' f,
          relate_RData f abd abd'
          -> (kernel_mode abd <-> kernel_mode abd').
      Proof.
        inversion 1; simpl; split; congruence.
      Qed.

      Lemma relate_observe:
        forall p abd abd' f,
          relate_RData f abd abd' ->
          observe p abd = observe p abd'.
      Proof.
        inversion 1; simpl; unfold ObservationImpl.observe; congruence.
      Qed.

      Global Instance rel_prf: CompatRel HDATAOps LDATAOps.
      Proof.
        constructor.
        - apply inject_match_correct.
        - apply store_match_correct.
        - apply alloc_match_correct.
        - apply free_match_correct.
        - apply storebytes_match_correct.
        - intros. eapply relate_incr; eauto.
        - intros; eapply relate_kernel_mode; eauto.
        - intros; eapply relate_observe; eauto.
      Qed.

    End Rel_Property.

    (** * Proofs the one-step forward simulations for the low level specifications*)
    Section OneStep_Forward_Relation.

      Ltac pattern2_refinement_simpl:=
        pattern2_refinement_simpl' (@relate_AbData).

      Section FRESH_PRIM.

        Lemma kctxt_ra_spec_ref:
          compatsim (crel HDATA LDATA) PKContext.kctxt_ra_compatsem
                    kctxt_ra_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          assert(HOS: kernel_mode d2 /\ 0 <= Int.unsigned n < num_proc).
          {
            simpl; inv match_related.
            unfold kctxt_ra_spec in *.
            subdestruct. inv H7.
            refine_split'; trivial; try congruence. omega.
          }
          destruct HOS as [Hkern HOS].
          inv H. rename H0 into HMem.
          assert (HOS': ZtoPreg 5 = Some RA) by reflexivity.
          destruct (HMem _ HOS _ _ HOS') as [v1[HL1[HV1 HM]]].
          specialize (Mem.valid_access_store _ _ _ _ (Vptr b ofs) HV1); intros [m' HST].
          assert(HFB: ι b = Some (b, 0)).
          {
            destruct H5 as [fun_id Hsymbol].
            eapply stencil_find_symbol_inject'; eauto.
          }
          refine_split.
          - econstructor; eauto.
            instantiate (2:= m').
            instantiate (1:= d2).
            simpl in HST; simpl; lift_trivial. subrewrite'.
          - constructor.
          - rename H7 into Hspec.
            unfold kctxt_ra_spec in Hspec.
            pose proof match_related as match_relate'.
            inv match_related.
            subdestruct. inv Hspec.
            split; eauto; pattern2_refinement_simpl.
            econstructor; simpl; eauto.
            econstructor; eauto; intros.
            destruct (zeq ofs0 (Int.unsigned n)); subst.
            + (* ofs0 = Int.unsigned n *)
              destruct (zeq n0 5); subst.
              * (* n0 = 5  *)
                refine_split'; eauto;
                try eapply Mem.store_valid_access_1; eauto.
                eapply Mem.load_store_same; eauto.
                repeat rewrite ZMap.gss. inv H0.
                rewrite Pregmap.gsspec. simpl.
                econstructor; eauto.
                rewrite Int.add_zero; trivial.
              * (* n0 <> 5 *)
                specialize (HMem _ H _ _ H0).
                destruct HMem as [v1'[HL1'[HV1' HM']]].
                refine_split'; eauto;
                try eapply Mem.store_valid_access_1; eauto.
                rewrite <- (Mem.load_store_other  _ _ _ _ _ _ HST) in HL1'; eauto.
                simpl; right. destruct (zlt n0 5); [left; omega|right; omega].
                rewrite ZMap.gss.
                rewrite Pregmap.gsspec.
                destruct (Pregmap.elt_eq r RA); subst; auto.
                apply ZtoPreg_correct in H0.
                inv H0. omega.
            + (* ofs0 <> Int.unsigned n *)
              specialize (HMem _ H _ _ H0).
              destruct HMem as [v1'[HL1'[HV1' HM']]].
              refine_split'; eauto;
              try eapply Mem.store_valid_access_1; eauto.
              rewrite <- (Mem.load_store_other  _ _ _ _ _ _ HST) in HL1'; eauto.
              simpl; right. apply ZtoPreg_range in H0.
              destruct (zlt ofs0 (Int.unsigned n)); [left; omega|right; omega].
              rewrite ZMap.gso; trivial.
          - apply inject_incr_refl.
        Qed.

        Lemma kctxt_sp_spec_ref:
          compatsim (crel HDATA LDATA) PKContext.kctxt_sp_compatsem
                    kctxt_sp_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          assert(HOS: kernel_mode d2 /\ 0 <= Int.unsigned n < num_proc).
          {
            simpl; inv match_related.
            unfold kctxt_sp_spec in *.
            subdestruct. inv H8.
            refine_split'; trivial; try congruence. omega.
          }
          destruct HOS as [Hkern HOS].
          inv H. rename H0 into HMem.
          assert (HOS': ZtoPreg 0 = Some (IR ESP)) by reflexivity.
          destruct (HMem _ HOS _ _ HOS') as [v1[HL1[HV1 HM]]].
          specialize (Mem.valid_access_store _ _ _ _ (Vptr b ofs) HV1); intros [m' HST].
          assert(HFB: ι b = Some (b, 0)).
          {
            destruct H6 as [fun_id Hsymbol].
            eapply stencil_find_symbol_inject'; eauto.
          }
          refine_split.
          - econstructor; eauto.
            instantiate (2:= m').
            instantiate (1:= d2).
            simpl in HST; simpl; lift_trivial.
            replace (Int.unsigned n * 24) with (Int.unsigned n * 24 + 0) by omega.
            subrewrite'.
          - constructor.
          - rename H8 into Hspec.
            unfold kctxt_sp_spec in Hspec.
            pose proof match_related as match_relate'.
            inv match_related.
            subdestruct. inv Hspec.
            split; eauto; pattern2_refinement_simpl.
            econstructor; simpl; eauto.
            econstructor; eauto; intros.
            destruct (zeq ofs0 (Int.unsigned n)); subst.
            + (* ofs0 = Int.unsigned n *)
              destruct (zeq n0 0); subst.
              * (* n0 = 0 *)
                refine_split'; eauto;
                try eapply Mem.store_valid_access_1; eauto.
                eapply Mem.load_store_same; eauto.
                repeat rewrite ZMap.gss. inv H0.
                rewrite Pregmap.gsspec. simpl.
                econstructor; eauto.
                rewrite Int.add_zero; trivial.
              * (* n0 <> 0 *)
                specialize (HMem _ H _ _ H0).
                destruct HMem as [v1'[HL1'[HV1' HM']]].
                refine_split'; eauto;
                try eapply Mem.store_valid_access_1; eauto.
                rewrite <- (Mem.load_store_other  _ _ _ _ _ _ HST) in HL1'; eauto.
                simpl; right. destruct (zlt n0 0); [left; omega|right; omega].
                rewrite ZMap.gss.
                rewrite Pregmap.gsspec.
                destruct (Pregmap.elt_eq r ESP); subst; auto.
                apply ZtoPreg_correct in H0.
                inv H0. omega.
            + (* ofs0 <> Int.unsigned n *)
              specialize (HMem _ H _ _ H0).
              destruct HMem as [v1'[HL1'[HV1' HM']]].
              refine_split'; eauto;
              try eapply Mem.store_valid_access_1; eauto.
              rewrite <- (Mem.load_store_other  _ _ _ _ _ _ HST) in HL1'; eauto.
              simpl; right. apply ZtoPreg_range in H0.
              destruct (zlt ofs0 (Int.unsigned n)); [left; omega|right; omega].
              rewrite ZMap.gso; trivial.
          - apply inject_incr_refl.
        Qed.

        Lemma kctxt_switch_spec_ref:
          compatsim (crel HDATA LDATA)
                    (primcall_kctxt_switch_compatsem kctxt_switch_spec)
                    kctxt_switch_spec_low.
        Proof.
          compatsim_simpl (@match_AbData). intros.
          inv match_extcall_states.
          unfold kctxt_switch_spec in *.
          subdestruct.
          inv match_match. inv H.
          rename H0 into HMAT.
          assert (HV0: forall ofs : Z,
                         0 <= ofs < num_proc ->
                         forall n0, 0<= n0 <= 5 -> Mem.valid_access m2 Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros. destruct (ZtoPreg_range_correct _ H0) as [r HEX].
            destruct (HMAT _ H _ _ HEX) as [_[_[HV _]]]; trivial.
          }
          assert (HP: exists m0, Mem.store Mint32 m2 b0 (Int.unsigned n * 24) (rs2#ESP) = Some m0).
          {
            assert(HOS0: 0 <= 0 <=5) by omega.
            specialize (HV0 _ a _ HOS0).
            replace (Int.unsigned n * 24 + 0 * 4) with (Int.unsigned n * 24) in HV0 by omega.
            apply (Mem.valid_access_store); auto.
          }
          destruct HP as [m0 HST0].
          assert (HV1: forall ofs : Z,
                         0 <= ofs < num_proc ->
                         forall n0, 0<= n0 <= 5 -> Mem.valid_access m0 Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros; eapply Mem.store_valid_access_1; eauto.
          }
          clear HV0.
          assert (HP: exists m1, Mem.store Mint32 m0 b0 (Int.unsigned n * 24 + 1 * 4) (rs2#EDI) = Some m1).
          {
            assert(HOS0: 0 <= 1 <=5) by omega.
            apply (Mem.valid_access_store); auto.
          }
          destruct HP as [m1 HST1].
          assert (HV2: forall ofs : Z,
                         0 <= ofs < num_proc ->
                         forall n0, 0<= n0 <= 5 -> Mem.valid_access m1 Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros; eapply Mem.store_valid_access_1; eauto.
          }
          clear HV1.
          assert (HP: exists m2', Mem.store Mint32 m1 b0 (Int.unsigned n * 24 + 2 * 4) (rs2#ESI) = Some m2').
          {
            assert(HOS0: 0 <= 2 <=5) by omega.
            apply (Mem.valid_access_store); auto.
          }
          destruct HP as [m2' HST2].
          assert (HV3: forall ofs : Z,
                         0 <= ofs < num_proc ->
                         forall n0, 0<= n0 <= 5 -> Mem.valid_access m2' Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros; eapply Mem.store_valid_access_1; eauto.
          }
          clear HV2.
          assert (HP: exists m3, Mem.store Mint32 m2' b0 (Int.unsigned n * 24 + 3 * 4) (rs2#EBX) = Some m3).
          {
            assert(HOS0: 0 <= 3 <=5) by omega.
            apply (Mem.valid_access_store); auto.
          }
          destruct HP as [m3 HST3].
          assert (HV4: forall ofs : Z,
                         0 <= ofs < num_proc ->
                         forall n0, 0<= n0 <= 5 -> Mem.valid_access m3 Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros; eapply Mem.store_valid_access_1; eauto.
          }
          clear HV3.
          assert (HP: exists m4, Mem.store Mint32 m3 b0 (Int.unsigned n * 24 + 4 * 4) (rs2#EBP) = Some m4).
          {
            assert(HOS0: 0 <= 4 <=5) by omega.
            apply (Mem.valid_access_store); auto.
          }
          destruct HP as [m4 HST4].
          assert (HV5: forall ofs : Z,
                         0 <= ofs < num_proc ->
                         forall n0, 0<= n0 <= 5 -> Mem.valid_access m4 Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros; eapply Mem.store_valid_access_1; eauto.
          }
          clear HV4.
          assert (HP: exists m5, Mem.store Mint32 m4 b0 (Int.unsigned n * 24 + 5 * 4) (rs2#RA) = Some m5).
          {
            assert(HOS0: 0 <= 5 <=5) by omega.
            apply (Mem.valid_access_store); auto.
          }
          destruct HP as [m5 HST5].
          assert (HV: forall ofs : Z,
                        0 <= ofs < num_proc ->
                        forall n0, 0<= n0 <= 5 -> Mem.valid_access m5 Mint32 b0 (ofs * 24 + n0 * 4) Writable).
          {
            intros; eapply Mem.store_valid_access_1; eauto.
          }
          clear HV5.
          assert (HMAT':
                    forall ofs : Z,
                      0 <= ofs < num_proc ->
                      ofs <> Int.unsigned n ->
                      forall (n : Z) (r : preg),
                        ZtoPreg n = Some r ->
                        exists v : val,
                          Mem.load Mint32 m5 b0 (ofs * 24 + n * 4) = Some v /\
                          Mem.valid_access m5 Mint32 b0 (ofs * 24 + n * 4) Writable /\
                          val_inject ι ((Val.load_result
                                           Mint32 (Pregmap.get
                                                     r (ZMap.get ofs (kctxt d1))))) v).
          {
            intros.
            destruct (HMAT _ H _ _ H2) as [v[HLD[_ HM]]].
            exists v.
            specialize (ZtoPreg_range _ _ H2); intros Hn1.
            split; eauto.
            Ltac simpl_other ofs n:=
              right; simpl; destruct (zlt ofs (Int.unsigned n));
              [left; omega|right; omega].
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST5); [|simpl_other ofs n].
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST4); [|simpl_other ofs n].
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST3); [|simpl_other ofs n].
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST2); [|simpl_other ofs n].
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST1); [|simpl_other ofs n].
            rewrite (Mem.load_store_other  _ _ _ _ _ _ HST0); [|simpl_other ofs n].
            trivial.
          }
          clear HMAT.
          assert (forall n0 : Z, 0 <= n0 <= 5 -> Mem.valid_access m5 Mint32 b0 (Int.unsigned n' * 24 + n0 * 4) Readable).
          {
            specialize (HV _ a0).
            intros. specialize (HV _ H).
            eapply Mem.valid_access_implies; eauto.
            constructor.
          }
          clear HV.
          assert (HP: exists v0, Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + 0 * 4) = Some v0).
          {
            assert (0<= 0 <= 5) by omega.
            eapply Mem.valid_access_load; eauto.
          }
          destruct HP as [v0 HLD0].
          assert (HP: exists v1, Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + 1 * 4) = Some v1).
          {
            assert (0<= 1 <= 5) by omega.
            eapply Mem.valid_access_load; eauto.
          }
          destruct HP as [v1 HLD1].
          assert (HP: exists v2, Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + 2 * 4) = Some v2).
          {
            assert (0<= 2 <= 5) by omega.
            eapply Mem.valid_access_load; eauto.
          }
          destruct HP as [v2 HLD2].
          assert (HP: exists v3, Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + 3 * 4) = Some v3).
          {
            assert (0<= 3 <= 5) by omega.
            eapply Mem.valid_access_load; eauto.
          }
          destruct HP as [v3 HLD3].
          assert (HP: exists v4, Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + 4 * 4) = Some v4).
          {
            assert (0<= 4 <= 5) by omega.
            eapply Mem.valid_access_load; eauto.
          }
          destruct HP as [v4 HLD4].
          assert (HP: exists v5, Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + 5 * 4) = Some v5).
          {
            assert (0<= 5 <= 5) by omega.
            eapply Mem.valid_access_load; eauto.
          }
          destruct HP as [v5 HLD5].
          simpl in *.
          assert(N_ARU': rs2 EAX = Vint n /\ rs2 EDX = Vint n').
          {
            unfold Pregmap.get in *.
            split.
            specialize (match_reg EAX).
            rewrite N_ARU1 in match_reg.
            inv match_reg; trivial.
            unfold Pregmap.get in *.
            specialize (match_reg EDX).
            rewrite N_ARU2 in match_reg.
            inv match_reg; trivial.
          }
          destruct N_ARU' as [N_ARU1' N_ARU2'].
          assert(HMCTXT: match_KCtxtPool s (kctxt d1') m5 ι).
          {
            econstructor; eauto. clear HLD0 HLD1 HLD2 HLD3 HLD4 HLD5.
            intros.
            destruct (zeq ofs (Int.unsigned n)).
            * (* ofs = Int.unsigned n*)
              clear HMAT'. subst.
              specialize (ZtoPreg_range _ _ H2).
              intros Hn1.
              destruct (zeq n1 5); subst; inv H2.
              eexists (Val.load_result Mint32 (rs2 RA)).
              split.
              eapply Mem.load_store_same; eauto.
              split.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_3; eauto.
              inv H4. simpl in *.
              rewrite ZMap.gss.
              unfold Pregmap.get in *.
              specialize (match_reg RA).
              inv match_reg; try constructor.
              econstructor; eauto.
              assert (HW0: Mem.load Mint32 m5 b0 (Int.unsigned n * 24 + n1 * 4) =
                           Mem.load Mint32 m4 b0 (Int.unsigned n * 24 + n1 * 4)).
              {
                rewrite (Mem.load_store_other  _ _ _ _ _ _ HST5).
                trivial.
                right. left. simpl. omega.
              }
              destruct (zeq n1 4); subst. inv H4.
              eexists (Val.load_result Mint32 (rs2 EBP)).
              split. rewrite HW0.
              eapply Mem.load_store_same; eauto.
              split.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_3; eauto.
              inv H5. simpl in *. rewrite ZMap.gss.
              unfold Pregmap.get in *.
              specialize (match_reg EBP).
              inv match_reg; try constructor.
              econstructor; eauto.
              assert (HW1: Mem.load Mint32 m5 b0 (Int.unsigned n * 24 + n1 * 4)
                           = Mem.load Mint32 m3 b0 (Int.unsigned n * 24 + n1 * 4)).
              {
                rewrite HW0.
                rewrite (Mem.load_store_other  _ _ _ _ _ _ HST4).
                trivial.
                right. left. simpl. omega.
              }
              clear HW0.
              destruct (zeq n1 3); subst. inv H4.
              eexists (Val.load_result Mint32 (rs2 EBX)).
              split. rewrite HW1.
              eapply Mem.load_store_same; eauto.
              split.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_3; eauto.
              inv H5. simpl in *.
              rewrite ZMap.gss.
              unfold Pregmap.get in *.
              specialize (match_reg EBX).
              inv match_reg; try constructor.
              econstructor; eauto.
              assert (HW2: Mem.load Mint32 m5 b0 (Int.unsigned n * 24 + n1 * 4)
                           = Mem.load Mint32 m2' b0 (Int.unsigned n * 24 + n1 * 4)).
              {
                rewrite HW1.
                rewrite (Mem.load_store_other  _ _ _ _ _ _ HST3).
                trivial.
                right. left. simpl. omega.
              }
              clear HW1.
              destruct (zeq n1 2); subst. inv H4.
              eexists (Val.load_result Mint32 (rs2 ESI)).
              split. rewrite HW2.
              eapply Mem.load_store_same; eauto.
              split.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_3; eauto.
              inv H5. simpl in *.
              rewrite ZMap.gss.
              unfold Pregmap.get in *.
              specialize (match_reg ESI).
              inv match_reg; try constructor.
              econstructor; eauto.
              assert (HW1: Mem.load Mint32 m5 b0 (Int.unsigned n * 24 + n1 * 4)
                           = Mem.load Mint32 m1 b0 (Int.unsigned n * 24 + n1 * 4)).
              {
                rewrite HW2.
                rewrite (Mem.load_store_other  _ _ _ _ _ _ HST2).
                trivial.
                right. left. simpl. omega.
              }
              clear HW2.
              destruct (zeq n1 1); subst; inv H4.
              eexists (Val.load_result Mint32 (rs2 EDI)).
              split. rewrite HW1.
              eapply Mem.load_store_same; eauto.
              split.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_3; eauto.
              inv H5. simpl in *.
              rewrite ZMap.gss.
              unfold Pregmap.get in *.
              specialize (match_reg EDI).
              inv match_reg; try constructor.
              econstructor; eauto.
              assert (HW0: Mem.load Mint32 m5 b0 (Int.unsigned n * 24 + n1 * 4)
                           = Mem.load Mint32 m0 b0 (Int.unsigned n * 24 + n1 * 4)).
              {
                rewrite HW1.
                rewrite (Mem.load_store_other  _ _ _ _ _ _ HST1).
                trivial.
                right. left. simpl. omega.
              }
              clear HW1.
              destruct (zeq n1 0). subst. inv H5.
              eexists (Val.load_result Mint32 (rs2 ESP)).
              replace (Int.unsigned n * 24 + 0 * 4) with (Int.unsigned n * 24) in * by omega.
              split. rewrite HW0.
              eapply Mem.load_store_same; eauto.
              split.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_1; eauto.
              eapply Mem.store_valid_access_3; eauto.
              simpl in *.
              rewrite ZMap.gss.
              unfold Pregmap.get in *.
              specialize (match_reg ESP).
              inv match_reg; try constructor.
              econstructor; eauto.
              omega.
            *  (** ofs <> Int.unsigned n**)
              specialize (HMAT' _ H0 n2 _ _ H2).
              inv H4. simpl.
              rewrite ZMap.gso; trivial.
          }
          refine_split; eauto 2.
          - econstructor; eauto; simpl; lift_trivial;
            try eassumption; unfold set; simpl.
            eapply reg_symbol_inject; eassumption.
            rewrite HST0. reflexivity.
            simpl; rewrite HST1. reflexivity.
            simpl; rewrite HST2. reflexivity.
            simpl; rewrite HST3. reflexivity.
            simpl; rewrite HST4. reflexivity.
            simpl; rewrite HST5. reflexivity.

            simpl. inv match_related.
            split; congruence.
          - pose proof match_related as match_relate'.
            inv match_related. inv H4.
            econstructor; eauto.
            split; eauto; pattern2_refinement_simpl.
            econstructor; eauto 2.
            econstructor; simpl; eauto 2.
            assert (HINJ: forall n1 r,
                            ZtoPreg n1 = Some r ->
                            forall v ,
                              Mem.load Mint32 m5 b0 (Int.unsigned n' * 24 + n1 * 4) = Some v ->
                              val_inject ι ((ZMap.get (Int.unsigned n') (kctxt d1)) r) v).
            {
              assert (Hn: Int.unsigned n' <> Int.unsigned n) by auto.
              intros. specialize (HMAT' _ a0 Hn _ _ H0).
              destruct HMAT' as [v'[HL'[_ HV']]].
              rewrite H2 in HL'. inv HL'.
              refine_split'; eauto 2.
              unfold Pregmap.get in *.
              specialize (N_TYPE _ _ H0).
              caseEq (ZMap.get (Int.unsigned n') (kctxt d1) r); intros;
              rewrite H3 in *; try assumption; inv N_TYPE.
            }
            clear HMAT'. subst rs3.
            val_inject_simpl;
              try (eapply HINJ; [apply PregToZ_correct; reflexivity| trivial]).
        Qed.

      End FRESH_PRIM.

      Section PASSTHROUGH_PRIM.

        Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
        Proof.
          accessor_prop_tac.
          - eapply flatmem_store_exists; eauto.
          - eapply flatmem_store_match; eauto.
        Qed.

        Lemma passthrough_correct:
          sim (crel HDATA LDATA) pkcontext_passthrough mshare.
        Proof.
          sim_oplus.
          - apply fload_sim.
          - apply fstore_sim.
          - apply flatmem_copy_sim.
          - apply vmxinfo_get_sim.
          - apply device_output_sim.
          - apply pfree_sim.
          - apply setPT_sim.
          - apply ptRead_sim.
          - apply ptResv_sim.
          - apply pt_new_sim.
          - apply sharedmem_init_sim.
          - apply shared_mem_status_sim.
          - apply offer_shared_mem_sim.
          - apply ptin_sim.
          - apply ptout_sim.
          - apply clearCR2_sim.
          - apply container_get_nchildren_sim.
          - apply container_get_quota_sim.
          - apply container_get_usage_sim.
          - apply container_can_consume_sim.
          - apply alloc_sim.
          - apply trapin_sim.
          - apply trapout_sim.
          - apply hostin_sim.
          - apply hostout_sim.
          - apply trap_info_get_sim.
          - apply trap_info_ret_sim.
          - layer_sim_simpl.
            + eapply load_correct2.
            + eapply store_correct2.
        Qed.

      End PASSTHROUGH_PRIM.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.


Require Export Nat.
Require Export ch2o.prelude.orders.
Require Export ch2o.prelude.nmap.
Require Export ch2o.prelude.stringmap.
Require Export ch2o.memory.memory_basics.
Require Export ch2o.abstract_c.architectures.
Require Export ch2o.abstract_c.interpreter.
Require Export ch2o.abstract_c.frontend_sound.
Require Export ch2o.core_c.smallstep.
Require Export ch2o.core_c.restricted_smallstep.
Require Export ch2o.core_c.expression_eval_smallstep.
Require Export ch2o.axiomatic.axiomatic_expressions.
Require Export ch2o.axiomatic.axiomatic_statements.
Require Export ch2o.axiomatic.axiomatic_adequate.
Require Export one_local.

Definition get_right{A B}(v: A + B)(H: match v with inl _ => False | inr _ => True end): B.
destruct v.
elim H.
exact b.
Defined.

Open Local Scope string_scope.

Definition A: architecture := {|
  arch_sizes := architectures.lp64;
  arch_big_endian := false;
  arch_char_signedness := Signed;
  arch_alloc_can_fail := false
|}.
Notation K := (arch_rank A).

Notation M := (error (frontend_state K) string).

Lemma alloc_program_ok: match alloc_program (K:=K) decls empty with inl _ => False | inr _ => True end.
exact I.
Qed.

Definition alloc_program_result: frontend_state K.
eapply snd.
eapply get_right.
apply alloc_program_ok.
Defined.

Compute (stringmap_to_list (env_t (to_env alloc_program_result))).
Compute (stringmap_to_list (env_f (to_env alloc_program_result))).

Definition to_core_c_program: M (env K * funenv K * state K) :=
  _ ← alloc_program decls;
  Δg ← gets to_globals;
  '(_,σs,σ,_) ← error_of_option (Δg !! "main"≫= maybe4 Fun)
    ("function `main` undeclared`");
  guard (σ = sintT%T ∨ σ = uintT%T) with
    ("function `main` should have return type `int`");
  Γ ← gets to_env;
  δ ← gets to_funenv;
  m ← gets to_mem;
  mret (Γ, δ, initial_state m "main" []).

Definition to_core_c_program_result: string + env K * funenv K * state K :=
  error_eval to_core_c_program ∅.

Lemma to_core_c_program_ok: match to_core_c_program_result with inl _ => False | inr _ => True end.
exact I.
Qed.

Definition core_c_program: env K * funenv K * state K := get_right to_core_c_program_result to_core_c_program_ok.

Definition Γ: env K := to_env alloc_program_result.
Definition δ: funenv K := to_funenv alloc_program_result.
Definition m0: mem K := to_mem alloc_program_result.
Definition S0 := initial_state m0 "main" [].

Lemma alloc_program_eq: alloc_program decls empty = mret () alloc_program_result.
reflexivity.
Qed.

Lemma Γ_valid: ✓ Γ.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma δ_valid: ✓{Γ,'{m0}} δ.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma m0_valid: ✓{Γ} m0.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma mem_lock_cmap (Γ: env K) o (m: indexmap (cmap_elem K (pbit K))):
  mem_lock Γ (addr_top o sintT%BT) (CMap m) =
  CMap (alter (cmap_elem_map (ctree_map pbit_lock)) o m).
reflexivity.
Qed.

Lemma zip_with_pbit_unlock_if_list_fmap_pbit_lock (l: list (pbit K)):
  Forall (λ γb, Some Writable ⊆ pbit_kind γb) l ->
  zip_with pbit_unlock_if (pbit_lock <$> l) (replicate (Datatypes.length l) true) = l.
induction l; intros; try reflexivity.
simpl.
unfold fmap in IHl.
rewrite IHl.
- destruct a.
  simpl.
  inversion H; subst.
  destruct tagged_perm.
  + destruct l0; simpl in *.
    * unfold perm_kind in H2.
      elim H2.
    * reflexivity.
  + elim H2.
- inversion H; subst; assumption.
Qed.

Lemma mem_unlock_lock_singleton (Γ: env K) o (m: mem K):
  ✓{Γ} m ->
  '{m} !! o = Some (sintT%T, false) ->
  mem_writable Γ (addr_top o sintT%BT) m ->
  mem_unlock
    (lock_singleton Γ (addr_top o sintT%BT))
    (mem_lock Γ (addr_top o sintT%BT) m) = m.
destruct m as [m].
intros Hvalid. intros.
destruct Hvalid as [Hvalid1 [Hvalid2 Hvalid3]].
simpl in *.
assert (forall (m1: indexmap (cmap_elem K (pbit K))) m2, m1 = m2 -> CMap m1 = CMap m2). { intros; congruence. }
apply H1.
apply map_eq.
intro i.
rewrite lookup_merge.
2:reflexivity.
destruct (decide (i = o)).
- subst.
  rewrite lookup_singleton.
  rewrite lookup_alter.
  destruct H0 as [w [Hw H'w]].
  simpl in *.
  unfold cmap_lookup in Hw.
  simpl in Hw.
  case_eq (m !! o); intros; rewrite H0 in Hw; try discriminate.
  destruct c; try discriminate.
  simpl in Hw.
  injection Hw; clear Hw; intros; subst.
  simpl.
  rewrite lookup_fmap in H.
  rewrite H0 in H.
  simpl in H.
  injection H; clear H; intros; subst.
  destruct w; try discriminate.
  destruct b0; try discriminate.
  destruct i; try discriminate.
  simpl in H.
  injection H; clear H; intros; subst.
  clear H1.
  simpl.
  pose proof H0.
  apply Hvalid3 in H0.
  destruct H0 as [τ [Ho1 [Ho2 [Ho3 Ho4]]]].
  simpl in *.
  unfold typed in Ho1.
  unfold index_typed in Ho1.
  destruct Ho1 as [β Ho1].
  rewrite lookup_fmap in Ho1.
  rewrite H in Ho1.
  simpl in Ho1.
  injection Ho1; clear Ho1; intros; subst.
  simpl in Ho3.
  unfold typed in Ho3.
  unfold ctree_typed in Ho3.
  simpl in Ho3.
  inversion Ho3; subst.
  rewrite fmap_length.
  assert (Datatypes.length l = 32). {
    rewrite H4.
    reflexivity.
  }
  rewrite H0.
  assert (natmap.to_bools 32
              {|
              mapset.mapset_car := natmap.list_to_natmap
                                     [Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some (); Some ();
                                     Some (); Some ()] |} =
    [true; true; true; true; true; true; true; true;
     true; true; true; true; true; true; true; true;
     true; true; true; true; true; true; true; true;
     true; true; true; true; true; true; true; true]).
  reflexivity.
  rewrite H1.
  pose proof (zip_with_pbit_unlock_if_list_fmap_pbit_lock l H'w).
  rewrite H0 in H5.
  simpl in H5.
  rewrite H5.
  reflexivity.
- rewrite lookup_singleton_ne; try congruence.
  rewrite lookup_alter_ne; try congruence.
Qed.

Lemma lockset_union_right_id (Ω: lockset): Ω ∪ ∅ = Ω.
apply lockset_eq.
intros.
solve_elem_of.
Qed.

Lemma cons_snoc0 {A} x (xs: list A): exists y ys, x::xs = (ys ++ [y])%list.
revert x.
induction xs.
- intros.
  exists x.
  exists [].
  reflexivity.
- intros.
  destruct (IHxs a) as [y [ys Hyys]].
  rewrite Hyys.
  exists y.
  exists (x::ys).
  reflexivity.
Qed.

Lemma expr_eval_pure (Γ: env K) ρ e1 m e2 m2 (E: ectx K) ν:
  Γ\ ρ ⊢ₕ e1, m ⇒ e2, m2 ->
  ⟦ subst E e1 ⟧ Γ ρ m = Some ν ->
  m2 = m.
intros.
apply expr_eval_subst in H0.
destruct H0 as [ν' [Hν' _]].
apply symmetry.
apply ehstep_expr_eval_mem with (1:=H) (2:=Hν').
Qed.

Lemma expr_eval_complete_subst (Γ: env K) ρ e1 m e2 m2 (E: ectx K) ν:
  Γ\ ρ ⊢ₕ e1, m ⇒ e2, m2 ->
  ⟦ subst E e1 ⟧ Γ ρ m = Some ν ->
  ⟦ subst E e2 ⟧ Γ ρ m = Some ν.
intros.
pose proof H0.
apply expr_eval_subst in H0.
destruct H0 as [ν' [Hν' _]].
assert (m = m2). {
  apply ehstep_expr_eval_mem with (1:=H) (2:=Hν').
}
subst m2.
assert (⟦ e2 ⟧ Γ ρ m = Some ν'). {
  apply ehstep_expr_eval with (1:=H) (2:=Hν') (3:=Hν').
}
rewrite subst_preserves_expr_eval with (e4:=e2) in H1.
- assumption.
- congruence.
Qed.

Lemma expr_eval_call_None {Γ: env K} {ρ m} {E: ectx K} {f args ν}:
  ⟦ subst E (ECall f args) ⟧ Γ ρ m = Some ν -> False.
intros.
apply expr_eval_subst in H.
destruct H.
destruct H.
simpl in H.
discriminate.
Qed.

Lemma expr_eval_no_locks (Γ: env K) ρ m Ω ν ν':
  ⟦ %#{Ω} ν ⟧ Γ ρ m = Some ν' -> (%#{Ω} ν = %# ν')%E.
intros.
simpl in H.
unfold mguard in H.
unfold option_guard in H.
destruct (lockset_eq_dec Ω ∅); congruence.
Qed.

Lemma assign_pure (Γ: env K) δ ρ S0 S:
  Γ\ δ\ ρ ⊢ₛ S0 ⇒* S ->
  is_undef_state S ->
  forall k el er m νl νr,
  S0 = State k (Expr (el ::= er)) m ->
  ⟦ el ⟧ Γ (rlocals ρ k) m = Some νl ->
  ⟦ er ⟧ Γ (rlocals ρ k) m = Some νr ->
  Γ\ δ\ ρ ⊢ₛ State k (Expr (%# νl ::= %# νr)) m ⇒* S.
induction 1; intros; subst. {
  elim (is_Some_None H).
}
inversion H; clear H; subst.
- (* head reduction *)
  destruct E.
  + (* empty evaluation context *)
    simpl in *.
    subst.
    inversion H8; subst.
    simpl in *.
    unfold mguard in H4.
    unfold option_guard in H4.
    case_eq (lockset_eq_dec Ω2 ∅); intros.
    * rewrite H in H4.
      injection H4; clear H4; intros; subst.
      unfold mguard in H3; unfold option_guard in H3.
      case_eq (lockset_eq_dec Ω1 ∅); intros.
      -- rewrite H2 in H3.
         injection H3; clear H3; intros; subst.
         clear H H2.
         eapply rtc_l.
         ++ eapply rcstep_expr_head with (E:=[]).
            eassumption.
         ++ eassumption.
      -- rewrite H2 in H3; discriminate.
    * rewrite H in H4; discriminate.
  + (* nonempty evaluation context *)
    destruct (cons_snoc0 e E) as [e' [E' H']].
    rewrite H' in *.
    clear H' e E.
    rewrite subst_snoc in H6.
    destruct e'; try discriminate.
    * (* lhs *)
      simpl in H6.
      injection H6; clear H6; intros; subst.
      rewrite subst_snoc in H0.
      rewrite subst_snoc in IHrtc.
      simpl in *.
      assert (m2 = m). {
        apply expr_eval_pure with (1:=H8) (2:=H3).
      }
      subst m2.
      apply expr_eval_complete_subst with (1:=H8) in H3.
      apply IHrtc with (3:=H3) (4:=H4); trivial.
    * (* rhs *)
      simpl in *.
      injection H6; clear H6; intros; subst.
      rewrite subst_snoc in H0.
      rewrite subst_snoc in IHrtc.
      simpl in *.
      assert (m2 = m). {
        apply expr_eval_pure with (1:=H8) (2:=H4).
      }
      subst m2.
      apply expr_eval_complete_subst with (1:=H8) in H4.
      apply IHrtc with (3:=H3) (4:=H4); trivial.
- (* function call *)
  destruct E.
  + (* E = [] *)
    simpl in *.
    discriminate.
  + destruct (cons_snoc0 e0 E) as [e' [E' H']].
    rewrite H' in *.
    clear H' e0 E.
    rewrite subst_snoc in H6.
    destruct e'; try discriminate; simpl in *; injection H6; clear H6; intros; subst.
    * (* lhs *)
      elim (expr_eval_call_None H3).
    * (* rhs *)
      elim (expr_eval_call_None H4).
- (* undef *)
  destruct E.
  * (* E = [] *)
    simpl in *.
    subst.
    eapply rtc_l.
    2: eassumption.
    inversion H8; subst.
    destruct H5.
    destruct H7.
    rewrite expr_eval_no_locks with (1:=H3) in *.
    rewrite expr_eval_no_locks with (1:=H4) in *.
    apply rcstep_expr_undef with (E:=[]).
    -- assumption.
    -- assumption.
  * (* E <> [] *)
    destruct (cons_snoc0 e0 E) as [e' [E' H']].
    rewrite H' in *.
    clear H' e0 E.
    rewrite subst_snoc in H5.
    destruct e'; try discriminate; simpl in *; injection H5; clear H5; intros; subst.
    -- (* lhs *)
       destruct expr_eval_subst_ehstep with (1:=H3) (2:=H8).
       destruct H.
       elim H9.
       eapply ehsafe_step.
       apply H.
    -- (* rhs *)
       destruct expr_eval_subst_ehstep with (1:=H4) (2:=H8).
       destruct H.
       elim H9.
       eapply ehsafe_step.
       apply H.
Qed.

Lemma assign_pure' (Γ: env K) δ ρ S k el er m νl νr:
  Γ\ δ\ ρ ⊢ₛ (State k (Expr (el ::= er)) m) ⇒* S ->
  ⟦ el ⟧ Γ (rlocals ρ k) m = Some νl ->
  ⟦ er ⟧ Γ (rlocals ρ k) m = Some νr ->
  (Γ\ δ\ ρ ⊢ₛ State k (Expr (%# νl ::= %# νr)) m ⇒* S ->
   ¬ is_undef_state S) ->
  ¬ is_undef_state S.
intros.
intro.
apply H2 with (2:=H3).
apply assign_pure with (1:=H) (2:=H3) (4:=H0) (5:=H1).
reflexivity.
Qed.

Lemma Expr_pure (Γ: env K) δ ρ S0 S:
  Γ\ δ\ ρ ⊢ₛ S0 ⇒* S ->
  is_undef_state S ->
  forall k e m ν,
  S0 = State k (Expr e) m ->
  ⟦ e ⟧ Γ (rlocals ρ k) m = Some ν ->
  Γ\ δ\ ρ ⊢ₛ State k (Expr (%# ν)) m ⇒* S.
intro Hrtc.
pose proof Hrtc.
induction H; intros; subst. {
  elim (is_Some_None H).
}
assert (forall Ω ν', e = (%#{Ω} ν')%E -> Γ\ δ\ ρ ⊢ₛ State k (Expr (%# ν)) m ⇒* z). {
  intros.
  subst.
  simpl in H3.
  unfold mguard in H3.
  unfold option_guard in H3.
  destruct (lockset_eq_dec Ω ∅).
  2: discriminate.
  injection H3; clear H3; intros; subst.
  assumption.
}
clear Hrtc.
inversion H; clear H; subst; try (eapply H2; reflexivity); clear H2.
- (* head reduction *)
  assert (m2 = m). {
    apply expr_eval_pure with (1:=H8) (2:=H3).
  }
  subst m2.
  eapply IHrtc; try trivial.
  apply expr_eval_complete_subst with (1:=H8) (2:=H3).
- (* function call *)
  elim (expr_eval_call_None H3).
- elim H9.
  eapply expr_eval_subst_ehsafe; eassumption.
Qed.

Lemma Expr_pure' (Γ: env K) δ ρ S k e m ν:
  Γ\ δ\ ρ ⊢ₛ (State k (Expr e) m) ⇒* S ->
  ⟦ e ⟧ Γ (rlocals ρ k) m = Some ν ->
  (Γ\ δ\ ρ ⊢ₛ State k (Expr (%# ν)) m ⇒* S ->
   ¬ is_undef_state S) ->
  ¬ is_undef_state S.
intros.
intro.
apply H1.
2: assumption.
apply Expr_pure with (1:=H) (2:=H2) (4:=H0).
reflexivity.
Qed.

Definition safe S0: Prop := forall S, rtc (cstep Γ δ) S0 S -> ~ is_undef_state S.

Lemma call_safe_lemma: forall f s,
  δ !! f = Some s ->
  safe (State [] (Stmt ↘ s) ∅) ->
  safe (State [] (Call f []) ∅).
Admitted.

Require Export ch2o.axiomatic.axiomatic_simple.

Lemma call_main_safe: safe (State [] (Call "main" []) ∅).
eapply call_safe_lemma. reflexivity.
assert ((intT (to_inttype
                        {|
                        csign := None;
                        crank := CIntRank |}))%BT = (sintT%BT : base_type K)). reflexivity.
rewrite H; clear H.
assert (IntType (from_option Signed (Some Signed)) int_rank = (sintT%IT: int_type K)). reflexivity.
rewrite H; clear H.
intros S HS1 HS2.
destruct ax_stmt_adequate with (7:=HS1) (Q:=fun (v: val K) => True%A) (cmτ:=((true, Some sintT%T): rettype K)) as [[n' [m' [Had1 Had2]]] | [[n' [m' [v [Had1 Had2]]]] | Had3]].
Focus 7. {
  subst. elim (is_Some_None HS2).
} Unfocus.
Focus 7. {
  subst. elim (is_Some_None HS2).
} Unfocus.
Focus 7. {
  inversion Had3.
  destruct S as [k [] m]; try elim (is_Some_None HS2).
  inversion H.
} Unfocus.
{ apply Γ_valid. }
{ apply δ_valid. }
{ apply m0_valid. }
{ apply mem_locks_empty. }
{ apply type_check_sound.
  - simpl. apply Γ_valid.
  - reflexivity.
}
clear S HS1 HS2.
apply ax_local.
assert ((assert_eq_mem (cmap_erase ∅)↑)%A ⊆{Γ,δ} (emp%A: assert K)). {
  rewrite cmap_erase_empty.
  unfold subseteqE.
  unfold assert_entails.
  intros.
  unfold assert_eq_mem in H5.
  unfold assert_Prop.
  simpl in *.
  tauto.
}
eapply ax_stmt_weaken_pre. {
  rewrite H.
  rewrite (right_id _ (★)%A).
  reflexivity.
}
assert (Inhabited (ptr K)). {
  constructor.
  apply NULL.
  constructor.
  apply (sintT%T).
}
eapply ax_comp.
- eapply ax_do' with
     (Q:=(var 0 ↦{false,perm_lock perm_full} (# intV{sintT} 3) : sintT%BT)%A)
     (Q':=(var 0 ↦{false,perm_full} (# intV{sintT} 3) : sintT%BT)%A).
  + eapply ax_expr_weaken_pre. {
      rewrite assert_singleton_l_.
      reflexivity.
    }
    apply ax_expr_exist_pre.
    intro x.
    eapply ax_expr_weaken_post'. {
      apply assert_singleton_l_2 with (a:=x).
    }
    eapply ax_expr_invariant_l'.
    eapply ax_assign_r' with (p:=x).
    * apply ax_var'.
      rewrite (right_id _ (★)%A).
      rewrite (right_id _ (★)%A).
      apply assert_and_l.
    * eapply ax_cast'.
      -- eapply ax_expr_base.
         eapply assert_and_intro.
         Focus 2. {
           apply assert_int_typed_eval.
           constructor; (unfold int_lower || unfold int_upper); simpl; lia.
         } Unfocus.
         simpl.
         rewrite assert_Prop_l.
         ++ reflexivity.
         ++ reflexivity.
      -- apply assert_eval_int_cast_self'.
         apply assert_int_typed_eval.
         constructor; (unfold int_lower || unfold int_upper); simpl; lia.
    * simpl.
      apply assert_and_intro.
      -- apply assert_eval_int_cast_self'.
         apply assert_int_typed_eval.
         constructor; (unfold int_lower || unfold int_upper); simpl; lia.
      -- apply assert_eval_int_cast_self'.
         apply assert_int_typed_eval.
         constructor; (unfold int_lower || unfold int_upper); simpl; lia.
    * simpl (freeze true _).
      rewrite <- (right_id _ (★)%A) at 1.
      apply assert_sep_preserving.
      -- reflexivity.
      -- apply assert_wand_intro.
         rewrite (left_id _ (★)%A).
         reflexivity.
    * reflexivity.
  + apply assert_lock_singleton.
    * apply perm_full_valid.
    * reflexivity.
- apply ax_ret with (Q1:=(fun _ => var 0 ↦{false, perm_full} # intV{sintT} 3 : sintT%BT)%A).
  + intros.
    rewrite <- assert_unlock_sep.
    rewrite stack_indep.
    rewrite <- unlock_indep.
    rewrite <- (right_id _ (★)%A) at 1.
    apply assert_sep_preserving. 2:apply assert_True_intro.
    rewrite assert_unlock_exists.
    apply assert_exist_intro with (x:=intV{sintT} 3).
    apply assert_singleton_unlock_indep.
    reflexivity.
  + eapply ax_expr_base.
    apply assert_and_intro.
    * reflexivity.
    * rewrite <- assert_eval_int_cast.
      -- apply assert_singleton_eval.
         reflexivity.
      -- constructor; (unfold int_lower || unfold int_upper); simpl; lia.
Qed.

Goal forall S, rtc (cstep Γ δ) S0 S -> ~ is_undef_state S.
intros.
apply call_main_safe with (1:=H).
Qed.