Require Import Bedrock.Bedrock Bedrock.Platform.PreAutoSep.

(** * Separation logic specifications for system calls *)

Definition abortS := SPEC reserving 0
  PREonly[_] Emp.

Definition printIntS := SPEC("n") reserving 0
  PRE[_] Emp
  POST[_] Emp.

Definition listenS := SPEC("port") reserving 0
  PRE[_] Emp
  POST[stream] Emp.

Definition acceptS := SPEC("stream") reserving 0
  PRE[_] Emp
  POST[stream'] Emp.

Definition buffer (p : W) (size : nat) : HProp :=
  (Ex bs, array8 bs p * [| length bs = size |])%Sep.

Infix "=?>8" := buffer (at level 39) : Sep_scope.
Notation "buf =?>8 size" := (Body (buf =?>8 size)%Sep) : qspec_scope.

Definition connectS := SPEC("address", "size") reserving 0
  PRE[V] V "address" =?>8 wordToNat (V "size")
  POST[bytesRead] V "address" =?>8 wordToNat (V "size").

Definition readS := SPEC("stream", "buffer", "size") reserving 0
  PRE[V] V "buffer" =?>8 wordToNat (V "size")
  POST[bytesRead] V "buffer" =?>8 wordToNat (V "size").

Definition writeS := SPEC("stream", "buffer", "size") reserving 0
  PRE[V] V "buffer" =?>8 wordToNat (V "size")
  POST[bytesWritten] V "buffer" =?>8 wordToNat (V "size").

(* Limited version of epoll_ctl *)
Definition declareS := SPEC("stream", "mode") reserving 0
  PRE[_] Emp
  POST[index] Emp.
(* Mode is either 0 for read or 1 for write. *)

(* Limited version of epoll_wait *)
Definition waitS := SPEC("blocking") reserving 0
  PRE[_] Emp
  POST[index] Emp.

Definition closeS := SPEC("stream") reserving 0
  PRE[_] Emp
  POST[_] Emp.

(** * More primitive operational semantics *)

Definition mapped (base : W) (len : nat) (m : mem) :=
  forall n, (n < len)%nat -> m (base ^+ $ (n)) <> None.

Record onlyChange (base : W) (len : nat) (m m' : mem) : Prop :=
  { Elsewhere : forall p, (forall n, (n < len)%nat -> p <> base ^+ $ (n))
    -> m' p = m p;
    SameMapped : forall p, m p = None <-> m' p = None }.

Hint Constructors onlyChange.

Section OpSem.
  Variable stn : settings.
  Variable prog : program.

  Inductive sys_step : state' -> state' -> Prop :=
  | Normal : forall st st', step stn prog st = Some st'
    -> sys_step st st'
  | Abort : forall st, Labels stn ("sys", Global "abort") = Some (fst st)
    -> sys_step st st
  | PrintInt : forall st st',
    Labels stn ("sys", Global "printInt") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Listen : forall st st', Labels stn ("sys", Global "listen") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Accept : forall st st',
    Labels stn ("sys", Global "accept") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Connect : forall st address size st',
    Labels stn ("sys", Global "connect") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 12 (Mem (snd st))
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $4) = Some address
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $8) = Some size
    -> mapped address (wordToNat size) (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> onlyChange address (wordToNat size) (Mem (snd st)) (Mem st')
    -> sys_step st (Regs (snd st) Rp, st')
  | Read : forall st buffer size st',
    Labels stn ("sys", Global "read") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 16 (Mem (snd st))
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $8) = Some buffer
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $12) = Some size
    -> mapped buffer (wordToNat size) (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> onlyChange buffer (wordToNat size) (Mem (snd st)) (Mem st')
    -> sys_step st (Regs (snd st) Rp, st')
  | Write : forall st buffer size st',
    Labels stn ("sys", Global "write") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 16 (Mem (snd st))
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $8) = Some buffer
    -> ReadWord stn (Mem (snd st)) (Regs (snd st) Sp ^+ $12) = Some size
    -> mapped buffer (wordToNat size) (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Declare : forall st st',
    Labels stn ("sys", Global "declare") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 12 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Wait : forall st st',
    Labels stn ("sys", Global "wait") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st')
  | Close : forall st st',
    Labels stn ("sys", Global "close") = Some (fst st)
    -> mapped (Regs (snd st) Sp) 8 (Mem (snd st))
    -> Regs st' Sp = Regs (snd st) Sp
    -> Mem st' = Mem (snd st)
    -> sys_step st (Regs (snd st) Rp, st').

  Inductive sys_reachable : state' -> state' -> Prop :=
  | SR0 : forall st, sys_reachable st st
  | SR1 : forall st st' st'', sys_step st st'
    -> sys_reachable st' st''
    -> sys_reachable st st''.

  Definition sys_safe (st : state') :=
    forall st', sys_reachable st st' -> exists st'', sys_step st' st''.
End OpSem.


From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.
From cap_machine Require Import machine_base rules_base.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  (* TODO: move to stdpp *)
  Tactic Notation "destruct_or" ident(H) :=
  match type of H with
  | _ ∨ _ => destruct H as [H|H]
  | Is_true (_ || _) => apply orb_True in H; destruct H as [H|H]
  end.
  Tactic Notation "destruct_or" "?" ident(H) := repeat (destruct_or H).
  Tactic Notation "destruct_or" "!" ident(H) := hnf in H; destruct_or H; destruct_or? H.

  Definition denote (i: instr) (n1 n2: Z): Z :=
    match i with
    | machine_base.Add _ _ _ => (n1 + n2)%Z
    | Sub _ _ _ => (n1 - n2)%Z
    | Lt _ _ _ => (Z.b2z (n1 <? n2)%Z)
    | _ => 0%Z
    end.

  Definition is_AddSubLt (i: instr) (r: RegName) (arg1 arg2: Z + RegName) :=
    i = machine_base.Add r arg1 arg2 ∨
    i = Sub r arg1 arg2 ∨
    i = Lt r arg1 arg2.

  Lemma regs_of_is_AddSubLt i r arg1 arg2 :
    is_AddSubLt i r arg1 arg2 →
    regs_of i = {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2.
  Proof.
    intros HH. destruct_or! HH; subst i; reflexivity.
  Qed.

  Inductive AddSubLt_failure (i: instr) (regs: Reg) (dst: RegName) (rv1 rv2: Z + RegName) (regs': Reg) :=
  | AddSubLt_fail_nonconst1:
      z_of_argument regs rv1 = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'
  | AddSubLt_fail_nonconst2:
      z_of_argument regs rv2 = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'
  | AddSubLt_fail_incrPC n1 n2:
      z_of_argument regs rv1 = Some n1 ->
      z_of_argument regs rv2 = Some n2 ->
      incrementPC (<[ dst := inl (denote i n1 n2) ]> regs) = None ->
      regs' = (<[ dst := inl (denote i n1 n2) ]> regs) ->
      AddSubLt_failure i regs dst rv1 rv2 regs'.

  Inductive AddSubLt_spec (i: instr) (regs: Reg) (dst: RegName) (rv1 rv2: Z + RegName) (regs': Reg): cap_lang.val -> Prop :=
  | AddSubLt_spec_success n1 n2:
      z_of_argument regs rv1 = Some n1 ->
      z_of_argument regs rv2 = Some n2 ->
      incrementPC (<[ dst := inl (denote i n1 n2) ]> regs) = Some regs' ->
      AddSubLt_spec i regs dst rv1 rv2 regs' NextIV
  | AddSubLt_spec_failure:
      AddSubLt_failure i regs dst rv1 rv2 regs' ->
      AddSubLt_spec i regs dst rv1 rv2 regs' FailedV.

  Local Ltac iFail Hcont get_fail_case :=
    cbn; iFrame; iApply Hcont; iFrame; iPureIntro;
    econstructor; eapply get_fail_case; eauto.

  Lemma wp_AddSubLt Ep i pc_p pc_g pc_b pc_e pc_a w dst arg1 arg2 regs :
    decodeInstrW w = i →
    is_AddSubLt i dst arg1 arg2 →
    isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs_of i ⊆ dom _ regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ AddSubLt_spec (decodeInstrW w) regs dst arg1 arg2 regs' retv ⌝ ∗
          pc_a ↦ₐ w ∗
          [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hdecode Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1 as [r m]; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    erewrite regs_of_is_AddSubLt in Hri, Dregs; eauto.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    destruct (z_of_argument regs arg1) as [n1|] eqn:Hn1;
      pose proof Hn1 as Hn1'; cycle 1.
    (* Failure: arg1 is not an integer *)
    { unfold z_of_argument in Hn1. destruct arg1 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hn1. destruct r0v as [| (([[? ?] ?] & ?) & ?) ]; [ congruence |].
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      { destruct_or! Hinstr; rewrite Hinstr /= in Hstep.
        all: rewrite /RegLocate Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFail "Hφ" AddSubLt_fail_nonconst1. }

    destruct (z_of_argument regs arg2) as [n2|] eqn:Hn2;
      pose proof Hn2 as Hn2'; cycle 1.
    (* Failure: arg2 is not an integer *)
    { unfold z_of_argument in Hn2. destruct arg2 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hn2. destruct r0v as [| (([[? ?] ?] & ?) & ?) ]; [ congruence |].
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      { destruct_or! Hinstr; rewrite Hinstr /= in Hstep.
        all: rewrite /RegLocate Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFail "Hφ" AddSubLt_fail_nonconst2. }

    eapply z_of_argument_Some_inv' in Hn1; eapply z_of_argument_Some_inv' in Hn2; eauto.

    assert ((c, σ2) = updatePC (update_reg (r, m) dst (inl (denote i n1 n2)))) as HH.
    { destruct Hn1 as [ -> | (r1 & -> & _ & Hr1) ]; destruct Hn2 as [ -> | (r2 & -> & _ & Hr2) ].
      all: destruct_or! Hinstr; rewrite Hinstr /= /RegLocate /update_reg /= in Hstep |- *; auto.
      all: rewrite ?Hr1 ?Hr2 /= in Hstep; auto. }
    rewrite /update_reg /= in HH.

    destruct (incrementPC (<[ dst := inl (denote i n1 n2) ]> regs))
      as [regs'|] eqn:Hregs'; pose proof Hregs' as H'regs'; cycle 1.
    (* Failure: Cannot increment PC *)
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
      iFail "Hφ" AddSubLt_fail_incrPC. }

    (* Success *)

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Ha_pc' & HuPC & -> & X).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto.
    simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iModIntro. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  (* Derived specifications *)

  Lemma wp_add_sub_lt_success_z_z E dst pc_p pc_g pc_b pc_e pc_a w wdst ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite insert_commute // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "[? ?]"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_z E dst pc_p pc_g pc_b pc_e pc_a w wdst ins r1 n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ inl n1
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl n1
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr1 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r1 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_z_r E dst pc_p pc_g pc_b pc_e pc_a w wdst ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r2 ↦ᵣ inl n2
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ inl n2
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_r E dst pc_p pc_g pc_b pc_e pc_a w wdst ins r1 n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ inl n1
        ∗ r2 ↦ᵣ inl n2
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl n1
          ∗ r2 ↦ᵣ inl n2
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr1 & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_4 with "HPC Hr1 Hr2 Hdst") as "[Hmap (%&%&%&%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ r1 dst) // (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_4 with "Hmap") as "(?&?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H8 as [? | [? | [? | [? | ?]]]]; destruct H15 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_r_same E dst pc_p pc_g pc_b pc_e pc_a w wdst ins r n pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r) (inr r) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r ↦ᵣ inl n
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r ↦ᵣ inl n
          ∗ dst ↦ᵣ inl (denote ins n n)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_z E dst pc_p pc_g pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ inl n1
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_z_dst E dst pc_p pc_g pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ inl n2
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_r E dst pc_p pc_g pc_b pc_e pc_a w ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r2 ↦ᵣ inl n2
        ∗ dst ↦ᵣ inl n1
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ inl n2
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_dst E dst pc_p pc_g pc_b pc_e pc_a w ins r1 n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ inl n1
        ∗ dst ↦ᵣ inl n2
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl n1
          ∗ dst ↦ᵣ inl (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r1 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H5 as [? | [? | [? | [? | ?]]]]; destruct H12 as [? | [? | ?]]; congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_dst E dst pc_p pc_g pc_b pc_e pc_a w ins n pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) ->

    {{{ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ inl n
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ inl (denote ins n n)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
      destruct e1; try congruence.
      inv Hvpc. destruct H3 as [? | [? | [? | [? | ?]]]]; destruct H10 as [? | [? | ?]]; congruence. }
  Qed.

End cap_lang_rules.

(* Hints to automate proofs of is_AddSubLt *)
Lemma is_AddSubLt_Add dst arg1 arg2 :
  is_AddSubLt (machine_base.Add dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.
Lemma is_AddSubLt_Sub dst arg1 arg2 :
  is_AddSubLt (Sub dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.
Lemma is_AddSubLt_Lt dst arg1 arg2 :
  is_AddSubLt (Lt dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.

Global Hint Resolve is_AddSubLt_Add : core.
Global Hint Resolve is_AddSubLt_Sub : core.
Global Hint Resolve is_AddSubLt_Lt : core.


From mtl.Classes Require Import Monad.

Record Identity (a : Type) : Type :=
  MkIdentity { runIdentity : a }.

Arguments MkIdentity {a} _.
Arguments runIdentity {a} _.

Lemma injective_runIdentity {a} (u v : Identity a)
  : runIdentity u = runIdentity v -> u = v.
Proof.
  destruct u, v; intros; f_equal; auto.
Qed.

Instance Monad_Identity : Monad Identity :=
  { pure _ := MkIdentity
  ; bind _ _ u k := k (runIdentity u)
  }.

Instance LawfulMonad_Identity : LawfulMonad Identity.
Proof.
  split; intros; apply injective_runIdentity; reflexivity.
Qed.


(* PREAMBLE *)

From compcert.common     Require Memory.
From compcert.cfrontend  Require Csem.
From compcert.lib        Require Coqlib.

From trancert.lib        Require All.
From trancert.properties Require memory.Assign Env.

Import Csem Memory Mem Coqlib Tac lib.All Assign properties.Env.

(** [bind_parameters] does not change memory size ([nextblock]). *)

Theorem bind_parameters_nextblock:
  forall ge e1 m1 ps vs m2,
    bind_parameters ge e1 m1 ps vs m2 ->
    nextblock m1 = nextblock m2.
Proof.
  intros ge e1 m1 ps vs m2 H.
  induction H;auto.
  eapply assign_loc_nextblock in H0; eauto.
  rewrite <-IHbind_parameters, H0. reflexivity.
Qed.

Theorem bind_parameters_env_freeable_any:
  forall (ge:genv) e m1 e' params vargs m2,
    env_freeable ge m1 e  ->
    bind_parameters ge e' m1 params vargs m2 ->
    env_freeable ge m2 e.
Proof.
  intros ge e m1 e' params vargs m2 H H0.
  unfold env_freeable in *.
  induction H0; eauto.
  apply IHbind_parameters.
  intros i b0 t0 H3 delta Hdelta.
  eapply assign_loc_perm; eauto.
  eapply H; eauto.
Qed.


From Coq Require Import String HexString ZArith.
From Vyper Require Import Config.
From Vyper.L50 Require Import Types.

Inductive expr {C: VyperConfig}
:= FunCall (name: string) (args: list expr)
 | LocVar (name: string)
 | Const (t: yul_type) (val: yul_value t).

Definition typename: Type := yul_type * string.

Inductive stmt {C: VyperConfig}
:= BlockStmt (s: block)
 | VarDecl (vars: list typename) (init: option expr)
 | Assign (lhs: list string) (rhs: expr)
 | If (cond: expr) (body: block)
 | Expr (e: expr)
 | Switch (e: expr) (cases: list case) (default: option block)
 | For (init: block) (cond: expr) (after body: block)
 | Break
 | Continue
 | Leave
with case  {C: VyperConfig} := Case (t: yul_type) (val: yul_value t) (body: block)
with block {C: VyperConfig} := Block (body: list stmt).

Record fun_decl {C: VyperConfig} := {
  fd_name: string;
  fd_inputs: list typename;
  fd_outputs: list typename;
  fd_body: block;
}.

Definition program {C: VyperConfig}: Type := string_map fun_decl * block.

Definition is_var_decl {C: VyperConfig} (s: stmt)
:= match s with
   | VarDecl _ _ => true
   | _ => false
   end.

Program Definition var_decl_unpack {C: VyperConfig} (s: stmt) (IsVarDecl: is_var_decl s = true)
: list typename * option expr
:= match s with
   | VarDecl vars init => (vars, init)
   | _ => False_rect _ _
   end.
Next Obligation.
destruct s; cbn in IsVarDecl; try discriminate.
exact (H vars init eq_refl).
Qed.

(****************************   print   ******************************)

Local Open Scope list_scope.
Local Open Scope string_scope.

Fixpoint to_comma_list {A} (s: A -> string) (l: list A)
: string
:= match l with
   | nil => ""
   | x :: nil => s x
   | h :: t => s h ++ ", " ++ to_comma_list s t
   end.

Definition string_of_typename (tn: typename)
:= let '(t, n) := tn in
   n ++ ":" ++ string_of_type t.

Definition string_of_yul_value {C: VyperConfig} {t: yul_type} (v: yul_value t)
:= match v with
   | NumberValue _ value _ => HexString.of_Z (Z_of_uint256 value)
   | BoolValue _ true _ => "true"
   | BoolValue _ false _ => "false"
   end.

Fixpoint string_of_expr {C: VyperConfig} (e: expr)
:= match e with
   | FunCall name args => (name ++ "(" ++
                          (* Coq won't allow to_comma_list here *)
                          (fix string_of_exprs (l: list expr) :=
                             match l with
                             | nil => ""
                             | x :: nil => string_of_expr x
                             | h :: t => string_of_expr h ++ ", " ++ string_of_exprs t
                             end) args
                            ++ ")")%string
   | LocVar name => name
   | Const t v => string_of_yul_value v ++ ":" ++ string_of_type t
   end.

Definition attach (a b: list string)
: list string
:= match b with
   | nil => a
   | hb :: tb =>
     let a' := List.rev a in
       match a' with
       | nil => b
       | ha :: ta => List.rev ta ++ (ha ++ " " ++ hb) :: tb
       end
   end.

Fixpoint lines_of_stmt {C: VyperConfig} (s: stmt)
: list string
:= match s with
   | BlockStmt b => lines_of_block b
   | VarDecl vars init => ("let " ++ to_comma_list string_of_typename vars
                             ++ match init with
                                | Some e => " := " ++ string_of_expr e
                                | None => ""
                                end) :: nil
   | Assign lhs rhs => (to_comma_list id lhs ++ " := " ++ string_of_expr rhs) :: nil
   | If cond body => ("if " ++ string_of_expr cond) :: lines_of_block body
   | Expr e => string_of_expr e :: nil
   | Switch e cases default =>
      ("switch " ++ string_of_expr e) ::
      (fix lines_of_cases (l: list case): list string :=
        match l with
        | nil => nil
        | h :: t => (lines_of_case h ++ lines_of_cases t)%list
        end) cases ++
       match default with
       | None => nil
       | Some def => "default" :: lines_of_block def
       end
   | For init cond inc body => attach ("for" :: nil)
                                      (attach (lines_of_block init)
                                              (attach (string_of_expr cond :: nil)
                                                      (lines_of_block inc)))
                                ++ lines_of_block body
   | Break => "break" :: nil
   | Continue => "continue" :: nil
   | Leave => "leave" :: nil
   end
with lines_of_case {C: VyperConfig} (c: case)
: list string
:= let '(Case t v body) := c in
   ("case " ++ string_of_yul_value v ++ ":" ++ string_of_type t) :: lines_of_block body
with lines_of_block {C: VyperConfig} (b: block)
: list string
:= let fix lines_of_stmts (l: list stmt) :=
          match l with
          | nil => nil
          | h :: t => (lines_of_stmt h ++ lines_of_stmts t)%list
          end in
   let '(Block stmts) := b in
   let lines := lines_of_stmts stmts in
   match lines with
   | nil => "{}" :: nil
   | line :: nil => ("{ " ++ line ++ " }") :: nil
   | _ => "{" :: List.map (fun x => "    " ++ x) lines ++ "}" :: nil
   end.

(** Name override is needed because fd_name not properly mangled.
    (Actually fun_decl has no reason to store its name at all.)
 *)
Definition lines_of_fun_decl {C: VyperConfig} (fd: fun_decl) (override_name: string)
:= ("function " ++ override_name ++
      "(" ++ to_comma_list string_of_typename (fd_inputs fd) ++ ")" ++
      match fd_outputs fd with
      | nil => ""
      | _ => " -> " ++ to_comma_list string_of_typename (fd_outputs fd)
      end)
   :: lines_of_block (fd_body fd).

Definition lines_of_fun_decls {C: VyperConfig} (decls: string_map fun_decl)
:= let _ := string_map_impl in
   (fix lines_of_alist (l: list (string * fun_decl))
    := match l with
       | nil => nil
       | h :: t => let '(k, v) := h in (lines_of_fun_decl v k ++ lines_of_alist t)%list
       end) (Map.items decls).


From Undecidability Require Import L.Util.L_facts.

From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
Require Import List.

Require Import Undecidability.TM.Util.TM_facts.

From Undecidability Require Import ProgrammingTools LM_heap_def WriteValue CaseList Copy ListTM Hoare.
From Undecidability.TM.L Require Import JumpTargetTM Alphabets M_LHeapInterpreter.
From Undecidability Require Import L.AbstractMachines.FlatPro.LM_heap_correct.

Require Import List.

Import Vector.VectorNotations.
Import ListNotations ResourceMeasures.

From Undecidability.TM.L Require Import UnfoldClos.

Import CasePair Code.CaseList.

Set Default Proof Using "Type".

Module EvalL.
Section Fix.

  Variable Σ : finType.

  Definition Σintern :Type := sigStep + sigList (sigPair sigHClos sigNat).

  Context (retr_eval : Retract Σintern Σ) (retr_pro : Retract sigPro Σ).

  Definition retr_unfolder : Retract (sigList (sigPair sigHClos sigNat)) Σ := ComposeRetract retr_eval _.
  Definition retr_interpreter : Retract sigStep Σ := ComposeRetract retr_eval _.

  Local Instance retr_closs_intrp : Retract (sigList (sigHClos)) Σ := ComposeRetract retr_interpreter _.
  Local Instance retr_clos_intrp : Retract sigHClos Σ := ComposeRetract retr_closs_intrp _.
  Local Instance retr_pro_intrp : Retract sigPro Σ := ComposeRetract retr_clos_intrp _.

  Local Instance retr_nat_clos_ad' : Retract sigNat sigHClos := Retract_sigPair_X _ (Retract_id _).
  Local Instance retr_nat_clos_ad : Retract sigNat Σ := ComposeRetract _ retr_nat_clos_ad'.
  Local Instance retr_heap : Retract sigHeap Σ := ComposeRetract retr_interpreter _.

  (*
    auxiliary tapes:

    0    : T
    1    : V
    2    : H
    3-4  : aux for init
    5-12 : aux for loop
    13   : t
   *)

  Definition M : pTM (Σ^+) unit 11 :=
    Translate retr_pro retr_pro_intrp @ [|Fin0|];;
    CopyValue _ @ [|Fin0;Fin1|];;
    Reset _ @[|Fin0|];;
    WriteValue 0 ⇑ retr_nat_clos_ad @ [| Fin0|];;
    Constr_pair _ _ ⇑ retr_clos_intrp @ [|Fin0;Fin1|];;
    Reset _ @ [|Fin0|];;
    WriteValue ( []%list) ⇑ retr_closs_intrp @ [| Fin0|];;
    Constr_cons _ ⇑ retr_closs_intrp @ [|Fin0;Fin1|];;
    Reset _ @ [|Fin1|];;
    WriteValue ( []%list) ⇑ retr_closs_intrp @ [| Fin1|];;
    WriteValue ( []%list ) ⇑ retr_heap @ [| Fin2|];;
    M_LHeapInterpreter.Loop ⇑ retr_interpreter;;
    Reset _ @ [|Fin0|];;
    CaseList _ ⇑ retr_closs_intrp @ [| Fin1;Fin0 |];;
    Reset _ @ [|Fin1|];;
    UnfoldClos.M retr_unfolder retr_heap retr_clos_intrp @ [| Fin0;Fin2;Fin1;Fin3;Fin4;Fin5;Fin6;Fin7;Fin8;Fin9|];;
    Reset _ @ [|Fin2|];;
    Translate (UnfoldClos.retr_pro _) retr_pro @ [|Fin0|].

  Arguments "+" : simpl never.
  Arguments "*" : simpl never.

  Definition steps (s : term) (k:nat) (t:term) Hcl (HR:evalIn k s t):=
    1 + Translate_steps (compile s) +
    (1 + CopyValue_steps (compile s) +
    (1 + Reset_steps (compile s) +
      (1 + WriteValue_steps (size 0) +
      (1 + Constr_pair_steps 0 +
        (1 + Reset_steps 0 +
        (1 + WriteValue_steps (size []%list) +
          (1 + Constr_cons_steps (0, compile s) +
          (1 + Reset_steps (0, compile s) +
            (1 + WriteValue_steps (size []%list) +
            (1 + WriteValue_steps (size []%list) +
              (1 + Loop_steps [(0, compile s)] [] []%list (3 * k + 1) +
              (1 + Reset_steps []%list +
                let (g,tmp) := completenessTimeInformative (proj2 (timeBS_evalIn _ _ _) HR) Hcl in
                let (H,_):= tmp in
                (1 + CaseList_steps [g] +
                (1 + Reset_steps []%list +
                  (1 + UnfoldClos.steps H g t +
                  (1 + Reset_steps H + Translate_steps (compile t))))))))))))))))).
  Arguments steps : clear implicits.

  Lemma SpecT s k t (Hcl: closed s) (HR:evalIn k s t):
    TripleT ≃≃([],[|Contains retr_pro (compile s)|] ++ Vector.const Void _)
      (steps s k t Hcl HR) M
      (fun _ => ≃≃([],[|Contains retr_pro (compile t)|] ++ Vector.const Void _)).
  Proof.
    unfold steps. destruct completenessTimeInformative as (g&H&?&?). clear HR.
    eapply ConsequenceT_pre. 2:reflexivity.
    unfold M.
    do 11 (hstep_seq;[]). cbn.
    hstep_seq;[| | ] .
    { refine (TripleT_RemoveSpace _). intros. eapply Interpreter_SpecT. eassumption. inversion 1. }
    now cbn; tspec_ext.
    do 2 (hstep_seq;[]).
    hintros _ _.
    hstep_seq;[].
    hstep_seq;[|].
    { eapply UnfoldClos.SpecT. eassumption. }
    cbn.
    do 2 (hstep_seq;[]). reflexivity.
    unfold steps. reflexivity.
  Qed.

  Lemma Spec s :
   closed s ->
    Triple ≃≃([],[|Contains retr_pro (compile s)|] ++ Vector.const Void _)
      M
      (fun _ t => exists s', t ≃≃ ([s ⇓ s']%list,[|Contains retr_pro (compile s')|] ++ Vector.const Void _)).
  Proof.
    intros cls.
    unfold M.
    do 11 (hstep_seq;[]). cbn.
    hstep.
    {
      eapply Consequence with (Q1:= fun y => _) (Q2:= fun y => _).
      eapply ChangeAlphabet_Spec_ex with (Q:= fun y x => _) (Q':= fun y x => _) (Ctx:= fun x (H:Prop) => (steps_k (snd x) _ (fst x) /\ halt_state (fst x)) /\
        (fst (fst (fst x)) = []%list ->
        H)).
      now refine (Interpreter_Spec [(0,compile s)] [] [])%list. now unfold "==>",Proper,Basics.impl. now cbn; tspec_ext. cbn;intros _. apply reflexivity.
    }
    cbn. intros _.
    eapply Triple_exists_pre. intros [[[T' V'] H'] k'];cbn.
    eapply Triple_and_pre. intros [HR Hhalt].
    unfold steps_k in*.
    edestruct soundness with (1:=cls) as (?&?&?&Heq&?&?). {split. now eapply pow_star. eassumption. }
    injection Heq as [= -> -> ->].
    eapply Triple_forall_pre. exists eq_refl.
    do 2 (hstep_seq;[]).
    hintros ? _.
    do 2 hstep_seq;[|].
    { refine (TripleT_Triple _). refine (UnfoldClos.SpecT _ _ _ _). eassumption. }
    cbn.
    hstep_seq.
    eapply Triple_exists_con. eexists _.
    change (fun x => ?h x) with h.
    eapply Consequence_post.
    now hsteps_cbn.
    cbn. intros _. tspec_ext. easy.
  Qed.

End Fix.
End EvalL.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Axioms.
Require Import Floats.
Require Import Asm.
Require Import Values.
Require Import Memory.

Require Import PeekTactics.
Require Import PregTactics.
Require Import PeekLib.
Require Import AsmCallingConv.
Require Import AsmBits.
Require Import MemoryAxioms.
Require Import ValEq.
Require Import MemEq.
Require Import UseBasic.

Require Import NoPtr.

Require Import MemBits.
Require Import Maps.

Lemma val_eq_longofwords :
  forall v1 v2 v1' v2',
    val_eq v1 v2 ->
    val_eq v1' v2' ->
    val_eq (Val.longofwords v1 v1') (Val.longofwords v2 v2').
Proof.
  intros. unfold val_eq in *.
  repeat break_match_hyp; try inv_false; subst; simpl;
  intros; try congruence;
  unfold Val.longofwords;
  repeat break_match; try congruence.
Qed.

Lemma eval_annot_arg_rs :
  forall (prog : AST.program fundef unit) a (s1 s2 : preg -> Values.val) m b md,
    eval_annot_arg_bits md (Genv.globalenv prog) s1 (s1 (IR ESP)) m a b ->
    forall m',
    mem_eq md m m' ->
    (val_eq (s1 ESP) (s2 ESP)) ->
    (forall r, In r (get_annot_preg a) -> val_eq (s1 r) (s2 r)) ->
    exists b',
      eval_annot_arg_bits md (Genv.globalenv prog) s2 (s2 (IR ESP)) m' a b' /\ val_eq b b'.
Proof.

  induction 1; intros;
  try solve [
        eexists; split; try econstructor; eauto;
        eapply H1; simpl; intuition idtac].

  * rewrite H in H3. simpl in H3. rewrite <- H3 in *.
    unfold Mem.loadv in *.
    simpl in *.
    app eq_mem_load H1. break_and.
    exists x.
    split; auto. econstructor; eauto.
  * app val_eq_or H0.
    break_or.
    destruct (Val.add (s2 ESP) (Vint ofs)) eqn:?;
    exists (Val.add (s2 ESP) (Vint ofs));
    split; try econstructor; eauto;
    rewrite H3; simpl; eauto;
    try solve [intros; congruence].
           unfold Val.add in Heqv.
           break_match_hyp; try congruence.
           rewrite H3 in H2. simpl in H2.
           congruence.
    exists (Val.add (s2 ESP) (Vint ofs)).
    split. econstructor; eauto.
    unfold Val.add.
    break_match; simpl; try rewrite <- H3; eauto;
    intros; congruence.
  * unfold Mem.loadv in *. simpl in *.
    break_match_hyp; try congruence.
    app eq_mem_load H. break_and.
    exists x.
    split; eauto.
    econstructor; eauto.
    unfold Mem.loadv.
    find_rewrite. eauto.
  * exists Vundef.
           split; simpl; eauto.
           econstructor; eauto.
           intros. congruence.
  *
  edestruct IHeval_annot_arg_bits1; eauto.
  intros. eapply H3. simpl.
  rewrite in_app. left. eauto.
  break_and.
  edestruct IHeval_annot_arg_bits2; eauto.
  intros. eapply H3. simpl.
  rewrite in_app. right. eauto.
  break_and.
  eexists. split. econstructor; eauto.
  eapply val_eq_longofwords; eauto.

Qed.

Lemma list_forall2_annot:
  forall (prog : AST.program fundef unit) s1 s2 args vargs ef m m' md,
    list_forall2 (eval_annot_arg_bits md (Genv.globalenv prog) s1 (s1 (IR ESP)) m) args vargs ->
    (forall p, In p (use (Pannot ef args)) -> val_eq (s1 p) (s2 p)) ->
    mem_eq md m m' ->
    exists vargs',
      list_forall2 (eval_annot_arg_bits md (Genv.globalenv prog) s2 (s2 (IR ESP)) m') args vargs' /\ list_forall2 val_eq vargs vargs'.
Proof.
  intros. induction H;
    try solve [eexists; split; econstructor; eauto].
  app eval_annot_arg_rs H;
    try eapply H0;
    repeat break_and.

  Focus 2. simpl. right. left. eauto.
  Focus 2. intros. apply H0. simpl.
  right. right. rewrite in_app. left. auto.
  destruct (IHlist_forall2).
  intros. apply H0. simpl.
  rewrite in_app. simpl in H5.
  intuition idtac.
  break_and. exists (x :: x0).
  split; econstructor; eauto.
Qed.

Ltac unify_all :=
  try unify_psur;
  simpl in *;
  try unify_find_funct_ptr;
  simpl in *;
  try unify_find_instr;
  simpl in *.

Fixpoint getres (res : list preg) (vl : list Values.val) : list preg :=
  match res with
    | nil => nil
    | f :: r =>
      match vl with
        | nil => nil
        | x :: y => f :: getres r y
      end
  end.

Lemma set_regs_gnot_in :
  forall res vl x,
    ~ (In x (getres res vl)) ->
    forall rs,
      (set_regs res vl rs) x = rs x.
Proof.
  induction res; intros.
  simpl. reflexivity.
  simpl in H. break_match_hyp; simpl in H.
  subst vl. simpl. reflexivity.
  eapply Decidable.not_or in H.
  break_and. simpl.
  rewrite IHres by eauto.
  preg_simpl. reflexivity.
Qed.

Lemma set_regs_gin :
  forall res vl x,
    In x (getres res vl) ->
    forall rs rs',
      (set_regs res vl rs) x = (set_regs res vl rs') x.
Proof.
  induction res; intros.
  simpl in H. inv H.
  simpl in H. break_match_hyp; simpl in H; try solve [inv H].
  destruct (in_dec preg_eq x (getres res l)).
  simpl. apply IHres. eauto.
  simpl. repeat rewrite set_regs_gnot_in by eauto.
  break_or; try congruence.
  preg_simpl. reflexivity.
Qed.

Lemma undef_regs_undef :
  forall l x rs,
    In x l ->
    undef_regs l rs x = Values.Vundef.
Proof.
  induction l; intros.
  simpl in H. inv_false.
  simpl in H.
  destruct (in_dec preg_eq x l).
  simpl. rewrite IHl; eauto.
  break_or; try congruence.
  simpl. rewrite undef_regs_not_in; eauto.
  preg_simpl. reflexivity.
Qed.

Lemma val_eq_list_lessdef :
  forall a a',
    list_forall2 val_eq a a' ->
    Val.lessdef_list a a'.
Proof.
  induction 1; intros;
  econstructor; eauto.
  eapply val_eq_lessdef; eauto.
Qed.

Lemma no_ptr_nextinstr_nf :
  forall rs,
    (forall x, ~ In x flags -> forall b i, rs x <> Vptr b i) ->
    no_ptr_regs (nextinstr_nf rs).
Proof.
  intros. unfold no_ptr_regs.
  intros. unfold nextinstr_nf.
  unfold nextinstr. simpl.
  repeat preg_case; try congruence.
  name (H PC) HPC.
  unfold Val.add. repeat break_match; try congruence.
  unfold Vone in *. congruence.
  unfold Vone in *. inv Heqv0.
  exfalso. eapply HPC. simpl. intuition idtac; try congruence.
  reflexivity. eapply H. simpl. intuition idtac.
Qed.

Lemma set_regs_either :
  forall res rs l reg,
    set_regs res l rs reg = rs reg \/
    exists v, set_regs res l rs reg = v /\ In v l.
Proof.
  induction res; intros.
  left. simpl. reflexivity.
  simpl. break_match. left. reflexivity.
  subst l. simpl.
  destruct (in_dec preg_eq reg (getres res l0)).
  erewrite set_regs_gin; eauto.
  instantiate (1 := rs).
  specialize (IHres rs l0 reg).
  destruct IHres. left. auto.
  right. break_exists. exists x. break_and. split; auto.
  rewrite set_regs_gnot_in; eauto.
  clear IHres. clear n.
  preg_case. right. eauto.
  left. eauto.
Qed.

Lemma encode_long_no_ptr :
  forall v v' x t,
    val_eq v v' ->
    In x (encode_long t v') ->
    forall b i,
      x <> Vptr b i.
Proof.
  intros. unfold encode_long in *.
  unfold val_eq in *.
  destruct v; simpl in H; try inv_false; try subst v';
  repeat break_match_hyp; simpl in *; repeat break_or; try inv_false;
  eauto; try congruence. unfold Val.hiword. break_match; try congruence.
  unfold Val.loword. break_match; try congruence.
Qed.

Lemma global_perms_mem_eq :
  forall md m m',
    mem_eq md m m' ->
    forall ge,
      global_perms ge m ->
      global_perms ge m'.
Proof.
  intros.
  unfold global_perms in *.
  intros. app H0 H1.
  break_and.
  unfold mem_eq in *.
  repeat break_and.
  app H6 H1.
Qed.

Lemma list_forall2_inv_right :
  forall {A : Type} (P : A -> A -> Prop) (l l' : list A),
    list_forall2 P l l' ->
    forall x,
      In x l' ->
      exists y,
        In y l /\ P y x.
Proof.
  induction 1; intros.
  simpl in H. inv_false.
  simpl in H1.
  break_or. simpl. exists a1.
  split; auto.
  app IHlist_forall2 H2.
  exists x0. simpl.
  split. right. break_and. auto.
  break_and. auto.
Qed.

Lemma list_forall2_map :
  forall l (rs rs' : regset),
    (forall r, In r l -> val_eq (rs r) (rs' r)) ->
      list_forall2 val_eq (map rs l) (map rs' l).
Proof.
  induction l; intros.
  simpl. econstructor.
  simpl. econstructor. eapply H. simpl. left. auto.
  eapply IHl. intros. eapply H. simpl. right. auto.
Qed.

Lemma val_eq_hiword :
  forall v v',
    val_eq v v' ->
    val_eq (Val.hiword v) (Val.hiword v').
Proof.
  intros.
  unfold val_eq in H.
  break_match_hyp; subst; simpl; eauto;
  try congruence.
  intros. unfold Val.hiword.
  break_match; congruence.
Qed.

Lemma val_eq_loword :
  forall v v',
    val_eq v v' ->
    val_eq (Val.loword v) (Val.loword v').
Proof.
  intros.
  unfold val_eq in H.
  break_match_hyp; subst; simpl; eauto;
  try congruence.
  unfold Val.loword; break_match; congruence.
Qed.

Lemma set_regs_efres:
  forall ef p r v v' rs rs',
    In p r ->
    (forall p0, In p0 (efres ef r) -> val_eq (rs p0) (rs' p0)) ->
    val_eq v v' ->
    val_eq ((set_regs r (encode_long (sig_res (ef_sig ef)) v) rs) p) ((set_regs r (encode_long (sig_res (ef_sig ef)) v') rs') p).
Proof.
  induction r; intros.
  * simpl in H. inv H.
  * unfold efres in *; simpl in H0; repeat break_match_hyp.

    simpl. repeat rewrite set_regs_nil.

    destruct (preg_eq p a). subst. simpl.
    repeat rewrite set_regs_nil. repeat rewrite Pregmap.gss.
    assumption.

    simpl. repeat rewrite set_regs_nil. repeat rewrite Pregmap.gso by auto.
    apply H0. simpl in H. destruct H. congruence. assumption.

    destruct (preg_eq p a). subst. simpl.
    repeat rewrite set_regs_nil. repeat rewrite Pregmap.gss.
    assumption.

    simpl. repeat rewrite set_regs_nil. repeat rewrite Pregmap.gso by auto.
    apply H0. simpl in H. destruct H. congruence. assumption.

    destruct (preg_eq p a). subst. simpl.
    destruct r. simpl. repeat rewrite Pregmap.gss.
    eapply val_eq_hiword; assumption.

    simpl. repeat rewrite set_regs_nil.
    destruct (preg_eq p a). subst. repeat rewrite Pregmap.gss.
    eapply val_eq_loword; assumption.
    rewrite Pregmap.gso by auto.
    rewrite Pregmap.gss.
    rewrite Pregmap.gso by auto.
    rewrite Pregmap.gss.

    eapply val_eq_hiword; assumption.

    destruct r. simpl.
    repeat rewrite Pregmap.gso by auto.
    simpl in H. destruct H. congruence. inv H.
    destruct (preg_eq p p0).
    simpl. repeat rewrite set_regs_nil.
    subst. rewrite Pregmap.gss. rewrite Pregmap.gss.

    eapply val_eq_loword; assumption.
    simpl. repeat rewrite set_regs_nil.
    repeat rewrite Pregmap.gso by auto.
    apply H0. simpl. simpl in H.
    destruct H. congruence. destruct H. congruence.
    assumption.

    destruct (preg_eq p a). subst. simpl.
    repeat rewrite set_regs_nil. repeat rewrite Pregmap.gss.
    assumption.

    simpl. repeat rewrite set_regs_nil. repeat rewrite Pregmap.gso by auto.
    apply H0. simpl in H. destruct H. congruence. assumption.

    destruct (preg_eq p a). subst. simpl.
    repeat rewrite set_regs_nil. repeat rewrite Pregmap.gss.
    assumption.

    simpl. repeat rewrite set_regs_nil. repeat rewrite Pregmap.gso by auto.
    apply H0. simpl in H. destruct H. congruence. assumption.

    destruct (preg_eq p a). subst. simpl.
    repeat rewrite set_regs_nil. repeat rewrite Pregmap.gss.
    assumption.

    simpl. repeat rewrite set_regs_nil. repeat rewrite Pregmap.gso by auto.
    apply H0. simpl in H. destruct H. congruence. assumption.

    destruct (preg_eq p a). subst. simpl.
    repeat rewrite set_regs_nil. repeat rewrite Pregmap.gss.
    assumption.

    simpl. repeat rewrite set_regs_nil. repeat rewrite Pregmap.gso by auto.
    apply H0. simpl in H. destruct H. congruence. assumption.
Qed.

Ltac invs2 :=
  match goal with
    | [ H : step_bits _ _ _ _, H2 : step_bits _ _ _ _ |- _ ] => inv_step H; inv_step H2
  end.

Lemma val_eq_set_regs :
  forall v v',
    list_forall2 val_eq v v' ->
    forall r rs rs' p,
      val_eq (rs p) (rs' p) ->
      val_eq (set_regs r v rs p)
             (set_regs r v' rs' p).
Proof.
  intros v v' H.
  induction H; intros.
  repeat rewrite set_regs_nil. eauto.
  destruct r; simpl. eauto.
  eapply IHlist_forall2; eauto.
  preg_case; try subst; eauto.
Qed.

Lemma val_eq_undef_regs :
  forall rs rs' p,
    val_eq (rs p) (rs' p) ->
    forall l,
      val_eq (undef_regs l rs p) (undef_regs l rs' p).
Proof.
  induction l; intros. simpl. eauto.
  simpl.
  destruct (in_dec preg_eq p l).
  erewrite undef_regs_in with (rs' := rs); eauto.
  erewrite undef_regs_in with (rs := rs' # a <- Values.Vundef)(rs' := rs'); eauto.
  repeat rewrite undef_regs_not_in; eauto.
  preg_case; simpl; eauto.
  congruence.
Qed.

Lemma val_eq_decode_longs :
  forall sg l l',
    list_forall2 val_eq l l' ->
    list_forall2 val_eq (decode_longs sg l)
                   (decode_longs sg l').
Proof.
  induction sg; intros; simpl; repeat break_match; subst; try solve [econstructor];
  inv H;
  try solve [
        econstructor; eauto;
        eapply IHsg; eauto].
  inv H5. inv H5.
  inv H5. econstructor.
  eapply val_eq_longofwords; eauto.
  eapply IHsg; eauto.
Qed.

Lemma use_def_spec :
  forall p s1 s1' s2 b z s c i m m0 m' t bits md md',
    s1 PC = Values.Vint bits ->
    s2 PC = Values.Vint bits ->
    no_ptr_regs s2 ->
    psur md bits = Some (b,z) ->
    @Genv.find_funct_ptr fundef unit (Genv.globalenv p) b = Some (Internal (mkfunction s c)) ->
    find_instr (Int.unsigned z) c = Some i ->
    (forall p,
       In p (use i) -> val_eq (s1 p) (s2 p)) ->
    step_bits (Genv.globalenv p) (State_bits s1 m md) t (State_bits s1' m' md') ->
    mem_eq md m m0 ->
    no_ptr_mem m0 ->
    ~ is_call_return i ->
    (exists s2' m0',
       step_bits (Genv.globalenv p) (State_bits s2 m0 md) t (State_bits s2' m0' md') /\ (forall p, In p (def i) -> val_eq (s1' p) (s2' p)) /\ mem_eq md' m' m0'
    ).
Proof.
  intros.
  invs.
  *
    unify_all.

    match goal with
      | [ H : Genv.find_funct_ptr _ _ = _ |- _ ] =>
        name H Hge;
          eapply use_spec with (s1 := s1) (s2 := s2) in H; eauto
    end.

    repeat break_exists. do 2 eexists.
    split.
    eapply exec_step_internal_bits; eauto.
    unfold mem_eq in *.
    repeat break_and. assumption.
    eapply global_perms_mem_eq; eauto.
    intros. eapply use_def_exec; eauto.

  * app mem_eq_extcall' H20.
    repeat break_and.
    eexists. eexists.
    repeat unify_psur.
    split.
    rewrite H14. econstructor; eauto.
    eapply no_ptr_nextinstr_nf.
    intros.
    edestruct (set_regs_either res).
    rewrite H15.
    destruct (in_dec preg_eq x1 (map preg_of (Machregs.destroyed_by_builtin ef))).
    rewrite undef_regs_undef by assumption. congruence.
    rewrite undef_regs_not_in by assumption. apply H1.
    break_exists. break_and. rewrite H15.
    app (@list_forall2_inv_right val) H12.
    break_and. unfold val_eq in H21.
    break_match_hyp; try congruence.
    eapply no_ptr_mem_eq; eauto.
    unfold mem_eq in *.
    repeat break_and. assumption.
    eapply global_perms_mem_eq; eauto.

    split.
    intros.
    repeat unify_psur. repeat unify_find_funct_ptr.
    simpl in *. unify_find_instr.
    simpl in *.
    eapply val_eq_nextinstr_nf. intros.
    rewrite in_app in H2.
    simpl in H15.
    apply Decidable.not_or in H15; break_and.
    apply Decidable.not_or in H16; break_and.
    apply Decidable.not_or in H18; break_and.
    apply Decidable.not_or in H19; break_and.
    apply Decidable.not_or in H20; break_and.

    assert (p0 = PC \/ In p0 res \/ In p0 (map preg_of (Machregs.destroyed_by_builtin ef))) by (
      repeat break_or; try congruence; try (left; reflexivity); prove_or_eq assumption; assumption).

    clear H2.

    inv H11. inv H10.
    destruct (in_dec preg_eq p0 res).
    eapply set_regs_efres; eauto.
    intros.

    destruct (in_dec preg_eq p1 (map preg_of (Machregs.destroyed_by_builtin ef))).
    repeat rewrite undef_regs_undef by assumption.
    simpl. congruence.
    repeat rewrite undef_regs_not_in; eauto.
    eapply H5. right. rewrite in_app. right. eauto.

    app mem_eq_extcall H11. repeat break_and.
    eapply external_call_determ in H11; try eapply H2.
    break_and.
    specialize (H30 eq_refl). break_and.
    subst. assumption.

    eapply val_eq_decode_longs.
    eapply list_forall2_map. intros.
    eapply H5. right. rewrite in_app. left. auto.

    repeat rewrite set_regs_not_in by assumption.

    repeat break_or; try congruence.
    destruct (in_dec preg_eq PC (map preg_of (Machregs.destroyed_by_builtin ef))).
    repeat rewrite undef_regs_undef by assumption.
    simpl. congruence.
    repeat rewrite undef_regs_not_in; eauto.
    repeat rewrite undef_regs_undef by assumption. simpl. congruence.

    congruence.

    eapply list_forall2_map.
    intros. apply H5. repeat unify_psur.
    unify_find_funct_ptr.
    simpl in *. rewrite H4 in H19. inv H19.
    simpl. right. rewrite in_app. left. assumption.

  *
    unify_psur. unfold fundef in *.
    unify_find_funct_ptr. simpl in *.
    rewrite H4 in *. opt_inv. subst.

    eapply (list_forall2_annot p s1 s2) in H23;
    intros;
    try eapply H5;
    eauto.
    repeat break_exists. break_and.
    app mem_eq_extcall H24.

    repeat break_and. rewrite H15.

    eexists. eexists. split.
    eapply exec_step_annot_bits; eauto.
    eapply no_ptr_mem_eq; eauto.
    unfold mem_eq in *. tauto.
    eapply global_perms_mem_eq; eauto.

    split.
    intros. simpl in H16. break_or; try inv_false.
    preg_simpl. eapply val_eq_add.
    eapply H5. simpl. left. reflexivity.
    simpl. reflexivity.

    congruence.

  * unify_psur. unify_find_funct_ptr.

Qed.

Lemma def_spec' :
  forall prog s c z b i s1 m s1' m' t bits md md',
    s1 PC = Values.Vint bits ->
    psur md bits = Some (b,z) ->
    @Genv.find_funct_ptr fundef unit (Genv.globalenv prog) b = Some (Internal (mkfunction s c)) ->
    find_instr (Int.unsigned z) c = Some i ->
    step_bits (Genv.globalenv prog) (State_bits s1 m md) t (State_bits s1' m' md') ->
    ~ is_call_return i ->
    (forall p, (In p (def i) \/ s1 p = s1' p)).
Proof.
  intros. invs; unify_all.

  *
    eapply def_spec; eauto.

  * destruct (preg_eq PC p).
      left. left. assumption.
    destruct (in_dec preg_eq p flags).
      left. simpl. simpl in i. tauto.
    destruct (in_dec preg_eq p res).
      left. simpl. repeat right. rewrite in_app. left. assumption.
    destruct (in_dec preg_eq p (map preg_of (Machregs.destroyed_by_builtin ef))).
      left. simpl. repeat right. rewrite in_app. right. assumption.
    right. unfold nextinstr_nf. fold flags.
    unfold nextinstr. rewrite Pregmap.gso by auto.
    rewrite undef_regs_not_in by auto.
    rewrite set_regs_not_in by auto.
    rewrite undef_regs_not_in by auto.
    reflexivity.

  * destruct (preg_eq PC p).
      left. simpl. left. assumption.
    right. unfold nextinstr.
    rewrite Pregmap.gso by auto.
    reflexivity.
Qed.

Lemma val_eq_refl :
  forall v,
    (forall b ofs, v <> Vptr b ofs) ->
    val_eq v v.
Proof.
  intros. unfold val_eq.
  break_match; auto.
  congruence.
Qed.

(* Lemma use_def_exec' : *)
(*   forall prog s c i b z s1 s2 m m' s1' s2' m0 m0' t bits md md', *)
(*     s1 PC = Values.Vint bits -> *)
(*     s2 PC = Values.Vint bits -> *)
(*     psur md bits = Some (b,z) -> *)
(*     @Genv.find_funct_ptr fundef unit (Genv.globalenv prog) b = Some (Internal (mkfunction s c)) -> *)
(*     find_instr (Int.unsigned z) c = Some i -> *)
(*     step_bits (Genv.globalenv prog) (State_bits s1 m md) t (State_bits s1' m' md') -> *)
(*     step_bits (Genv.globalenv prog) (State_bits s2 m0 md) t (State_bits s2' m0' md') -> *)
(*     mem_eq md m m0 -> *)
(*     (forall p, In p (use i) -> val_eq (s1 p) (s2 p)) -> *)
(*     ~ is_call_return i -> *)
(*     (forall p, In p (def i) -> val_eq (s1' p) (s2' p)) /\ mem_eq md' m' m0'. *)
(* Proof. *)
(*   intros. invs2; repeat unify_all; try state_inv. *)

(*   * eapply use_def_exec; eauto. *)
(*   * split; intros. *)
(*     eapply val_eq_nextinstr_nf. *)
(*     intros. *)
(*     repeat break_or; try subst p; *)
(*     try solve [exfalso; apply H9; simpl; prove_or_eq reflexivity]. *)
(*     eapply val_eq_set_regs. *)

(*     eapply val_eq_undef_regs. *)

(*     eapply H7. left. eauto. *)

(*     inv H19. inv H27. *)

(*     rewrite in_app in H1. break_or. *)
(*     eapply set_regs_efres. eauto. *)
(*     intros. *)
(*     eapply val_eq_undef_regs. apply H7. *)
(*     right. rewrite in_app. right. eauto. *)

(*     eapply val_eq_set_regs. *)

(*     repeat rewrite undef_regs_undef by assumption. *)
(*     simpl. auto. *)
(*     congruence. *)

(*   * split; intros. *)
(*     break_or; try inv_false. *)
(*     eapply val_eq_nextinstr. *)
(*     eapply H7; eauto. *)
(* Qed. *)


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.sha_lemmas.
Require Import sha.spec_sha.
Local Open Scope nat.
Local Open Scope logic.

Lemma body_SHA256_Init: semax_body Vprog Gtot f_SHA256_Init SHA256_Init_spec.
Proof.
start_function.
name c_ _c.
unfold data_at_.
(* BEGIN: without these lines, the "do 8 forward" takes 40 times as long. *)
unfold field_at_.
unfold_data_at (field_at _ _ _ _ _).
simpl fst; simpl snd.
(* END: without these lines *)
Time do 8 (forward; unfold upd_Znth; if_tac;
  unfold Zlength in *; simpl Zlength_aux in *; try lia;
  unfold sublist; simpl app).
Time repeat forward. (* 14 sec *)
unfold sha256state_.
Exists (map Vint init_registers,
      (Vint Int.zero, (Vint Int.zero, (repeat Vundef (Z.to_nat 64), Vint Int.zero)))).
unfold_data_at (data_at _ _ _ _).
Time entailer!. (* 5.2 sec *)
repeat split; auto.
unfold s256_h, fst, s256a_regs.
rewrite hash_blocks_equation. reflexivity.
unfold data_at. apply derives_refl'; f_equal.
f_equal.
simpl.
repeat (apply f_equal2; [f_equal; apply int_eq_e; compute; reflexivity | ]); auto.
Time Qed. (* 33.6 sec *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a40_ : Universe.
Variable a4_ : Universe.
Variable a39_ : Universe.
Variable a38_ : Universe.
Variable a37_ : Universe.
Variable a36_ : Universe.
Variable a35_ : Universe.
Variable a34_ : Universe.
Variable a33_ : Universe.
Variable a32_ : Universe.
Variable a31_ : Universe.
Variable a30_ : Universe.
Variable a3_ : Universe.
Variable a29_ : Universe.
Variable a28_ : Universe.
Variable a27_ : Universe.
Variable a26_ : Universe.
Variable a25_ : Universe.
Variable a24_ : Universe.
Variable a23_ : Universe.
Variable a22_ : Universe.
Variable a21_ : Universe.
Variable a20_ : Universe.
Variable a2_ : Universe.
Variable a19_ : Universe.
Variable a18_ : Universe.
Variable a17_ : Universe.
Variable a16_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ (dom_ a15_ /\ (dom_ a16_ /\ (dom_ a17_ /\ (dom_ a18_ /\ (dom_ a19_ /\ (dom_ a20_ /\ (dom_ a21_ /\ (dom_ a22_ /\ (dom_ a23_ /\ (dom_ a24_ /\ (dom_ a25_ /\ (dom_ a26_ /\ (dom_ a27_ /\ (dom_ a28_ /\ (dom_ a29_ /\ (dom_ a30_ /\ (dom_ a31_ /\ (dom_ a32_ /\ (dom_ a33_ /\ (dom_ a34_ /\ (dom_ a35_ /\ (dom_ a36_ /\ (dom_ a37_ /\ (dom_ a38_ /\ (dom_ a39_ /\ dom_ a40_))))))))))))))))))))))))))))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 A29 A30 A31 A32 A33 A34 A35 A36 A37 A38 A39 A40 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ (dom_ A15 /\ (dom_ A16 /\ (dom_ A17 /\ (dom_ A18 /\ (dom_ A19 /\ (dom_ A20 /\ (dom_ A21 /\ (dom_ A22 /\ (dom_ A23 /\ (dom_ A24 /\ (dom_ A25 /\ (dom_ A26 /\ (dom_ A27 /\ (dom_ A28 /\ (dom_ A29 /\ (dom_ A30 /\ (dom_ A31 /\ (dom_ A32 /\ (dom_ A33 /\ (dom_ A34 /\ (dom_ A35 /\ (dom_ A36 /\ (dom_ A37 /\ (dom_ A38 /\ (dom_ A39 /\ dom_ A40))))))))))))))))))))))))))))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 A29 A30 A31 A32 A33 A34 A35 A36 A37 A38 A39 A40)).
Variable ax3_3 : (p_ a40_ a39_ a38_ a37_ a36_ a35_ a34_ a33_ a32_ a31_ a30_ a29_ a28_ a27_ a26_ a25_ a24_ a23_ a22_ a21_ a20_ a19_ a18_ a17_ a16_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma40_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


From fae_gtlc_mu.refinements.static_gradual Require Export compat_cast.defs.
From fae_gtlc_mu.backtranslation Require Export general_def_lemmas.
From fae_gtlc_mu.cast_calculus Require Export lang.

Section compat_cast_arrow_arrow.
  Context `{!implG Σ,!specG Σ}.

  (** The case `throughArrow` in our proof by induction on the alternative consistency relation. *)
  Lemma back_cast_ar_arrow_arrow:
    ∀ (A : list (type * type)) (τ1 τ1' τ2 τ2' : type) (pC1 : alternative_consistency A τ1' τ1) (pC2 : alternative_consistency A τ2 τ2')
      (IHpC1 : back_cast_ar pC1) (IHpC2 : back_cast_ar pC2),
      back_cast_ar (throughArrow A τ1 τ1' τ2 τ2' pC1 pC2).
  Proof.
    intros A τ1 τ1' τ2 τ2' pC1 pC2 IHpC1 IHpC2.
    rewrite /back_cast_ar. iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    (* extract small lemma about length fs *)
    iDestruct "Hfs" as "[% Hfs']"; iAssert (rel_cast_functions A fs) with "[Hfs']" as "Hfs". iSplit; done. iClear "Hfs'".
    (* rewriting stuff *)
    rewrite /𝓕c /𝓕. fold (𝓕 pC1) (𝓕 pC2). rewrite between_TArrow_subst_rewrite.
    rename v into f. rename v' into f'. iDestruct "Hv'" as "Hf'". iDestruct "Hvv'" as "Hff'".
    fold (𝓕c pC1 fs) (𝓕c pC2 fs).
    do 2 rewrite 𝓕c_rewrite.
    (* 1 step in WP *)
    unfold between_TArrow.
    wp_head.
    asimpl.
    (* prove postcondition because value *)
    iApply wp_value.
    iExists (CastV f' (TArrow τ1 τ2) (TArrow τ1' τ2') (TArrow_TArrow_icp τ1 τ2 τ1' τ2')).
    rewrite interp_rw_TArrow.
    iSplitL "Hf'"; auto.
    rewrite interp_rw_TArrow.
    iModIntro.
    (** actual thing to prove *)
    (** ===================== *)
    iIntros ((a , a')) "#Haa'".
    simpl. clear K'.
    iIntros (K') "Hf'".
    simpl in *.
    (* step in wp *)
    wp_head. asimpl.
    (* step in gradual side *)
    iMod (step_pure _ ei' K'
                    (App (Cast f' (TArrow τ1 τ2) (TArrow τ1' τ2')) a')
                    (Cast (App f' (Cast a' τ1' τ1)) τ2 τ2') with "[Hf']") as "Hf'".
    intros. eapply AppCast; try by rewrite -to_of_val. auto. by iFrame.
    (* first IH for the arguments *)
    iApply (wp_bind (ectx_language.fill $ [stlc_mu.lang.AppRCtx _ ; stlc_mu.lang.AppRCtx _])).
    iApply (wp_wand with "[-]").
    rewrite -𝓕c_rewrite.
    iApply (IHpC1 ei' (AppRCtx f' :: CastCtx τ2 τ2' :: K') with "[Hf']"). auto.
    iIntros (b) "HHH".
    iDestruct "HHH" as (b') "[Hb' #Hbb']".
    simpl.
    iClear "Haa'". clear a a'.
    (* using the relatedness of functions *)
    iApply (wp_bind (ectx_language.fill $ [stlc_mu.lang.AppRCtx _ ])).
    iApply (wp_wand with "[-]").
    iDestruct ("Hff'" with "Hbb'") as "Hfbf'b' /=".
    iApply ("Hfbf'b'" $! (CastCtx τ2 τ2' :: K')).
    simpl.
    iExact "Hb'".
    iIntros (r) "HHH". iDestruct "HHH" as (r') "[Hr' Hrr']".
    simpl.
    iClear "Hbb'". clear b b'.
    (** second IH for the results *)
    iApply (wp_wand with "[-]").
    rewrite -𝓕c_rewrite.
    iApply (IHpC2 ei' K' r r' with "[-]").
    iSplitR. done.
    iSplitL "Hrr'"; try done.
    iSplitR. done.
    done.
    iIntros (s) "HHH". done.
  Qed.

End compat_cast_arrow_arrow.


Require Import AutoSep Malloc Abort Bootstrap.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 0.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 0.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [Abort.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREonly[_] 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREonly[_] mallocHeap 0];;

        Goto "test"!"main"
      end
    }}.

  Theorem ok : moduleOk boot.
    vcgen; abstract genesis.
  Qed.

  Definition m0 := link Malloc.m boot.
  Definition m1 := link Abort.m m0.

  Lemma ok0 : moduleOk m0.
    link Malloc.ok ok.
  Qed.

  Lemma ok1 : moduleOk m1.
    link Abort.ok ok0.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $(size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok1.
  Qed.
End boot.

End Make.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RealmExitHandlerAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition handle_realm_exit_spec0 (rec: Pointer) (exception: Z) (adt: RData) : option (RData * Z) :=
    match rec, exception with
    | (_rec_base, _rec_ofst), _exception =>
      if (_exception =? 0) then
        when adt == set_rec_run_exit_reason_spec (VZ64 0) adt;
        when _t'1, adt == handle_exception_sync_spec (_rec_base, _rec_ofst) adt;
        rely is_int _t'1;
        Some (adt, _t'1)
      else
        if (_exception =? 1) then
          when _t'2, adt == handle_excpetion_irq_lel_spec (_rec_base, _rec_ofst) adt;
          rely is_int _t'2;
          Some (adt, _t'2)
        else
          if (_exception =? 2) then
            when adt == set_rec_run_exit_reason_spec (VZ64 2) adt;
            Some (adt, 0)
          else
            Some (adt, 0)
     end
    .

End SpecLow.