From Coq Require Import ssreflect.
From stdpp Require Import strings gmap list.
From iris.proofmode Require Import proofmode.
From melocoton Require Import named_props.
From melocoton.ml_lang Require Import lang_instantiation primitive_laws.
From melocoton.interop Require Export prims.
From melocoton.interop Require Import basics_resources gctoken prims.

Section PrimsProto.

Context `{SI: indexT}.
Context {Σ : gFunctors}.
Context `{!heapG_ML Σ, !heapG_C Σ}.
Context `{!invG Σ}.
Context `{!wrapperGCtokG Σ}.

Notation C_proto := (protocol C_intf.val Σ).
Notation ML_proto := (protocol ML_lang.val Σ).

(* TODO: move *)
Definition wrap_proto (Ψ : ML_proto) : C_proto := (λ f ws Φ,
  ∃ θ vs lvs Φ',
    "HGC" ∷ GC θ ∗
    "%Hrepr" ∷ ⌜Forall2 (repr_lval θ) lvs ws⌝ ∗
    "Hsim" ∷ lvs ~~∗ vs ∗
    "Hproto" ∷ Ψ f vs Φ' ∗
    "Cont" ∷ ▷ (∀ θ' vret lvret wret,
      GC θ' -∗
      Φ' vret -∗
      lvret ~~ vret -∗
      ⌜repr_lval θ' lvret wret⌝ -∗
      Φ wret)
)%I.

Lemma wrap_proto_mono Ψ Ψ' : Ψ ⊑ Ψ' → wrap_proto Ψ ⊑ wrap_proto Ψ'.
Proof using.
  iIntros (Hre ? ? ?) "H". unfold wrap_proto. iNamed "H".
  rewrite /named. iExists _, _, _, _. iFrame. iSplit; first done.
  by iApply Hre.
Qed.

Definition int2val_proto : C_proto := (λ fn vl Φ,
   ∃ θ z,
     "->" ∷ ⌜fn = "int2val"⌝ ∗
     "HGC" ∷ GC θ ∗
     "->" ∷ ⌜vl = [C_intf.LitV $ C_intf.LitInt $ z]⌝ ∗
     "Cont" ∷ ▷ (∀ w, GC θ -∗ ⌜repr_lval θ (Lint z) w⌝ -∗ Φ w))%I.

Definition val2int_proto : C_proto := (λ fn vl Φ,
   ∃ θ w z,
     "->" ∷ ⌜fn = "val2int"⌝ ∗
     "HGC" ∷ GC θ ∗
     "->" ∷ ⌜vl = [ w ]⌝ ∗
     "%Hrepr" ∷ ⌜repr_lval θ (Lint z) w⌝ ∗
     "Cont" ∷ ▷ (GC θ -∗ Φ (C_intf.LitV $ C_intf.LitInt $ z)))%I.

Definition registerroot_proto : C_proto := (λ fn vl Φ,
   ∃ θ l v w,
     "->" ∷ ⌜fn = "registerroot"⌝ ∗
     "HGC" ∷ GC θ ∗
     "->" ∷ ⌜vl = [ C_intf.LitV $ C_intf.LitLoc $ l ]⌝ ∗
     "Hpto" ∷ l ↦C w ∗
     "%Hrepr" ∷ ⌜repr_lval θ v w⌝ ∗
     "Cont" ∷ ▷ (GC θ -∗ l ↦roots v -∗ Φ (C_intf.LitV $ C_intf.LitInt $ 0)))%I.

Definition unregisterroot_proto : C_proto := (λ fn vl Φ,
   ∃ θ l v,
     "->" ∷ ⌜fn = "unregisterroot"⌝ ∗
     "HGC" ∷ GC θ ∗
     "->" ∷ ⌜vl = [ C_intf.LitV $ C_intf.LitLoc $ l ]⌝ ∗
     "Hpto" ∷ l ↦roots v ∗
     "Cont" ∷ ▷ (∀ w, GC θ -∗ l ↦C w -∗ ⌜repr_lval θ v w⌝ -∗ Φ (C_intf.LitV $ C_intf.LitInt $ 0)))%I.

Definition modify_proto : C_proto := (λ fn vl Φ,
  ∃ θ w i v' w' γ mut tg vs,
    "->" ∷ ⌜fn = "modify"⌝ ∗
    "HGC" ∷ GC θ ∗
    "->" ∷ ⌜vl = [ w; C_intf.LitV $ C_intf.LitInt $ i; w' ]⌝ ∗
    "%Hreprw" ∷ ⌜repr_lval θ (Lloc γ) w⌝ ∗
    "%Hptomut" ∷ ⌜vblock_access_le M mut⌝ ∗
    "Hpto" ∷ γ ↦vblk[mut] (tg, vs) ∗
    "%Hreprw'" ∷ ⌜repr_lval θ v' w'⌝ ∗
    "%Hi1" ∷ ⌜0 ≤ i⌝%Z ∗
    "%Hi2" ∷ ⌜i < length vs⌝%Z ∗
    "Cont" ∷ ▷ (GC θ -∗
                 γ ↦vblk[mut] (tg, <[Z.to_nat i:=v']> vs) -∗
                 Φ (C_intf.LitV $ C_intf.LitInt $ 0)))%I.

Definition readfield_proto : C_proto := (λ fn vl Φ,
   ∃ θ w i γ dq m tg vs,
     "->" ∷ ⌜fn = "readfield"⌝ ∗
     "HGC" ∷ GC θ ∗
     "->" ∷ ⌜vl = [ w; C_intf.LitV $ C_intf.LitInt $ i ]⌝ ∗
     "%Hreprw" ∷ ⌜repr_lval θ (Lloc γ) w⌝ ∗
     "Hpto" ∷ γ ↦vblk[m]{dq} (tg, vs) ∗
     "%Hi1" ∷ ⌜0 ≤ i⌝%Z ∗
     "%Hi2" ∷ ⌜i < length vs⌝%Z ∗
     "Cont" ∷ ▷ (∀ v' w', GC θ -∗
                           γ ↦vblk[m]{dq} (tg, vs) -∗
                           ⌜vs !! (Z.to_nat i) = Some v'⌝ -∗
                           ⌜repr_lval θ v' w'⌝ -∗
                           Φ w'))%I.

Definition alloc_proto : C_proto := (λ fn vl Φ,
   ∃ θ tg sz,
     "->" ∷ ⌜fn = "alloc"⌝ ∗
     "HGC" ∷ GC θ ∗
     "->" ∷ ⌜vl = [ C_intf.LitV $ C_intf.LitInt $ vblock_tag_as_int $ tg; C_intf.LitV $ C_intf.LitInt $ sz ]⌝ ∗
     "%Hsz" ∷ ⌜0 ≤ sz⌝%Z ∗
     "Cont" ∷ ▷ (∀ θ' γ w, GC θ' -∗
                            γ ↦fresh (tg, List.repeat (Lint 0) (Z.to_nat sz)) -∗
                            ⌜repr_lval θ' (Lloc γ) w⌝ -∗
                            Φ w))%I.

Definition alloc_foreign_proto : C_proto := (λ fn vl Φ,
  ∃ θ,
    "->" ∷ ⌜fn = "alloc_foreign"⌝ ∗
    "HGC" ∷ GC θ ∗
    "->" ∷ ⌜vl = [ ]⌝ ∗
    "Cont" ∷ ▷ (∀ θ' γ w, GC θ' -∗
                          γ ↦foreignO None -∗
                          ⌜repr_lval θ' (Lloc γ) w⌝ -∗
                          Φ w))%I.

Definition write_foreign_proto : C_proto := (λ fn vl Φ,
  ∃ θ γ w wo w',
    "->" ∷ ⌜fn = "write_foreign"⌝ ∗
    "HGC" ∷ GC θ ∗
    "->" ∷ ⌜vl = [ w; w' ]⌝ ∗
    "%Hreprw" ∷ ⌜repr_lval θ (Lloc γ) w⌝ ∗
    "Hpto" ∷ γ ↦foreignO wo ∗
    "Cont" ∷ ▷ (GC θ -∗
                 γ ↦foreign w' -∗
                 Φ (C_intf.LitV (C_intf.LitInt 0))))%I.

Definition read_foreign_proto : C_proto := (λ fn vl Φ,
  ∃ θ γ w w',
    "->" ∷ ⌜fn = "read_foreign"⌝ ∗
    "HGC" ∷ GC θ ∗
    "->" ∷ ⌜vl = [ w ]⌝ ∗
    "%Hreprw" ∷ ⌜repr_lval θ (Lloc γ) w⌝ ∗
    "Hpto" ∷ γ ↦foreign w' ∗
    "Cont" ∷ ▷ (GC θ -∗
                 γ ↦foreign w' -∗
                 Φ w'))%I.

Definition callback_proto E (Ψ : ML_proto) : C_proto := (λ fn vl Φ,
  ∃ θ w γ w' lv' v' f x e Φ',
    "->" ∷ ⌜fn = "callback"⌝ ∗
    "HGC" ∷ GC θ ∗
    "->" ∷ ⌜vl = [ w; w' ]⌝ ∗
    "%Hreprw" ∷ ⌜repr_lval θ (Lloc γ) w⌝ ∗
    "Hclos" ∷ γ ↦clos (f, x, e) ∗
    "%Hreprw'" ∷ ⌜repr_lval θ lv' w'⌝ ∗
    "Hsim'" ∷ lv' ~~ v' ∗
    "WPcallback" ∷ ▷ WP (App (Val (RecV f x e)) (Val v')) @ ⟨∅, Ψ⟩ ; E {{ Φ' }} ∗
    "Cont" ∷ ▷ (∀ θ' vret lvret wret,
                   GC θ' -∗
                   Φ' vret -∗
                   lvret ~~ vret -∗
                   ⌜repr_lval θ' lvret wret⌝ -∗
                   Φ wret))%I.

Definition main_proto (E: coPset) (e : ML_lang.expr) (Ψ : ML_proto) : C_proto := (λ fn vl Φ,
  ∃ Φ',
  "->" ∷ ⌜fn = "main"⌝ ∗
  "->" ∷ ⌜vl = []⌝ ∗
  "Hat_init" ∷ at_init ∗
  "WPmain" ∷ ▷ WP e @ ⟨∅, Ψ⟩; E {{ Φ' }} ∗
  "Cont" ∷ ▷ (∀ θ' vret lvret wret,
                   GC θ' -∗
                   Φ' vret -∗
                   lvret ~~ vret -∗
                   ⌜repr_lval θ' lvret wret⌝ -∗
                   Φ wret)
  )%I.

Definition prim_proto (p : prim) E (Ψ : ML_proto) : C_proto :=
  match p with
  | Pint2val => int2val_proto
  | Pval2int => val2int_proto
  | Pregisterroot => registerroot_proto
  | Punregisterroot => unregisterroot_proto
  | Pmodify => modify_proto
  | Preadfield => readfield_proto
  | Palloc => alloc_proto
  | Pallocforeign => alloc_foreign_proto
  | Pwriteforeign => write_foreign_proto
  | Preadforeign => read_foreign_proto
  | Pcallback => callback_proto E Ψ
  | Pmain e => main_proto E e Ψ
  end.

Definition prims_proto E e (Ψ : ML_proto) : C_proto :=
  (λ fn vs Φ, ∃ p, ⌜prims_prog e !! fn = Some p⌝ ∗
    prim_proto p E Ψ fn vs Φ)%I.

Lemma proto_prim_mask_mono E1 E2 e Ψ : E1 ⊆ E2 →
  ∀ fn vl Φ, prims_proto E1 e Ψ fn vl Φ -∗ prims_proto E2 e Ψ fn vl Φ.
Proof using.
  iIntros (H fn vl Φ) "H". iDestruct "H" as (p Hp) "H". iExists p.
  iSplit; first done.
  destruct p; try done. all: cbn; iNamed "H".
  { do 10 iExists _; unfold named.
    iFrame. do 4 (iSplit; first done).
    iNext. iApply wp_mask_mono. 1: done.
    iFrame. }
  { unfold main_proto, named. iExists Φ'. iFrame. do 2 (iSplit; first done).
    iNext. iApply wp_mask_mono; first done. iFrame. }
Qed.

Lemma prims_proto_except_dom E e Ψ :
  (prims_proto E e Ψ) except (dom (prims_prog e)) ⊑ ⊥.
Proof using.
  iIntros (? ? ?) "H". rewrite /proto_except.
  iDestruct "H" as (Hdom p ?) "H".
  apply not_elem_of_dom in Hdom.
  destruct p; unfold prim_proto; iNamed "H"; by exfalso.
Qed.

(* some boilerplate *)
Local Ltac tac p :=
  iIntros (? ? ?) "H"; iExists p; (iSplit; last iFrame); by iNamed "H".
Lemma int2val_refines_prims_proto E e Ψ : int2val_proto ⊑ prims_proto E e Ψ.
Proof using. tac Pint2val. Qed.
Lemma val2int_refines_prims_proto E e Ψ : val2int_proto ⊑ prims_proto E e Ψ.
Proof using. tac Pval2int. Qed.
Lemma registerroot_refines_prims_proto E e Ψ : registerroot_proto ⊑ prims_proto E e Ψ.
Proof using. tac Pregisterroot. Qed.
Lemma unregisterroot_refines_prims_proto E e Ψ : unregisterroot_proto ⊑ prims_proto E e Ψ.
Proof using. tac Punregisterroot. Qed.
Lemma modify_refines_prims_proto E e Ψ : modify_proto ⊑ prims_proto E e Ψ.
Proof using. tac Pmodify. Qed.
Lemma readfield_refines_prims_proto E e Ψ : readfield_proto ⊑ prims_proto E e Ψ.
Proof using. tac Preadfield. Qed.
Lemma alloc_refines_prims_proto E e Ψ : alloc_proto ⊑ prims_proto E e Ψ.
Proof using. tac Palloc. Qed.
Lemma alloc_foreign_refines_prims_proto E e Ψ : alloc_foreign_proto ⊑ prims_proto E e Ψ.
Proof using. tac Pallocforeign. Qed.
Lemma write_foreign_refines_prims_proto E e Ψ : write_foreign_proto ⊑ prims_proto E e Ψ.
Proof using. tac Pwriteforeign. Qed.
Lemma read_foreign_refines_prims_proto E e Ψ : read_foreign_proto ⊑ prims_proto E e Ψ.
Proof using. tac Preadforeign. Qed.
Lemma callback_refines_prims_proto E e Ψ : callback_proto E Ψ ⊑ prims_proto E e Ψ.
Proof using. tac Pcallback. Qed.
Lemma main_refines_prims_proto E e Ψ : main_proto E e Ψ ⊑ prims_proto E e Ψ.
Proof using. tac (Pmain e). Qed.

End PrimsProto.

Global Hint Resolve int2val_refines_prims_proto : core.
Global Hint Resolve val2int_refines_prims_proto : core.
Global Hint Resolve registerroot_refines_prims_proto : core.
Global Hint Resolve unregisterroot_refines_prims_proto : core.
Global Hint Resolve modify_refines_prims_proto : core.
Global Hint Resolve readfield_refines_prims_proto : core.
Global Hint Resolve alloc_refines_prims_proto : core.
Global Hint Resolve alloc_foreign_refines_prims_proto : core.
Global Hint Resolve write_foreign_refines_prims_proto : core.
Global Hint Resolve read_foreign_refines_prims_proto : core.
Global Hint Resolve callback_refines_prims_proto : core.
Global Hint Resolve main_refines_prims_proto : core.


(** Sharpened ADT for an expression grammar with parentheses *)
Require Import Coq.Init.Wf Coq.Arith.Wf_nat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List Coq.Strings.String.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.
Require Import Coq.Program.Equality.
Require Import Coq.MSets.MSetPositive.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.LogicFacts.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.Splitters.BruteForce.
Require Import Fiat.Parsers.ParserInterface.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.BooleanRecognizerFull.
Require Import Fiat.Parsers.BooleanRecognizerCorrect.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Parsers.StringLike.FirstChar.
Require Import Fiat.Parsers.StringLike.FirstCharSuchThat.
Require Import Fiat.Parsers.StringLike.LastChar.
Require Import Fiat.Parsers.StringLike.LastCharSuchThat.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.MinimalParseOfParse.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Fold.
Require Import Fiat.Parsers.BaseTypesLemmas.
Require Import Fiat.Parsers.ContextFreeGrammar.Valid.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidProperties.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.Refinement.DisjointLemmasEarlyDeclarations.
Require Import Fiat.Parsers.Refinement.PossibleTerminalsSets.
Require Import Fiat.Common.BoolFacts.
Require Fiat.Parsers.Reachable.All.MinimalReachable.
Require Fiat.Parsers.Reachable.All.MinimalReachableOfReachable.
Require Fiat.Parsers.Reachable.All.ReachableParse.
Require Fiat.Parsers.Reachable.OnlyFirst.MinimalReachable.
Require Fiat.Parsers.Reachable.OnlyFirst.MinimalReachableOfReachable.
Require Fiat.Parsers.Reachable.OnlyFirst.ReachableParse.
Require Fiat.Parsers.Reachable.OnlyLast.MinimalReachable.
Require Fiat.Parsers.Reachable.OnlyLast.MinimalReachableOfReachable.
Require Fiat.Parsers.Reachable.OnlyLast.ReachableParse.
Require Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Fiat.Parsers.Reachable.MaybeEmpty.MinimalOfCore.
Require Fiat.Parsers.Reachable.MaybeEmpty.OfParse.

Set Implicit Arguments.

Local Open Scope string_like_scope.

Local Arguments string_beq : simpl never.

Section search_forward.
  Context {G : pregrammar' Ascii.ascii}
          {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}
          (pdata : possible_data G).

  Local Notation possible_terminals_of nt
    := (@all_possible_ascii_of_nt G pdata nt).
  Local Notation possible_first_terminals_of_production its
    := (@possible_first_ascii_of_production G pdata its).
  Local Notation might_be_empty_of_production its
    := (@might_be_empty_of_pr_production G pdata its).

  Lemma terminals_disjoint_search_for_not'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
  : forall_chars__char_in (take n str) (possible_terminals_of nt)
    /\ ((length str <= n /\ might_be_empty_of_production its)
        \/ (for_first_char
              (drop n str)
              (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt)))
            /\ n < length str)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.le_dec (length str) n); [ left | right ].
      { split; trivial.
        pose proof (drop_length str n) as H.
        rewrite (proj2 (Nat.sub_0_le (length str) n)) in H by assumption.
        generalize dependent (drop n str); clear -pit HinV' HinL HSLP HSIP.
        intros.
        eapply might_be_empty_pr_parse_of_production; eassumption. }
      { split; try omega; [].
        eapply first_char_in__impl__for_first_char;
          [
          | apply possible_first_ascii_parse_of_production; eassumption ].
        intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | assumption ]. } }
    { apply (all_possible_ascii_of_item_nt pit). }
  Qed.

  Lemma terminals_disjoint_search_for_not
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_terminals_of nt) (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_first_char_such_that
        (might_be_empty_of_production its)
        str
        n
        (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt))).
  Proof.
    pose proof (terminals_disjoint_search_for_not' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | H1]]; solve [ left; eauto | right; eauto ] ].
    revert H0.
    apply forall_chars__char_in__impl__forall_chars.
    intros ch H' H''.
    apply Bool.negb_true_iff, Bool.not_true_iff_false in H''.
    apply H''.
    apply list_in_lb; [ apply (@ascii_lb) | ]; assumption.
  Qed.

  Lemma terminals_disjoint_search_for'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_terminals_of nt) (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : forall_chars (take n str)
                   (fun ch => negb (list_bin ascii_beq ch (possible_first_terminals_of_production its)))
      /\ ((length str <= n /\ might_be_empty_of_production its)
          \/ (first_char_in
                (drop n str)
                (possible_first_terminals_of_production its)
              /\ n < length str)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.le_dec (length str) n); [ left | right ].
      { split; trivial.
        pose proof (drop_length str n) as H.
        rewrite (proj2 (Nat.sub_0_le (length str) n)) in H by assumption.
        generalize dependent (drop n str); clear -pit HinV' HinL HSLP HSIP.
        intros.
        eapply might_be_empty_pr_parse_of_production; eassumption. }
      { split; try omega; try assumption.
        apply possible_first_ascii_parse_of_production; assumption. } }
    { eapply forall_chars__char_in__impl__forall_chars.
      { intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | assumption ]. }
      { apply all_possible_ascii_of_item_nt; assumption. } }
  Qed.

  Lemma terminals_disjoint_search_for
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_terminals_of nt) (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_first_char_such_that
        (might_be_empty_of_production its)
        str
        n
        (fun ch => list_bin ascii_beq ch (possible_first_terminals_of_production its)).
  Proof.
    pose proof (terminals_disjoint_search_for' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | [H1 ?]]]; [ right | left; split ]; eauto ].
    { revert H0.
      apply forall_chars_Proper; [ reflexivity | ].
      intros ch H' H''.
      apply Bool.negb_true_iff, Bool.not_true_iff_false in H'.
      apply H'.
      assumption. }
    { revert H1.
      apply first_char_in__impl__for_first_char.
      intros ch H'.
      apply list_in_lb; [ apply (@ascii_lb) | ]; assumption. }
  Qed.
End search_forward.

Section search_backward.
  Context {G : pregrammar' Ascii.ascii}
          {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}
          (pdata : possible_data G).

  Local Notation possible_terminals_of_production its
    := (@all_possible_ascii_of_production G pdata its).
  Local Notation possible_last_terminals_of nt
    := (@possible_last_ascii_of_nt G pdata nt).
  Local Notation might_be_empty_of nt
    := (@might_be_empty_of_pr_nt G pdata nt).

  Lemma terminals_disjoint_rev_search_for_not'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
  : forall_chars__char_in (drop n str) (possible_terminals_of_production its)
    /\ ((n = 0 /\ might_be_empty_of nt)
        \/ (for_last_char
              (take n str)
              (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its)))
            /\ n > 0)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.zerop n); [ left | right ].
      { split; trivial; []; subst.
        eapply might_be_empty_pr_parse_of_item_nt; try eassumption.
        rewrite take_length; reflexivity. }
      { split; try omega; [].
        eapply last_char_in__impl__for_last_char;
          [
          | apply possible_last_ascii_parse_of_item_nt; eassumption ].
        intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | assumption ]. } }
    { apply all_possible_ascii_of_parse_of_production; assumption. }
  Qed.

  Lemma terminals_disjoint_rev_search_for_not
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_after_last_char_such_that
        str
        n
        (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its))).
  Proof.
    pose proof (terminals_disjoint_rev_search_for_not' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | H1]];
        destruct_head and;
        try solve [ left; eauto
                  | right; eauto
                  | assumption
                  | apply for_last_char_nil; rewrite ?take_length; apply Min.min_case_strong; omega ] ].
    revert H0.
    apply forall_chars__char_in__impl__forall_chars.
    intros ch H' H''.
    apply Bool.negb_true_iff, Bool.not_true_iff_false in H''.
    apply H''; clear H''.
    apply list_in_lb; [ apply (@ascii_lb) | ]; assumption.
  Qed.

  Lemma terminals_disjoint_rev_search_for'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : forall_chars (drop n str)
                   (fun ch => negb (list_bin ascii_beq ch (possible_last_terminals_of nt)))
      /\ ((n = 0 /\ might_be_empty_of nt)
          \/ (last_char_in
                (take n str)
                (possible_last_terminals_of nt)
              /\ n > 0)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.zerop n); [ left | right ].
      { split; trivial; [].
        eapply might_be_empty_pr_parse_of_item_nt; try eassumption.
        rewrite take_length; subst; reflexivity. }
      { split; try omega; try assumption; [].
        apply possible_last_ascii_parse_of_item_nt; assumption. } }
    { eapply forall_chars__char_in__impl__forall_chars.
      { intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | eassumption ]. }
      { apply all_possible_ascii_of_parse_of_production; assumption. } }
  Qed.

  Lemma terminals_disjoint_rev_search_for
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_after_last_char_such_that
        str
        n
        (fun ch => list_bin ascii_beq ch (possible_last_terminals_of nt)).
  Proof.
    pose proof (terminals_disjoint_rev_search_for' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | [H1 ?]]];
        try solve [ right; eauto
                  | left; split; eauto
                  | assumption
                  | apply for_last_char_nil; rewrite ?take_length; apply Min.min_case_strong; omega ] ].
    { revert H0.
      apply forall_chars_Proper; [ reflexivity | ].
      intros ch H' H''.
      apply Bool.negb_true_iff, Bool.not_true_iff_false in H'.
      apply H'.
      assumption. }
    { revert H1.
      apply last_char_in__impl__for_last_char.
      intros ch H'.
      apply list_in_lb; [ apply (@ascii_lb) | ]; assumption. }
  Qed.
End search_backward.

Ltac get_grammar :=
  lazymatch goal with
  | [ |- context[ParserInterface.split_list_is_complete_idx ?G] ] => G
  end.

(*Ltac pose_rvalid_for G :=
  lazymatch goal with
  | [ H : is_true (grammar_rvalid G) |- _ ] => idtac
  | _ => let Hvalid := fresh "Hvalid" in
         assert (Hvalid : is_true (grammar_rvalid G))
           by (vm_compute; reflexivity)
  end.
Ltac pose_rvalid := let G := get_grammar in pose_rvalid_for G.*)

Module Export Exports.
  Export DisjointLemmasEarlyDeclarations.
  (** hide the arguments to Build_disjoint_search_data *)
  Local Arguments FromAbstractInterpretation.Build_fold_grammar_data' {_ _ _ _ _} _ _ : assert.
  Notation precomputed_search_data
    := (FromAbstractInterpretation.Build_fold_grammar_data' _ _).

  Ltac do_disjoint_precomputations _ ::=
    let G := get_grammar in
    lazymatch goal with
    | [ |- context[@ParserInterface.split_list_is_complete_idx _ G ?HSLM ?HSL] ]
      => pose (_ : @StringLikeProperties _ HSLM HSL)
    end;
    pose_possible_data_for G.
End Exports.


Require Import msl.Coqlib2.
Require Import msl.eq_dec.
Require Import msl.seplog.
Require Import msl.age_to.
Require Import veric.aging_lemmas.
Require Import veric.juicy_mem.
Require Import veric.juicy_mem_lemmas.
Require Import veric.compcert_rmaps.
Require Import veric.Clight_new.
Require Import veric.semax.
Require Import veric.semax_ext.
Require Import veric.juicy_extspec.
Require Import veric.juicy_extspec.
Require Import veric.tycontext.
Require Import veric.res_predicates.
Require Import veric.mem_lessdef.
Require Import veric.coqlib4.
Require Import concurrency.lksize.
Require Import concurrency.sync_preds_defs.

Set Bullet Behavior "Strict Subproofs".

Lemma resource_decay_LK {b phi phi' loc rsh sh n pp} :
  resource_decay b phi phi' ->
  phi @ loc = YES rsh sh (LK n) pp ->
  phi' @ loc = YES rsh sh (LK n) (preds_fmap (approx (level phi')) (approx (level phi')) pp).
Proof.
  intros [L R] E.
  specialize (R loc).
  rewrite E in *.
  destruct R as [N [R|[R|[R|R]]]].
  - rewrite <- R.
    reflexivity.
  - destruct R as [sh' [v [v' [R H]]]]. simpl in R. congruence.
  - destruct R as [v [v' R]]. specialize (N ltac:(auto)). congruence.
  - destruct R as [v [pp' [R H]]]. congruence.
Qed.

Lemma resource_decay_CT {b phi phi' loc rsh sh n} :
  resource_decay b phi phi' ->
  phi @ loc = YES rsh sh (CT n) NoneP ->
  phi' @ loc = YES rsh sh (CT n) NoneP.
Proof.
  intros [L R] E.
  specialize (R loc).
  rewrite E in *.
  destruct R as [N [R|[R|[R|R]]]].
  - rewrite <- R.
    unfold resource_fmap in *; f_equal.
  - destruct R as [sh' [v [v' [R H]]]]. simpl in R. congruence.
  - destruct R as [v [v' R]]. specialize (N ltac:(auto)). congruence.
  - destruct R as [v [pp' [R H]]]. congruence.
Qed.

Lemma resource_decay_LK_inv {b phi phi' loc rsh sh n pp'} :
  resource_decay b phi phi' ->
  phi' @ loc = YES rsh sh (LK n) pp' ->
  exists pp,
    pp' = preds_fmap (approx (level phi')) (approx (level phi')) pp /\
    phi @ loc = YES rsh sh (LK n) pp.
Proof.
  intros [L R] E.
  specialize (R loc).
  rewrite E in *.
  destruct R as [N [R|[R|[R|R]]]].
  - destruct (phi @ loc); simpl in R; try discriminate.
    eexists.
    injection R. intros; subst.
    split; reflexivity.
  - destruct R as [sh' [v [v' [R H]]]]; congruence.
  - destruct R as [v [v' R]]; congruence.
  - destruct R as [v [pp [R H]]]; congruence.
Qed.

Lemma resource_decay_identity {b phi phi' loc} :
  resource_decay b phi phi' ->
  (fst loc < b)%positive ->
  identity (phi @ loc) ->
  identity (phi' @ loc).
Proof.
  intros [lev RD] LT ID; specialize (RD loc).
  destruct RD as [N [RD|[RD|[RD|RD]]]].
  destruct (phi @ loc) as [t | t p k p0 | k p]; simpl in RD; try rewrite <- RD.
  - auto.
  - apply YES_not_identity in ID. tauto.
  - apply PURE_identity.
  - destruct RD as (? & sh & _ & E & _).
    destruct (phi @ loc); simpl in E; try discriminate.
    apply YES_not_identity in ID. tauto.
  - destruct RD. auto with *.
  - destruct RD as (? & ? & ? & ->).
    apply NO_identity.
Qed.

Lemma resource_decay_LK_at {b phi phi' R sh loc} :
  resource_decay b phi phi' ->
  (fst loc < b)%positive ->
  (LK_at R sh loc) phi ->
  (LK_at (approx (level phi) R) sh loc) phi'.
Proof.
  intros RD LT LKAT loc'.
  specialize (LKAT loc').
  destruct (adr_range_dec loc LKSIZE loc') as [range|notrange]; swap 1 2.
  - rewrite jam_false in *; auto.
  - rewrite jam_true in *; auto.
    destruct (eq_dec loc loc') as [<-|noteq].
    + rewrite jam_true in *; auto.
      destruct LKAT as [p E]; simpl in E.
      apply (resource_decay_LK RD) in E.
      eexists.
      hnf.
      rewrite E.
      reflexivity.
    + rewrite jam_false in *; auto.
      destruct LKAT as [p E]; simpl in E.
      eexists; simpl.
      apply (resource_decay_CT RD) in E.
      rewrite E.
      reflexivity.
Qed.

Lemma resource_decay_lkat' {b phi phi' R loc} :
  resource_decay b phi phi' ->
  (fst loc < b)%positive ->
  (lkat R loc) phi ->
  (lkat (approx (level phi) R) loc) phi'.
Proof.
  intros RD LT LKAT loc' r.
  specialize (LKAT loc' r).
  destruct LKAT as (sh & rsh & E); exists sh, rsh.
  if_tac.
  - apply (resource_decay_LK RD) in E. rewrite E; reflexivity.
  - apply (resource_decay_CT RD) in E. rewrite E; reflexivity.
Qed.

Lemma resource_decay_lkat {b phi phi' R loc} :
  resource_decay b phi phi' ->
  (fst loc < b)%positive ->
  (lkat R loc) phi ->
  (lkat (approx (level phi') R) loc) phi'.
Proof.
  intros RD LT LKAT loc' r.
  specialize (LKAT loc' r).
  destruct LKAT as (sh & rsh & E); exists sh, rsh.
  if_tac.
  - apply (resource_decay_LK RD) in E. rewrite E. f_equal.
    unfold preds_fmap in *.
    unfold pack_res_inv in *.
    f_equal.
    unfold fmap.
    simpl.
    extensionality Ts.
    destruct RD as (Hlev, _).
    pose proof approx_oo_approx' (level phi') (level phi) as RR'.
    pose proof approx_oo_approx (level phi') as RR.
    autospec RR'.
    unfold "oo" in *.
    rewrite (equal_f RR' R).
    rewrite (equal_f RR R).
    reflexivity.
  - apply (resource_decay_CT RD) in E. rewrite E; reflexivity.
Qed.

Lemma resource_decay_LK_at' {b phi phi' R sh loc} :
  resource_decay b phi phi' ->
  (fst loc < b)%positive ->
  (LK_at R sh loc) phi ->
  (LK_at (approx (level phi') R) sh loc) phi'.
Proof.
  intros RD LT LKAT loc'.
  specialize (LKAT loc').
  destruct (adr_range_dec loc LKSIZE loc') as [range|notrange]; swap 1 2.
  - rewrite jam_false in *; auto.
  - rewrite jam_true in *; auto.
    destruct (eq_dec loc loc') as [<-|noteq].
    + rewrite jam_true in *; auto.
      destruct LKAT as [p E]; simpl in E.
      apply (resource_decay_LK RD) in E.
      eexists.
      hnf.
      rewrite E.
      f_equal.
      simpl.
      f_equal.
      extensionality.
      change (approx (level phi') (approx (level phi) R)) with
       ((approx (level phi') oo approx (level phi)) R).
      rewrite approx_oo_approx' by apply RD.
      unfold "oo".
      change (approx (level phi')   (approx (level phi')  R))
      with  ((approx (level phi') oo approx (level phi')) R).
      rewrite approx_oo_approx.
      reflexivity.
    + rewrite jam_false in *; auto.
      destruct LKAT as [p E]; simpl in E.
      eexists; simpl.
      apply (resource_decay_CT RD) in E.
      rewrite E.
      reflexivity.
Qed.

Lemma resource_decay_PURE {b phi phi'} :
  resource_decay b phi phi' ->
  forall loc sh P,
    phi @ loc = PURE sh P ->
    phi' @ loc = PURE sh (preds_fmap (approx (level phi')) (approx (level phi')) P).
Proof.
  intros [L RD] loc sh P PAT.
  specialize (RD loc).
  destruct RD as [N [RD|[RD|[RD|RD]]]].
  - rewrite PAT in RD; simpl in RD. rewrite RD; auto.
  - rewrite PAT in RD; simpl in RD. destruct RD as (?&?&?&?&?). congruence.
  - rewrite PAT in N. pose proof (N (proj1 RD)). congruence.
  - rewrite PAT in RD; simpl in RD. destruct RD as (?&?&?&?). congruence.
Qed.

Lemma resource_decay_PURE_inv {b phi phi'} :
  resource_decay b phi phi' ->
  forall loc sh P',
    phi' @ loc = PURE sh P' ->
    exists P,
      phi @ loc = PURE sh P /\
      P' = preds_fmap (approx (level phi')) (approx (level phi')) P.
Proof.
  intros [L RD] loc sh P PAT.
  specialize (RD loc).
  destruct RD as [N [RD|[RD|[RD|RD]]]].
  all: rewrite PAT in *; destruct (phi @ loc); simpl in *.
  all: inversion RD; subst; eauto.
  all: repeat match goal with H : ex _ |- _ => destruct H end.
  all: repeat match goal with H : and _ _ |- _ => destruct H end.
  all: discriminate.
Qed.

Lemma resource_decay_func_at' {b phi phi'} :
  resource_decay b phi phi' ->
  forall loc fs,
    seplog.func_at' fs loc phi ->
    seplog.func_at' fs loc phi'.
Proof.
  intros RD loc [f cc A P Q] [pp E]; simpl.
  rewrite (resource_decay_PURE RD _ _ _ E).
  eexists. reflexivity.
Qed.

Lemma resource_decay_func_at'_inv {b phi phi'} :
  resource_decay b phi phi' ->
  forall loc fs,
    seplog.func_at' fs loc phi' ->
    seplog.func_at' fs loc phi.
Proof.
  intros RD loc [f cc A P Q] [pp E]; simpl.
  destruct (resource_decay_PURE_inv RD _ _ _ E) as [pp' [Ephi E']].
  pose proof resource_at_approx phi loc as H.
  rewrite Ephi in H at 1. rewrite <-H.
  eexists. reflexivity.
Qed.

Lemma resource_decay_same_locks {b phi phi'} :
  resource_decay b phi phi' -> same_locks phi phi'.
Proof.
  intros R loc; split; intros (rsh & sh & n & pp & E).
  - repeat eexists. eapply resource_decay_LK in E; eauto.
  - destruct (resource_decay_LK_inv R E) as [pp' [E' ->]].
    repeat eexists.
Qed.

Lemma resource_decay_same_locks_sized {b phi phi'} :
  resource_decay b phi phi' -> same_locks_sized phi phi'.
Proof.
  intros R loc n; split; intros (rsh & sh & pp & E).
  - repeat eexists. eapply resource_decay_LK in E; eauto.
  - destruct (resource_decay_LK_inv R E) as [pp' [E' ->]].
    repeat eexists.
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: Assembly Verification 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 Locations.
Require Import AuxStateDataType.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import FlatMemory.
Require Import RefinementTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import Constant.
Require Import AsmImplLemma.
Require Import AsmImplTactic.
Require Import GlobIdent.
Require Import CommonTactic.

Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compcertx.MakeProgram.
(*Require Import LAsmModuleSem.*)
Require Import LAsm.

Require Import MContainer.
Require Import PTIntroGenSpec.
Require Import PTIntroGenAsmSource.
Require Import LAsmModuleSemSpec.
Require Import LinkTactic.

Require Import AbstractDataType.

Section ASM_VERIFICATION.

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

  Context `{real_params: RealParams}.

  Notation LDATA := RData.
  Notation LDATAOps := (cdata (cdata_ops := mcontainer_data_ops) LDATA).

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.
    Context `{make_program_ops: !MakeProgramOps function Ctypes.type fundef unit}.
    Context `{make_program_prf: !MakeProgram function Ctypes.type fundef unit}.

    Lemma pt_in_code_correct:
      asm_spec_le (pt_in ↦ pt_in_spec_low)
                  (〚pt_in ↦ ptin_function 〛 mcontainer).
    Proof.
      eapply asm_sem_intro; try reflexivity; simpl.
      intros. inv H.
      eapply make_program_make_globalenv in H0.
      exploit (make_globalenv_stencil_matches (D:= LDATAOps)); eauto.
      intros Hstencil_matches.
      assert(Hfun: Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal ptin_function)).
      {
        assert (Hmodule: get_module_function pt_in (pt_in ↦ ptin_function) = OK (Some ptin_function)) by
            reflexivity.
        assert (HInternal: make_internal ptin_function = OK (AST.Internal ptin_function)) by reflexivity.
        eapply make_globalenv_get_module_function in H0; eauto.
        destruct H0 as [?[Hsymbol ?]].
        inv Hstencil_matches.
        rewrite stencil_matches_symbols in Hsymbol.
        rewrite H1 in Hsymbol. inv Hsymbol.
        assumption.
      }
      refine_split'.
      - reflexivity.
      - econstructor; eauto.
        one_step_forward 0.
        + reflexivity.
        + econstructor.
        + reflexivity.
      - reflexivity.
      - inv H4. inv inv_inject_neutral.
        eapply Mem.neutral_inject in inv_mem_inject_neutral.
        assumption.
      - lift_trivial.
        reflexivity.
      - intros reg.
        repeat (rewrite Pregmap.gsspec).
        simpl_destruct_reg.
        constructor.
      - esplit; reflexivity.
    Qed.

    Lemma pt_out_code_correct:
      asm_spec_le (pt_out ↦ pt_out_spec_low)
                  (〚pt_out ↦ ptout_function 〛 mcontainer).
    Proof.
      eapply asm_sem_intro; try reflexivity; simpl.
      intros. inv H.
      eapply make_program_make_globalenv in H0.
      exploit (make_globalenv_stencil_matches (D:= LDATAOps)); eauto.
      intros Hstencil_matches.
      assert(Hfun: Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal ptout_function)).
      {
        assert (Hmodule: get_module_function pt_out (pt_out ↦ ptout_function) = OK (Some ptout_function)) by
            reflexivity.
        assert (HInternal: make_internal ptout_function = OK (AST.Internal ptout_function)) by reflexivity.
        eapply make_globalenv_get_module_function in H0; eauto.
        destruct H0 as [?[Hsymbol ?]].
        inv Hstencil_matches.
        rewrite stencil_matches_symbols in Hsymbol.
        rewrite H1 in Hsymbol. inv Hsymbol.
        assumption.
      }
      refine_split'.
      - reflexivity.
      - econstructor; eauto.
        one_step_forward 0.
        + reflexivity.
        + econstructor.
        + reflexivity.
      - reflexivity.
      - inv H4. inv inv_inject_neutral.
        eapply Mem.neutral_inject in inv_mem_inject_neutral.
        assumption.
      - lift_trivial.
        reflexivity.
      - intros reg.
        repeat (rewrite Pregmap.gsspec).
        simpl_destruct_reg.
        constructor.
      - esplit; reflexivity.
    Qed.

  End WITHMEM.

End ASM_VERIFICATION.