(** BigStepAnnot.v: We constrain the Bicolano bigstep semantics to handle only the executions where exception thrown at a given point are in a predefined set. Such a set could be computed for example with a CHA static analysis. *)
(* Hendra : - Modified to suit DEX program.
            - Also trim the system to contain only Arithmetic *)
Require Export List.
Require Export ZArith.
Require Export LoadBicolano.

Inductive compat_op (A B:Set) : option A -> option B -> Prop :=
  compat_op_none : compat_op A B None None
| compat_op_some : forall k v, compat_op A B (Some k) (Some v).
Implicit Arguments compat_op [A B].

Module DEX_BigStepAnnot.

Import DEX_BigStep.DEX_BigStep DEX_Dom DEX_Prog.

  Set Implicit Arguments.
  Section DEX_instr.

  Inductive DEX_exec_intra (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_IntraNormalState -> Prop :=
  | exec_intra_normal : forall s1 s2,
    DEX_NormalStep p m s1 s2 ->
    DEX_exec_intra p m (* None *) s1 s2.

  Inductive DEX_exec_return (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | exec_return_normal : forall h s ov,
     DEX_ReturnStep p m s (h, Normal ov) ->
     DEX_exec_return p m s (h, Normal ov).

 Inductive DEX_IntraStep (p:DEX_Program) :
    DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop :=
  | IntraStep_res :forall m s ret,
     DEX_exec_return p m s ret ->
     DEX_IntraStep p m s (inr _ ret)
  | IntraStep_intra_step:forall m s1 s2,
     DEX_exec_intra p m s1 s2 ->
     DEX_IntraStep p m s1 (inl _ s2).

 Definition DEX_IntraStepStar p m s r := TransStep_l (DEX_IntraStep p m) s r.

 Definition DEX_IntraStepStar_intra p m s s' := DEX_IntraStepStar p m s (inl _ s').

 Definition DEX_BigStep  p m s ret := DEX_IntraStepStar p m s (inr _ ret).

  Lemma DEX_IntraStep_ind_ :
      forall (p:DEX_Program)
        (P:DEX_Method->DEX_IntraNormalState->DEX_IntraNormalState+DEX_ReturnState->Prop),
         (forall m s, P m s (inl _ s)) ->
         (forall m s r, DEX_exec_return p m s r -> P m s (inr _ r)) ->
         (forall m s s' , DEX_exec_intra p m s s' ->
            forall r, DEX_IntraStepStar p m s' r -> P m s' r ->
            P m s r) ->
      forall m s r, DEX_IntraStep p m s r ->
        match r with
        | inr r' => P m s (inr _ r')
        | inl s' => forall r', DEX_IntraStepStar p m s' r' -> P m s' r' -> P m s r'
        end.
     Proof.
       intros prg Q H0 Hr Hi Hcr Hc.
       fix intra 2;intros r Hs;case Hs;clear r Hs;intros.
       eapply Hr; eauto.
       apply Hi with s2;trivial.
     Qed.

  Lemma DEX_IntraStepStar_ind :
    forall (p:DEX_Program)
     (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop),
       (forall m s, P m s (inl _ s)) ->
       (forall m s r, DEX_exec_return p m s r -> P m s (inr _ r)) ->
       (forall m s s' , DEX_exec_intra p m s s' ->
          forall r, DEX_IntraStepStar p m s' r -> P m s' r ->
          P m s r) ->
    forall m s r, DEX_IntraStepStar p m s r -> P m s r.
   Proof.
     intros p Q H0 Hr Hi.
     fix fixp 4;intros m s' s Ht;case Ht;clear Ht s' s;intros.
     apply H0.
     generalize (DEX_IntraStep_ind_ Q H0 Hr Hi H).
     case r;intros;trivial.
     apply H1;trivial.
     constructor.
     assert (HH:=DEX_IntraStep_ind_ Q H0 Hr Hi H);simpl in HH.
     apply HH;trivial.
     apply fixp;trivial.
   Qed.

End DEX_instr.

End DEX_BigStepAnnot.


Require Import AutoSep Malloc Arrays8.

Definition mainS := SPEC reserving 16
  PREonly[_] mallocHeap 0.

Definition writeS := SPEC("fd", "buf", "len") reserving 4
  Al len,
  PRE[V] V "buf" =?>8 len * [| (wordToNat (V "len") <= len)%nat |]
  POST[_] V "buf" =?>8 len.

Opaque allocated.

Definition neg1 : W := wones _.

Definition m := bimport [[ "sys"!"abort" @ [abortS], "sys"!"printInt" @ [printIntS],
                           "sys"!"listen" @ [listenS], "sys"!"accept" @ [acceptS],
                           "sys"!"read" @ [readS], "sys"!"write" @ [Sys.writeS],
                           "sys"!"declare" @ [declareS], "sys"!"wait" @ [Sys.waitS],
                           "sys"!"close" @ [closeS], "malloc"!"malloc" @ [mallocS] ]]
  bmodule "test" {{
    bfunction "write"("fd", "buf", "len") [writeS]
      Assert [Al len,
        PRE[V] buffer_splitAt (wordToNat (V "len")) (V "buf") len
          * [| (wordToNat (V "len") <= len)%nat |]
        POST[_] buffer_joinAt (wordToNat (V "len")) (V "buf") len];;

      Call "sys"!"write"("fd", "buf", "len")
      [PRE[_] Emp POST[_] Emp];;
      Return 0
    end with bfunctionNoRet "main"("fdl", "fd1", "fd2", "ind1", "ind2", "fd", "buf", "n") [mainS]
      "fdl" <-- Call "sys"!"listen"(8080%N)
      [PREonly[_] mallocHeap 0];;

      "fd1" <-- Call "sys"!"accept"("fdl")
      [PREonly[_] mallocHeap 0];;

      "fd2" <-- Call "sys"!"accept"("fdl")
      [PREonly[_] mallocHeap 0];;

      "buf" <-- Call "malloc"!"malloc"(0, 10)
      [PREonly[_, R] R =?> 10];;

      Note [please_materialize_buffer 10];;

      "ind1" <-- Call "sys"!"declare"("fd1", 0)
      [PREonly[V] V "buf" =?>8 40];;

      "ind2" <-- Call "sys"!"declare"("fd2", 0)
      [PREonly[V] V "buf" =?>8 40];;

      "n" <-- Call "sys"!"wait"(1)
      [PREonly[V] V "buf" =?>8 40];;

      [PREonly[V] V "buf" =?>8 40]
      While ("n" <> neg1) {
        If ("n" = "ind1") {
          "fd" <- "fd1"
        } else {
          "fd" <- "fd2"
        };;

        "n" <-- Call "sys"!"read"("fd", "buf", 40)
        [PREonly[V] V "buf" =?>8 40];;

        If ("n" = 0) {
          Call "sys"!"close"("fd")
          [PREonly[V] V "buf" =?>8 40]
        } else {
          If ("fd" = "fd1") {
            "ind1" <-- Call "sys"!"declare"("fd1", 0)
            [PREonly[V] V "buf" =?>8 40]
          } else {
            "ind2" <-- Call "sys"!"declare"("fd2", 0)
            [PREonly[V] V "buf" =?>8 40]
          };;

          If ("n" <= 40) {
            Call "test"!"write"("fd", "buf", "n")
            [PREonly[V] V "buf" =?>8 40]
          } else {
            Skip
          }
        };;

        "n" <-- Call "sys"!"wait"(1)
        [PREonly[V] V "buf" =?>8 40]
      };;

      Call "sys"!"abort"()
      [PREonly[_] [| False |] ]
    end
  }}.

Definition hints : TacPackage.
  prepare (materialize_buffer, buffer_split_tagged) buffer_join_tagged.
Defined.

Hint Extern 1 (@eq W _ _) => words.

Lemma le_40 : forall w : W,
  w <= natToW 40
  -> (wordToNat w <= 40)%nat.
  intros; pre_nomega.
  rewrite wordToNat_natToWord_idempotent in * by reflexivity; omega.
Qed.

Hint Immediate le_40.

Ltac t :=
  try match goal with
        | [ |- context[evalCond _ Le (RvImm (natToW 40)) _ _] ] =>
          post; evaluate hints; exists 40
      end;
  sep hints; auto.

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.

Section heapGS.
  Context `{!heapGS Σ}.
  Implicit Types l : loc.

  Definition record4_make : val :=
    λ: "v₀" "v₁" "v₂" "v₃",
      let: "l" := AllocN #4 "v₀" in
      "l".(1) <- "v₁" ;;
      "l".(2) <- "v₂" ;;
      "l".(3) <- "v₃" ;;
      "l".

  Definition record4_model l dq v₀ v₁ v₂ v₃ : iProp Σ :=
    l.(0) ↦{dq} v₀ ∗
    l.(1) ↦{dq} v₁ ∗
    l.(2) ↦{dq} v₂ ∗
    l.(3) ↦{dq} v₃.

  #[global] Instance record4_model_timeless l dq v₀ v₁ v₂ v₃ :
    Timeless (record4_model l dq v₀ v₁ v₂ v₃).
  Proof.
    apply _.
  Qed.
  #[global] Instance record4_model_persistent l v₀ v₁ v₂ v₃ :
    Persistent (record4_model l DfracDiscarded v₀ v₁ v₂ v₃).
  Proof.
    apply _.
  Qed.

  #[global] Instance record4_model_fractional l v₀ v₁ v₂ v₃ :
    Fractional (λ q, record4_model l (DfracOwn q) v₀ v₁ v₂ v₃).
  Proof.
    apply _.
  Qed.
  #[global] Instance record4_model_as_fractional l q v₀ v₁ v₂ v₃ :
    AsFractional (record4_model l (DfracOwn q) v₀ v₁ v₂ v₃) (λ q, record4_model l (DfracOwn q) v₀ v₁ v₂ v₃) q.
  Proof.
    split; done || apply _.
  Qed.

  Lemma record4_model_persist l dq v₀ v₁ v₂ v₃ :
    record4_model l dq v₀ v₁ v₂ v₃ ==∗
    record4_model l DfracDiscarded v₀ v₁ v₂ v₃.
  Proof.
    iIntros "(Hv₀ & Hv₁ & Hv₂ & Hv₃)".
    iMod (mapsto_persist with "Hv₀") as "$".
    iMod (mapsto_persist with "Hv₁") as "$".
    iMod (mapsto_persist with "Hv₂") as "$".
    iMod (mapsto_persist with "Hv₃") as "$".
    done.
  Qed.

  Lemma record4_model_valid l dq v₀ v₁ v₂ v₃ :
    record4_model l dq v₀ v₁ v₂ v₃ -∗
    ⌜✓ dq⌝.
  Proof.
    iIntros "(Hv₀ & Hv₁ & Hv₂ & Hv₃)". iApply (mapsto_valid with "Hv₀").
  Qed.
  Lemma record4_model_combine l dq1 v₀1 v₁1 v₂1 v₃1 dq2 v₀2 v₁2 v₂2 v₃2 :
    record4_model l dq1 v₀1 v₁1 v₂1 v₃1 -∗
    record4_model l dq2 v₀2 v₁2 v₂2 v₃2 -∗
      record4_model l (dq1 ⋅ dq2) v₀1 v₁1 v₂1 v₃1 ∗
      ⌜v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2 ∧ v₃1 = v₃2⌝.
  Proof.
    iIntros "(Hv₀1 & Hv₁1 & Hv₂1 & Hv₃1) (Hv₀2 & Hv₁2 & Hv₂2 & Hv₃2)".
    iDestruct (mapsto_combine with "Hv₀1 Hv₀2") as "(Hv₀ & <-)".
    iDestruct (mapsto_combine with "Hv₁1 Hv₁2") as "(Hv₁ & <-)".
    iDestruct (mapsto_combine with "Hv₂1 Hv₂2") as "(Hv₂ & <-)".
    iDestruct (mapsto_combine with "Hv₃1 Hv₃2") as "(Hv₃ & <-)".
    iSplit; last done. iFrame.
  Qed.
  Lemma record4_model_valid_2 l dq1 v₀1 v₁1 v₂1 v₃1 dq2 v₀2 v₁2 v₂2 v₃2 :
    record4_model l dq1 v₀1 v₁1 v₂1 v₃1 -∗
    record4_model l dq2 v₀2 v₁2 v₂2 v₃2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2 ∧ v₃1 = v₃2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record4_model_combine with "Hl1 Hl2") as "(Hl & %)".
    iDestruct (record4_model_valid with "Hl") as %?.
    done.
  Qed.
  Lemma record4_model_agree l dq1 v₀1 v₁1 v₂1 v₃1 dq2 v₀2 v₁2 v₂2 v₃2 :
    record4_model l dq1 v₀1 v₁1 v₂1 v₃1 -∗
    record4_model l dq2 v₀2 v₁2 v₂2 v₃2 -∗
    ⌜v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2 ∧ v₃1 = v₃2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record4_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record4_model_dfrac_ne l1 dq1 v₀1 v₁1 v₂1 v₃1 l2 dq2 v₀2 v₁2 v₂2 v₃2 :
    ¬ ✓ (dq1 ⋅ dq2) →
    record4_model l1 dq1 v₀1 v₁1 v₂1 v₃1 -∗
    record4_model l2 dq2 v₀2 v₁2 v₂2 v₃2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iIntros "% Hl1 Hl2" (->).
    iDestruct (record4_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record4_model_ne l1 v₀1 v₁1 v₂1 v₃1 l2 dq2 v₀2 v₁2 v₂2 v₃2 :
    record4_model l1 (DfracOwn 1) v₀1 v₁1 v₂1 v₃1 -∗
    record4_model l2 dq2 v₀2 v₁2 v₂2 v₃2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iApply record4_model_dfrac_ne. intros []%exclusive_l. apply _.
  Qed.
  Lemma record4_model_exclusive l v₀1 v₁1 v₂1 v₃1 v₀2 v₁2 v₂2 v₃2 :
    record4_model l (DfracOwn 1) v₀1 v₁1 v₂1 v₃1 -∗
    record4_model l (DfracOwn 1) v₀2 v₁2 v₂2 v₃2 -∗
    False.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record4_model_ne with "Hl1 Hl2") as %?. naive_solver.
  Qed.

  Lemma record4_dfrac_relax dq l v₀ v₁ v₂ v₃ :
    ✓ dq →
    record4_model l (DfracOwn 1) v₀ v₁ v₂ v₃ ==∗
    record4_model l dq v₀ v₁ v₂ v₃.
  Proof.
    iIntros "% (Hv₀ & Hv₁ & Hv₂ & Hv₃)".
    iMod (mapsto_dfrac_relax with "Hv₀") as "Hv₀"; first done.
    iMod (mapsto_dfrac_relax with "Hv₁") as "Hv₁"; first done.
    iMod (mapsto_dfrac_relax with "Hv₂") as "Hv₂"; first done.
    iMod (mapsto_dfrac_relax with "Hv₃") as "Hv₃"; first done.
    iFrame. done.
  Qed.

  Lemma record4_make_spec v₀ v₁ v₂ v₃ :
    {{{ True }}}
      record4_make v₀ v₁ v₂ v₃
    {{{ l, RET #l; record4_model l (DfracOwn 1) v₀ v₁ v₂ v₃ }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_rec. wp_pures.
    wp_apply (wp_allocN with "[//]"); first done. iIntros "%l (Hl & Hmeta & _)". rewrite loc_add_0.
    wp_pures.
    iDestruct (array_cons with "Hl") as "(Hv₀ & Hl)".
    iEval (setoid_rewrite <- loc_add_0) in "Hv₀".
    iDestruct (array_cons with "Hl") as "(Hv₁ & Hl)".
    iDestruct (array_cons with "Hl") as "(Hv₂ & Hl)".
    rewrite loc_add_assoc Z.add_1_r -Z.two_succ.
    iDestruct (array_singleton with "Hl") as "Hv₃".
    rewrite loc_add_assoc Z.add_1_r. assert (Z.succ 2 = 3)%Z as -> by lia.
    wp_store. wp_store. wp_store.
    iApply "HΦ". iFrame. done.
  Qed.

  Lemma record4_get0_spec l dq v₀ v₁ v₂ v₃ :
    {{{ record4_model l dq v₀ v₁ v₂ v₃ }}}
      !#l.(0)
    {{{ RET v₀; record4_model l dq v₀ v₁ v₂ v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.
  Lemma record4_get1_spec l dq v₀ v₁ v₂ v₃ :
    {{{ record4_model l dq v₀ v₁ v₂ v₃ }}}
      !#l.(1)
    {{{ RET v₁; record4_model l dq v₀ v₁ v₂ v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.
  Lemma record4_get2_spec l dq v₀ v₁ v₂ v₃ :
    {{{ record4_model l dq v₀ v₁ v₂ v₃ }}}
      !#l.(2)
    {{{ RET v₂; record4_model l dq v₀ v₁ v₂ v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.
  Lemma record4_get3_spec l dq v₀ v₁ v₂ v₃ :
    {{{ record4_model l dq v₀ v₁ v₂ v₃ }}}
      !#l.(3)
    {{{ RET v₃; record4_model l dq v₀ v₁ v₂ v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.

  Lemma record4_set0_spec l v₀ v₁ v₂ v₃ v :
    {{{ record4_model l (DfracOwn 1) v₀ v₁ v₂ v₃ }}}
      #l.(0) <- v
    {{{ RET #(); record4_model l (DfracOwn 1) v v₁ v₂ v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.
  Lemma record4_set1_spec l v₀ v₁ v₂ v₃ v :
    {{{ record4_model l (DfracOwn 1) v₀ v₁ v₂ v₃ }}}
      #l.(1) <- v
    {{{ RET #(); record4_model l (DfracOwn 1) v₀ v v₂ v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.
  Lemma record4_set2_spec l v₀ v₁ v₂ v₃ v :
    {{{ record4_model l (DfracOwn 1) v₀ v₁ v₂ v₃ }}}
      #l.(2) <- v
    {{{ RET #(); record4_model l (DfracOwn 1) v₀ v₁ v v₃ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂ & Hv₃) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂ $Hv₃]").
  Qed.
End heapGS.

#[global] Opaque record4_make.

#[global] Opaque record4_model.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Arith.
Require Import Program.
Require Import EquivDec.
Require Import Morphisms.
Require Import Utils.
Require Import DataSystem.
Require Import DNNRCSystem.
Require Import tDNNRC.

Section tDNNRCSub.

  Context {m:basic_model}.

  Section typ.
    Context (τconstants:tdbindings).

    Inductive dnnrc_base_type_sub {A plug_type:Set}
              {plug:AlgPlug plug_type} {tplug: TAlgPlug} :
      tdbindings -> @dnnrc_base _ A plug_type -> drtype -> Prop :=
    | TDNNRCGetConstant {τout} tenv s :
        forall (a:A),
          tdot τconstants s = Some τout ->
          dnnrc_base_type_sub tenv (DNNRCGetConstant a s) τout
    | TDNNRCVar {τ} tenv v :
        forall (a:A),
          lookup equiv_dec tenv v = Some τ ->
          dnnrc_base_type_sub tenv (DNNRCVar a v) τ
    | TDNNRCConst {τ} tenv c :
        forall (a:A),
          data_type (normalize_data brand_relation_brands c) τ ->
          dnnrc_base_type_sub tenv (DNNRCConst a c) (Tlocal τ)
    | TDNNRCBinop  {τ₁ τ₂ τ} tenv b e1 e2 :
        forall (a:A),
          binary_op_type b τ₁ τ₂ τ ->
          dnnrc_base_type_sub tenv e1 (Tlocal τ₁) ->
          dnnrc_base_type_sub tenv e2 (Tlocal τ₂) ->
          dnnrc_base_type_sub tenv (DNNRCBinop a b e1 e2) (Tlocal τ)
    | TDNNRCUnop {τ₁ τ} tenv u e1 :
        forall (a:A),
          unary_op_type u τ₁ τ ->
          dnnrc_base_type_sub tenv e1 (Tlocal τ₁) ->
          dnnrc_base_type_sub tenv (DNNRCUnop a u e1) (Tlocal τ)
    | TDNNRCLet {τ₁ τ₂} v tenv e1 e2 :
        forall (a:A),
          dnnrc_base_type_sub tenv e1 τ₁ ->
          dnnrc_base_type_sub ((v,τ₁)::tenv) e2 τ₂ ->
          dnnrc_base_type_sub tenv (DNNRCLet a v e1 e2) τ₂
    | TDNRCForLocal {τ₁ τ₂} v tenv e1 e2 :
        forall (a:A),
          dnnrc_base_type_sub tenv e1 (Tlocal (Coll τ₁)) ->
          dnnrc_base_type_sub ((v,(Tlocal τ₁))::tenv) e2 (Tlocal τ₂) ->
          dnnrc_base_type_sub tenv (DNNRCFor a v e1 e2) (Tlocal (Coll τ₂))
    | TDNRCForDist {τ₁ τ₂} v tenv e1 e2 :
        forall (a:A),
          dnnrc_base_type_sub tenv e1 (Tdistr τ₁) ->
          dnnrc_base_type_sub ((v,(Tlocal τ₁))::tenv) e2 (Tlocal τ₂) ->
          dnnrc_base_type_sub tenv (DNNRCFor a v e1 e2) (Tdistr τ₂)
    | TDNRCIf {τ} tenv e1 e2 e3 :
        forall (a:A),
          dnnrc_base_type_sub tenv e1 (Tlocal Bool) ->
          dnnrc_base_type_sub tenv e2 τ ->
          dnnrc_base_type_sub tenv e3 τ ->
          dnnrc_base_type_sub tenv (DNNRCIf a e1 e2 e3) τ
    | TDNNRCEither {τ τl τr} tenv ed xl el xr er :
        forall (a:A),
          dnnrc_base_type_sub tenv ed (Tlocal (Either τl τr)) ->
          dnnrc_base_type_sub ((xl,(Tlocal τl))::tenv) el τ ->
          dnnrc_base_type_sub ((xr,(Tlocal τr))::tenv) er τ ->
          dnnrc_base_type_sub tenv (DNNRCEither a ed xl el xr er) τ
    | TDNNRCCollect {τ} tenv e :
        forall (a:A),
          dnnrc_base_type_sub tenv e (Tdistr τ) ->
          dnnrc_base_type_sub tenv (DNNRCCollect a e) (Tlocal (Coll τ))
    | TDNNRCDispatch {τ} tenv e :
        forall (a:A),
          dnnrc_base_type_sub tenv e (Tlocal (Coll τ)) ->
          dnnrc_base_type_sub tenv (DNNRCDispatch a e) (Tdistr τ)
    (* Note: algebra 'plugged' expression is only well typed within distributed
         NNNRC if it returns a collection *)
    | TDNNRCAlg {τout} tenv tbindings op nl :
        forall (a:A),
          Forall2 (fun n τ => fst n = fst τ
                              /\ dnnrc_base_type_sub tenv (snd n) (Tdistr (snd τ)))
                  nl tbindings ->
          plug_typing op tbindings (Coll τout) ->
          dnnrc_base_type_sub tenv (DNNRCAlg a op nl) (Tdistr τout)
    | TDNNRCSubsumption {τenv τout} τenv' τout' e:
        tdbindings_sub τenv' τenv ->
        drtype_sub τout τout' ->
        dnnrc_base_type_sub τenv e τout ->
        dnnrc_base_type_sub τenv' e τout'
    .

    Global Instance dnnrc_base_type_sub_proper {A plug_type:Set} {plug:AlgPlug plug_type} {tplug: TAlgPlug} :
      Proper (tdbindings_sub --> eq ==> drtype_sub ==> impl) (dnnrc_base_type_sub (A:=A)).
    Proof.
      unfold Proper, respectful, flip, impl; intros.
      subst.
      eapply TDNNRCSubsumption; eauto.
    Qed.

    Global Instance dbindings_type_proper :
      Proper (eq ==> tdbindings_sub ==> impl) dbindings_type.
    Proof.
      unfold Proper, respectful, flip, impl, tdbindings_sub, dbindings_type; intros.
      subst.
      revert y y0 H0 H1.
      induction x0; intros x y0 F1 F2
      ; invcs F1; invcs F2; trivial.
      destruct a; destruct y; destruct x1; intuition; simpl in *; subst.
      rewrite H0 in H2.
      auto.
    Qed.

  End typ.

  Section lift.

    Lemma dnnrc_base_type_to_dnnrc_base_type_sub {A} (plug_type:Set) (plug:AlgPlug plug_type) {tplug:TAlgPlug} {τc} {τ} (tenv:tdbindings) (e:@dnnrc_base _ A plug_type) :
      dnnrc_base_type τc tenv e τ ->
      dnnrc_base_type_sub τc tenv e τ.
    Proof.
      Hint Constructors dnnrc_base_type_sub : qcert.
      revert tenv τ.
      induction e; simpl; intros tenv τ dt; invcs dt; qeauto.
      - econstructor; try eassumption.
        revert H5.
        apply Forall2_incl.
        rewrite Forall_forall in H.
        intros ? ? inn1 inn2 [eqq1 eqq2].
        auto.
    Qed.

  End lift.

End tDNNRCSub.


Set Implicit Arguments.

Require Import Bedrock.Platform.Facade.Facade.
Require Bedrock.Platform.Cito.Semantics.

Require Import Coq.Strings.String.
Require Import Bedrock.Platform.Cito.SyntaxExpr.

Fixpoint compile (s : Stmt) : Syntax.Stmt :=
  match s with
    | Skip => Syntax.Skip
    | Seq a b => Syntax.Seq (compile a) (compile b)
    | If e t f => Syntax.If e (compile t) (compile f)
    | While e c => Syntax.While e (compile c)
    | Facade.Assign x e => Syntax.Assign x e
    | Label x lbl => Syntax.Label x lbl
    | Call x f args => Syntax.Call (Some x) f (List.map Var args)
  end.

Require Import Bedrock.Platform.Cito.ListFacts3.

Definition compile_op (spec : OperationalSpec) :=
  {|
    Semantics.Fun :=
      {|
        FuncCore.ArgVars := ArgVars spec;
        FuncCore.RetVar := RetVar spec;
        FuncCore.Body := compile (Body spec)
      |};
    Semantics.NoDupArgVars := args_no_dup spec
  |}.


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Definition VerifiedRewriterUnfoldValueBarrier : VerifiedRewriter_with_args false false true unfold_value_barrier_rewrite_rules_proofs.
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterUnfoldValueBarrier.
      Let optsT := Eval hnf in optsT VerifiedRewriterUnfoldValueBarrier.

      Definition RewriteUnfoldValueBarrier (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterUnfoldValueBarrier opts t.

      Lemma Wf_RewriteUnfoldValueBarrier opts {t} e (Hwf : Wf e) : Wf (@RewriteUnfoldValueBarrier opts t e).
      Proof. now apply VerifiedRewriterUnfoldValueBarrier. Qed.

      Lemma Interp_RewriteUnfoldValueBarrier opts {t} e (Hwf : Wf e) : API.Interp (@RewriteUnfoldValueBarrier opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterUnfoldValueBarrier. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
    Hint Resolve Wf_RewriteUnfoldValueBarrier : wf wf_extra.
    Hint Opaque RewriteUnfoldValueBarrier : wf wf_extra interp interp_extra rewrite.
    Hint Rewrite @Interp_RewriteUnfoldValueBarrier : interp interp_extra.
  End Hints.
End Compilers.


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
Require Import Eqdep_dec List.
From cap_machine Require Import malloc macros.
From cap_machine Require Import fundamental logrel macros_helpers rules proofmode.
From cap_machine.examples Require Import template_adequacy.
From cap_machine Require Import register_tactics.
From cap_machine.exercises Require Import subseg_buffer.
Open Scope Z_scope.

(** Secondly, the other approach is to dynamically allocate the region with
    the `malloc` macro. *)
Section malloc_program.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg : sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MP: MachineParameters}.

  Definition prog_malloc_instrs f_m (size : nat) secret_off secret_val : list Word :=
    (* code: *)
    malloc_instrs f_m size ++ (prog_code secret_off secret_val).

  Definition prog_malloc_code a_prog f_m size secret_off secret_val :=
    ([∗ list] a_i;w ∈ a_prog;(prog_malloc_instrs f_m size secret_off secret_val), a_i ↦ₐ w)%I.

  (** We define the needed invariant *)

  Definition malloc_versionN : namespace := nroot .@ "malloc_version".

  (* Program invariant *)
  Definition malloc_codeN := (malloc_versionN.@"code").
  Definition prog_malloc_inv a f_m size secret_off secret_val  :=
    na_inv logrel_nais malloc_codeN (prog_malloc_code a f_m size secret_off secret_val ).

  (* Malloc invariant *)
  Definition mallocN := (malloc_versionN.@"malloc").
  Definition malloc_nainv b_m e_m :=
    na_inv logrel_nais mallocN (malloc_inv b_m e_m).

  (* Linking table invariant *)
  Definition link_tableN := (malloc_versionN.@"link_table").
  Definition link_table_inv
             table_addr b_link e_link a_link
             malloc_entry b_m e_m :=
    na_inv logrel_nais link_tableN
    (table_addr ↦ₐ WCap RO b_link e_link a_link
    ∗ malloc_entry ↦ₐ WCap E b_m e_m b_m)%I.

  (* This spec re-uses the specification defined in the previous section *)
  Lemma prog_malloc_spec
        (a_prog : Addr)
        wadv w0
        rmap (* resources *)
        a p b e a_first a_last (* pc *)
        f_m b_m e_m (* malloc *)
        b_link a_link e_link a_entry (* linking *)
        (size : nat) secret_off secret_val
        EN
        φ :

    let rmap_post :=
    (∃ b_l e_l,
     ([∗ map] r_i↦w_i ∈ (<[r_t1:=WCap RWX (b_l ^+ (secret_off+1))%a e_l (b_l ^+ secret_off)%a]>
                           (<[r_t2:=WInt (b_l + (secret_off+1))]>
                              (<[r_t3:=WInt e_l]>
                                 (<[r_t4:=WInt 0]> (<[r_t5:=WInt 0]> rmap))))),
       r_i ↦ᵣ w_i)
       ∗ [[(b_l ^+ (secret_off+1))%a,e_l]]↦ₐ[[region_addrs_zeroes (b_l ^+ (secret_off+1))%a e_l]]
    )%I
    in

    ExecPCPerm p →
    SubBounds b e a_first a_last ->
    contiguous_between a a_first a_last →
    withinBounds b_link e_link a_entry = true →
    (a_link + f_m)%a = Some a_entry →
    (0 <= secret_off < size %a) ->

    dom rmap = all_registers_s ∖ {[ PC; r_t0 ; r_t30 ]} →
    ↑malloc_versionN ⊆ EN ->

    ⊢ (( prog_malloc_inv a f_m size secret_off secret_val
          ∗ malloc_nainv b_m e_m
          ∗ link_table_inv b b_link e_link a_link a_entry b_m e_m
          ∗ PC ↦ᵣ WCap p b e a_first
          ∗ r_t0 ↦ᵣ w0
          ∗ r_t30 ↦ᵣ wadv
          ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
          ∗ na_own logrel_nais EN
          ∗ ▷ ( PC ↦ᵣ updatePcPerm wadv
                ∗ r_t30 ↦ᵣ wadv
                ∗ r_t0 ↦ᵣ w0
                ∗ rmap_post
                ∗ na_own logrel_nais EN
                -∗ WP Seq (Instr Executable) {{λ v, φ v ∨ ⌜v = FailedV⌝ }}))
        -∗ WP Seq (Instr Executable) {{λ v, φ v ∨ ⌜v = FailedV⌝ }})%I.
  Proof.
    intros rmap_post ; subst rmap_post.
    iIntros
      (Hpc_perm Hpc_bounds Hcont Hwb Hlink Hsecret_size Hdom Hna_malloc)
      "(#Hinv_prog & #Hinv_malloc & #Hinv_link & HPC& Hr0& Hr30& Hrmap& Hna& Post)".
    simpl in *.

    (* Open the invariants *)
    iMod (na_inv_acc with "Hinv_prog Hna") as "(>Hprog & Hna & Hinv_close_prog)"
    ; auto ; try solve_ndisj.
    rewrite {1}/prog_malloc_code {1}/prog_malloc_instrs.
    iMod (na_inv_acc with "Hinv_link Hna") as "(>[Hb Ha_entry] & Hna & Hinv_close_link)"
    ; auto ; try solve_ndisj.

    (* Prepare the ressources for the use of malloc_spec *)
    (* Extract malloc from the program *)
    iDestruct (contiguous_between_program_split with "Hprog") as
      (malloc_prog rest1 link1) "(Hmalloc_prog & Hprog & #Hcont1)"
    ;[apply Hcont|].
    iDestruct "Hcont1" as %(Hcont1 & Hcont2 & Heqapp1 & Hlink1).

    (* Insert r30 in rmap *)
    assert (dom (<[r_t30:=wadv]> rmap) =
              all_registers_s ∖ {[PC; r_t0]}) as Hdomeq.
    { rewrite dom_insert_L.
      rewrite Hdom.
      rewrite - difference_difference_L.
      rewrite -union_difference_L; auto.
      set_solver.
    }
    iInsert "Hrmap" r_t30.

    (* Malloc spec *)
    rewrite -/(malloc _ _ _).
    iApply (wp_wand_l _ _ _ (λ v, ((φ v ∨ ⌜v = FailedV⌝) ∨ ⌜v = FailedV⌝)))%I. iSplitR.
    { iIntros (v) "[H|H] /=";auto. }
    iApply (malloc_spec _ size with
             "[- $Hmalloc_prog $Hinv_malloc $Hna $Hb $Ha_entry $HPC $Hr0 $Hrmap]")
    ; auto ; try solve_ndisj ; try lia.
    { rewrite /contiguous.isCorrectPC_range; intros.
      apply isCorrectPC_ExecPCPerm_InBounds ; auto.
      apply contiguous_between_bounds in Hcont2.
      solve_addr.
    }
    iNext.
    iIntros "(HPC & Hmalloc & Hb & Ha_entry & Hregion & Hr0 & Hna & Hgen)"
    ; iDestruct "Hregion" as (b_l e_l Hmem_size) "(Hr1 & Hmem)".

    (* Prepare ressources for the use of prof_spec_CPS *)
    (* Extract some registers *)
    iExtractList "Hgen" [r_t2;r_t3;r_t30] as ["Hr2";"Hr3";"Hadv"].

    (* Convert the [* list] of instructions into a codefrag *)
    set (prog_instrs := (encodeInstrsW
                      [Lea r_t1 secret_off; Store r_t1 secret_val; GetB r_t2 r_t1; GetE r_t3 r_t1;
                       Add r_t2 r_t2 (secret_off+1); Subseg r_t1 r_t2 r_t3; Jmp r_t30]) ).
    iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog.
    iAssert (codefrag link1 prog_instrs) with "[Hprog]" as "Hprog".
    { rewrite /codefrag. simpl. rewrite /region_mapsto.
      simpl in *.
      replace rest1 with (finz.seq_between link1 (link1 ^+ 7%nat)%a).
      done.
      symmetry.
      apply region_addrs_of_contiguous_between.
      replace (link1 ^+ 7%nat)%a with a_last. done.
      apply contiguous_between_length in Hcont2.
      rewrite Hlength_prog in Hcont2.
      solve_addr. }

    (* Apply the prog_spec *)
    iApply (prog_spec_CPS with "[- $HPC $Hprog $Hr1 $Hr2 $Hr3 $Hmem $Hadv]")
    ; auto ; try solve_addr.
    { simpl in *.
      apply contiguous_between_length in Hcont2.
      rewrite Hlength_prog /= in Hcont2.
      solve_addr.
    }
    iNext.
    iIntros "(HPC& Hr1& Hr2& Hr3& Hr30& Hprog& Hmem)".

    (* Close the invariants *)
    iMod ("Hinv_close_link" with "[$Hb $Ha_entry $Hna]") as "Hna".

    iMod ("Hinv_close_prog" with "[Hprog Hmalloc $Hna]") as "Hna".
    {
    subst a.
    rewrite /prog_code /codefrag /malloc.
    iAssert (([∗ list] a_i;w ∈ (malloc_prog ++ rest1)
              ;(malloc_instrs f_m size ++ prog_instrs), a_i ↦ₐ w)%I)
            with "[Hprog Hmalloc]"
      as "Hprog'" .
    {iApply (big_sepL2_app with "[Hmalloc]") ; [done|].
      simpl. rewrite /region_mapsto.
      simpl in *.
      replace rest1 with (finz.seq_between link1 (link1 ^+ 7%nat)%a).
      done.
      symmetry.
      apply region_addrs_of_contiguous_between.
      replace (link1 ^+ 7%nat)%a with a_last. done.
      apply contiguous_between_length in Hcont2.
      rewrite Hlength_prog in Hcont2.
      solve_addr.
    }
    iFrame.
    }

    (* Apply the continuation *)
    iApply "Post". iFrame.
    replace ((b_l ^+ secret_off) ^+ 1)%a with (b_l ^+ (secret_off+1))%a by solve_addr.

    iExists _, _.
    iFrame.

    iInsertList "Hgen" [r_t3;r_t2;r_t1].
    rewrite (delete_notin); [ | apply not_elem_of_dom_1; clear -Hdom; set_solver].
    iAssumption.
  Qed.

  Lemma prog_malloc_full_run_spec
        wadv w0
        rmap (* register map *)
        a p b e a_first a_last (* pc *)
        f_m b_m e_m (* malloc *)
        b_link a_link e_link a_entry (* linking *)
        (size : nat) secret_off secret_val :

      ExecPCPerm p →
      SubBounds b e a_first a_last ->
      contiguous_between a a_first a_last →
      withinBounds b_link e_link a_entry = true →
      (a_link + f_m)%a = Some a_entry →
      (0 <= secret_off < size %a) ->

      dom rmap = all_registers_s ∖ {[ PC; r_t0 ; r_t30 ]} →

      ⊢ (( malloc_nainv b_m e_m
            ∗ prog_malloc_inv a f_m size secret_off secret_val
            ∗ link_table_inv b b_link e_link a_link a_entry b_m e_m

            ∗ PC ↦ᵣ WCap p b e a_first
            ∗ r_t0 ↦ᵣ w0
            ∗ r_t30 ↦ᵣ wadv
            ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i ∗ interp w_i )
            ∗ na_own logrel_nais ⊤

            ∗ interp wadv
            ∗ interp w0
            )
          -∗ WP Seq (Instr Executable) {{λ v,
                  (⌜v = HaltedV⌝ → ∃ r : Reg, full_map r ∧ registers_mapsto r ∗ na_own logrel_nais ⊤)%I
                  ∨ ⌜v = FailedV⌝ }})%I.
  Proof.
    intros *.
    iIntros
      (Hpc_perm Hpc_bounds Hcont Hwb Hlink Hsize_secret Hdom)
      "(#Hinv_malloc& #Hinv_prog& #Hinv_link& HPC& Hr0 &Hr30& Hrmap& Hown& #Hadv & #Hw0)".

    (* First and foremost, we prove that wadv is safe to execute *)
    iDestruct (jmp_to_unknown with "Hadv") as "Cont"; eauto.

    (* Apply the specification of the program *)
    iDestruct (big_sepM_sep with "Hrmap") as "[Hrmap Hrmap_interp]".
    iApply (prog_malloc_spec with "[-]") ; eauto.
    iFrame ; iFrame "#".
    iNext ; iIntros "(HPC & Hr30 & Hr0 & Hrmap & Hna)"
    ; iDestruct "Hrmap" as (b_mem e_mem) "[Hrmap Hmem]".

    (* After the specificatio, the PC points to the adversary code.
       Since it is safe to share, we have a continuation that prove the full
       safe execution. But we need to manipulate the resources in order to
       use this continuation *)
    set ( rmap' := (<[r_t1:=WCap RWX (b_mem ^+ (secret_off+1))%a e_mem (b_mem ^+ secret_off)%a]>
                      (<[r_t2:=WInt (b_mem + (secret_off+1))]>
                         (<[r_t3:=WInt e_mem]>
                            (<[r_t4:=WInt 0]> (<[r_t5:=WInt 0]> rmap)))))
        ).
    (* Insert the registers r0 and r30 in the register map *)
    assert (dom (<[r_t0 := w0]> (<[r_t30:=wadv]> rmap'))
            = all_registers_s ∖ {[PC]}).
    { rewrite !dom_insert_L. rewrite Hdom.
      replace (all_registers_s ∖ {[PC]})
              with
              ({[r_t0; r_t30]} ∪ all_registers_s ∖ {[PC; r_t0; r_t30]})
      ; [set_solver|].
      rewrite - !difference_difference_L.
      rewrite (difference_difference_L _ {[r_t0]}).
      rewrite -union_difference_L; auto.
      set_solver.
    }

    (* r1 is safe to share *)
    iDestruct (region_integers_alloc' _ _ _ (b_mem ^+ secret_off)%a _ RWX  with "Hmem") as ">#Hmem"
    ; [rewrite /region_addrs_zeroes; apply Forall_replicate; auto|].

    iApply (wp_wand with "[-]").
    2: {iIntros (v) "Hv" ; by iLeft. }
    iApply ("Cont" with "[]") ; eauto ; iFrame.
    subst rmap'.

    (* We need to prove that all the registers are r -> v and interp v.
       But, the register maps is split, such that some of them are known a interp,
       but the one that have been modified by the specification are not.
       Thus, we have to extract all the new register from the map,
       recombine the [* map] over rmap, and re-insert the new registers
       into the rmap, proving both points_to and interp.
     *)
    (* First, extract the new registers *)
    iApply (big_sepM_sep_2 with "[- Hrmap_interp]").
    - by iInsertList "Hrmap" [r_t30;r_t0].
    - iApply big_sepM_intro. iDestruct "Hrmap_interp" as "#Hmap_interp".
      iIntros "!>" (r w).
      consider_next_reg r r_t0; [iIntros (Hr0) ; by inversion Hr0 |].
      consider_next_reg r r_t30; [iIntros (Hr0) ; by inversion Hr0 |].
      consider_next_reg r r_t1; [iIntros (Hr0) ; by inversion Hr0 |].
      consider_next_reg r r_t2; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |].
      consider_next_reg r r_t3; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |].
      consider_next_reg r r_t4; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |].
      consider_next_reg r r_t5; [iIntros (Hr0) ; inversion Hr0; by rewrite !fixpoint_interp1_eq /= |].
      iIntros (Hr).
      iDestruct (big_sepM_delete _ _ r with "Hmap_interp") as "[Hr_t7 Hregs]"; eauto.
Qed.

  Lemma prog_malloc_safe_to_share
        pc_b pc_e
        a a_first a_last f_m b_m e_m
        b_link e_link a_link a_entry
        (size : nat) secret_off secret_val :

    SubBounds pc_b pc_e a_first a_last ->
    contiguous_between a a_first a_last →
    withinBounds b_link e_link a_entry = true →
    (a_link + f_m)%a = Some a_entry →
    (0 <= secret_off < size %a) ->

    ⊢ prog_malloc_inv a f_m size secret_off secret_val
      ∗ malloc_nainv b_m e_m
      ∗ link_table_inv pc_b b_link e_link a_link a_entry b_m e_m

    -∗ interp (WCap E pc_b pc_e a_first).
  Proof.
    iIntros (Hpc_bounds Hcont HlinkB HlinkE Hsize) "(#Hinv_prog& #Hinv_malloc& #Hinv_link)".
    simpl.
    rewrite !fixpoint_interp1_eq /=.
    iIntros (regs).
    iNext. iModIntro.
    iIntros "(Hrsafe& Hregs& Hna)".
    iDestruct "Hrsafe" as "[%Hrfull #Hrsafe]".
    rewrite /interp_conf.
    rewrite {1}/registers_mapsto.

    (* Extract the registers from the map *)
    apply regmap_full_dom in Hrfull as Hrfull'.
    assert (is_Some (regs !! r_t0)) as [w0 Hw0];[set_solver|].
    assert (is_Some (regs !! r_t30)) as [w30 Hw30];[set_solver|].
    iExtractList "Hregs" [PC;r_t0;r_t30] as ["HPC";"Hr0";"Hr30"].

    iAssert (interp w0) as "Hw0" ; first (iApply ("Hrsafe" $! r_t0 w0) ; eauto).
    iAssert (interp w30) as "Hw30" ; first (iApply ("Hrsafe" $! r_t30 w30) ; eauto).

    iApply (wp_wand _ _ _
                    (λ v0 : language.val cap_lang,
                        (⌜v0 = HaltedV⌝ →
                         ∃ r : Reg, full_map r
                                    ∧ registers_mapsto r ∗ na_own logrel_nais ⊤)
                        ∨ ⌜v0 = FailedV⌝)%I
             with "[-]").
    2:{ iIntros (v) "Hv"; iDestruct "Hv" as "[Hv|->]" ; auto.
      iIntros ; done. }

    (* Apply the full run spec *)
    iApply (prog_malloc_full_run_spec _ _
                                      (delete r_t30 (delete r_t0 (delete PC regs)))
             with "[-]")
    ; try (iFrame ; iFrame "#")
    ; try apply ExecPCPerm_RX
    ; eauto.
    - rewrite !dom_delete_L.
      rewrite (difference_difference_L _ {[PC]}).
      rewrite (difference_difference_L _ _ {[r_t30]}).
      apply regmap_full_dom in Hrfull.
      rewrite Hrfull.
      set_solver.
    - iDestruct (big_sepM_sep _ (λ k v, interp v)%I with "[Hregs]") as "Hregs".
      { iSplitL. by iApply "Hregs". iApply big_sepM_intro. iModIntro.
        iIntros (r' ? HH). repeat eapply lookup_delete_Some in HH as [? HH].
        iApply ("Hrsafe" $! r'); auto. }
      simpl.
      iFrame.
Qed.

End malloc_program.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation from Mach to ARM. *)

Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Locations.
Require Import Mach.
Require Import Asm.
Require Import Compopts.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

(** Extracting integer or float registers. *)

Definition ireg_of (r: mreg) : res ireg :=
  match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.

Definition freg_of (r: mreg) : res freg :=
  match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.

(** Recognition of integer immediate arguments for arithmetic operations.
- ARM: immediates are 8-bit quantities zero-extended and rotated right
  by 0, 2, 4, ... 30 bits.  In other words, [n] is an immediate iff
  [rotate-left(n, p)] is between 0 and 255 for some [p = 0, 2, 4, ..., 30].
- Thumb: immediates are 8-bit quantities zero-extended and shifted left
  by 0, 1, ..., 31 bits.  In other words, [n] is an immediate if
  all bits are 0 except a run of 8 adjacent bits.  In addition,
  [00XY00XY] and [XY00XY00] and [XYXYXYXY] are immediates for
  a given [XY] 8-bit constant.
*)

Fixpoint is_immed_arith_arm (n: nat) (x: int) {struct n}: bool :=
  match n with
  | Datatypes.O => false
  | Datatypes.S n =>
      Int.eq x (Int.and x (Int.repr 255)) ||
      is_immed_arith_arm n (Int.rol x (Int.repr 2))
  end.

Fixpoint is_immed_arith_thumb (n: nat) (x: int) {struct n}: bool :=
  match n with
  | Datatypes.O => true
  | Datatypes.S n =>
      Int.eq x (Int.and x (Int.repr 255)) ||
      (Int.eq (Int.and x Int.one) Int.zero
       && is_immed_arith_thumb n (Int.shru x Int.one))
  end.

Definition is_immed_arith_thumb_special (x: int): bool :=
  let l1 := Int.and x (Int.repr 255) in
  let l2 := Int.shl l1 (Int.repr 8) in
  let l3 := Int.shl l2 (Int.repr 8) in
  let l4 := Int.shl l3 (Int.repr 8) in
  let l13 := Int.or l1 l3 in
  let l24 := Int.or l2 l4 in
  Int.eq x l13 || Int.eq x l24 || Int.eq x (Int.or l13 l24).

Definition is_immed_arith (x: int): bool :=
  if thumb tt
  then is_immed_arith_thumb 24%nat x || is_immed_arith_thumb_special x
  else is_immed_arith_arm 16%nat x.

(** Recognition of integer immediate arguments for indexed memory accesses.
- For 32-bit integers, immediate offsets are [(-2^12,2^12)] for ARM classic
  and [(-2^8,2^12)] for Thumb2.
- For 8- and 16-bit integers, immediate offsets are [(-2^8,2^8)].
- For 32- and 64-bit integers, immediate offsets are multiples of 4
  in [(-2^10,2^10)].

For all 3 kinds of accesses, we provide not a recognizer but a synthesizer:
a function taking an arbitrary offset [n] and returning a valid offset [n']
that contains as many useful bits of [n] as possible, so that the
computation of the remainder [n - n'] is as simple as possible.
In particular, if [n] is a representable immediate argument, we should have
[n' = n].
*)

Definition mk_immed_mem_word (x: int): int :=
  if Int.ltu x Int.zero then
    Int.neg (Int.zero_ext (if thumb tt then 8 else 12) (Int.neg x))
  else
    Int.zero_ext 12 x.

Definition mk_immed_mem_small (x: int): int :=
  if Int.ltu x Int.zero then
    Int.neg (Int.zero_ext 8 (Int.neg x))
  else
    Int.zero_ext 8 x.

Definition mk_immed_mem_float (x: int): int :=
  let x := Int.and x (Int.repr (-4)) in   (**r mask low 2 bits off *)
  if Int.ltu x Int.zero then
    Int.neg (Int.zero_ext 10 (Int.neg x))
  else
    Int.zero_ext 10 x.

(** Decomposition of a 32-bit integer into a list of immediate arguments,
    whose sum or "or" or "xor" equals the integer. *)

Fixpoint decompose_int_arm (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl (Int.repr 3) p)) Int.zero then
        decompose_int_arm M n (Int.add p (Int.repr 2))
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_arm M (Int.and n (Int.not m)) (Int.add p (Int.repr 2))
  end.

Fixpoint decompose_int_thumb (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl Int.one p)) Int.zero then
        decompose_int_thumb M n (Int.add p Int.one)
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_thumb M (Int.and n (Int.not m)) (Int.add p Int.one)
  end.

Definition decompose_int_base (n: int): list int :=
  if thumb tt
  then if is_immed_arith_thumb_special n
       then n :: nil
       else decompose_int_thumb 24%nat n Int.zero
  else decompose_int_arm 12%nat n Int.zero.

Definition decompose_int (n: int) : list int :=
  match decompose_int_base n with
  | nil => Int.zero :: nil
  | l   => l
  end.

Definition iterate_op (op1 op2: shift_op -> instruction) (l: list int) (k: code) :=
  match l with
  | nil =>
      op1 (SOimm Int.zero) :: k                 (**r should never happen *)
  | i :: l' =>
      op1 (SOimm i) :: map (fun i => op2 (SOimm i)) l' ++ k
  end.

(** Smart constructors for integer immediate arguments. *)

Definition loadimm_thumb (r: ireg) (n: int) (k: code) :=
  let hi := Int.shru n (Int.repr 16) in
  if Int.eq hi Int.zero
  then Pmovw r n :: k
  else Pmovw r (Int.zero_ext 16 n) :: Pmovt r hi :: k.

Definition loadimm (r: ireg) (n: int) (k: code) :=
  let d1 := decompose_int n in
  let d2 := decompose_int (Int.not n) in
  let l1 := List.length d1 in
  let l2 := List.length d2 in
  if NPeano.leb l1 1%nat then
    Pmov r (SOimm n) :: k
  else if NPeano.leb l2 1%nat then
    Pmvn r (SOimm (Int.not n)) :: k
  else if thumb tt then
    loadimm_thumb r n k
  else if NPeano.leb l1 l2 then
    iterate_op (Pmov r) (Porr r r) d1 k
  else
    iterate_op (Pmvn r) (Pbic r r) d2 k.

Definition addimm (r1 r2: ireg) (n: int) (k: code) :=
  if Int.ltu (Int.repr (-256)) n then
    Psub r1 r2 (SOimm (Int.neg n)) :: k
  else
   (let d1 := decompose_int n in
    let d2 := decompose_int (Int.neg n) in
    if NPeano.leb (List.length d1) (List.length d2)
    then iterate_op (Padd r1 r2) (Padd r1 r1) d1 k
    else iterate_op (Psub r1 r2) (Psub r1 r1) d2 k).

Definition rsubimm (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Prsb r1 r2) (Padd r1 r1) (decompose_int n) k.

Definition andimm (r1 r2: ireg) (n: int) (k: code) :=
  if is_immed_arith n
  then Pand r1 r2 (SOimm n) :: k
  else iterate_op (Pbic r1 r2) (Pbic r1 r1) (decompose_int (Int.not n)) k.

Definition orimm  (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Porr r1 r2) (Porr r1 r1) (decompose_int n) k.

Definition xorimm  (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Peor r1 r2) (Peor r1 r1) (decompose_int n) k.

(** Translation of a shift immediate operation (type [Op.shift]) *)

Definition transl_shift (s: shift) (r: ireg) : shift_op :=
  match s with
  | Slsl n => SOlsl r (s_amount n)
  | Slsr n => SOlsr r (s_amount n)
  | Sasr n => SOasr r (s_amount n)
  | Sror n => SOror r (s_amount n)
  end.

(** Translation of a condition.  Prepends to [k] the instructions
  that evaluate the condition and leave its boolean result in one of
  the bits of the condition register.  The bit in question is
  determined by the [crbit_for_cond] function. *)

Definition transl_cond
              (cond: condition) (args: list mreg) (k: code) :=
  match cond, args with
  | Ccomp c, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1(SOreg r2) :: k)
  | Ccompu c, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (SOreg r2) :: k)
  | Ccompshift c s, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (transl_shift s r2) :: k)
  | Ccompushift c s, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (transl_shift s r2) :: k)
  | Ccompimm c n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_immed_arith n then
            Pcmp r1 (SOimm n) :: k
          else
            loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
  | Ccompuimm c n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_immed_arith n then
            Pcmp r1 (SOimm n) :: k
          else
            loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
  | Ccompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmpd r1 r2 :: k)
  | Cnotcompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmpd r1 r2 :: k)
  | Ccompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzd r1 :: k)
  | Cnotcompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzd r1 :: k)
  | Ccompfs cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmps r1 r2 :: k)
  | Cnotcompfs cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmps r1 r2 :: k)
  | Ccompfszero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzs r1 :: k)
  | Cnotcompfszero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzs r1 :: k)
  | _, _ =>
      Error(msg "Asmgen.transl_cond")
  end.

Definition cond_for_signed_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TClt
  | Cle => TCle
  | Cgt => TCgt
  | Cge => TCge
  end.

Definition cond_for_unsigned_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TClo
  | Cle => TCls
  | Cgt => TChi
  | Cge => TChs
  end.

Definition cond_for_float_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TCmi
  | Cle => TCls
  | Cgt => TCgt
  | Cge => TCge
  end.

Definition cond_for_float_not_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCne
  | Cne => TCeq
  | Clt => TCpl
  | Cle => TChi
  | Cgt => TCle
  | Cge => TClt
  end.

Definition cond_for_cond (cond: condition) :=
  match cond with
  | Ccomp cmp => cond_for_signed_cmp cmp
  | Ccompu cmp => cond_for_unsigned_cmp cmp
  | Ccompshift cmp s => cond_for_signed_cmp cmp
  | Ccompushift cmp s => cond_for_unsigned_cmp cmp
  | Ccompimm cmp n => cond_for_signed_cmp cmp
  | Ccompuimm cmp n => cond_for_unsigned_cmp cmp
  | Ccompf cmp => cond_for_float_cmp cmp
  | Cnotcompf cmp => cond_for_float_not_cmp cmp
  | Ccompfzero cmp => cond_for_float_cmp cmp
  | Cnotcompfzero cmp => cond_for_float_not_cmp cmp
  | Ccompfs cmp => cond_for_float_cmp cmp
  | Cnotcompfs cmp => cond_for_float_not_cmp cmp
  | Ccompfszero cmp => cond_for_float_cmp cmp
  | Cnotcompfszero cmp => cond_for_float_not_cmp cmp
  end.

(** Translation of the arithmetic operation [r <- op(args)].
  The corresponding instructions are prepended to [k]. *)

Definition transl_op
              (op: operation) (args: list mreg) (res: mreg) (k: code) :=
  match op, args with
  | Omove, a1 :: nil =>
      match preg_of res, preg_of a1 with
      | IR r, IR a => OK (Pmov r (SOreg a) :: k)
      | FR r, FR a => OK (Pfcpyd r a :: k)
      |  _  ,  _   => Error(msg "Asmgen.Omove")
      end
  | Ointconst n, nil =>
      do r <- ireg_of res;
      OK (loadimm r n k)
  | Ofloatconst f, nil =>
      do r <- freg_of res;
      OK (Pflid r f :: k)
  | Osingleconst f, nil =>
      do r <- freg_of res;
      OK (Pflis r f :: k)
  | Oaddrsymbol s ofs, nil =>
      do r <- ireg_of res;
      OK (Ploadsymbol r s ofs :: k)
  | Oaddrstack n, nil =>
      do r <- ireg_of res;
      OK (addimm r IR13 n k)
  | Ocast8signed, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (if thumb tt then
            Psbfx r r1 Int.zero (Int.repr 8) :: k
          else
            Pmov r (SOlsl r1 (Int.repr 24)) ::
            Pmov r (SOasr r (Int.repr 24)) :: k)
  | Ocast16signed, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (if thumb tt then
            Psbfx r r1 Int.zero (Int.repr 16) :: k
          else
            Pmov r (SOlsl r1 (Int.repr 16)) ::
            Pmov r (SOasr r (Int.repr 16)) :: k)
  | Oadd, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd r r1 (SOreg r2) :: k)
  | Oaddshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd r r1 (transl_shift s r2) :: k)
  | Oaddimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (addimm r r1 n k)
  | Osub, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub r r1 (SOreg r2) :: k)
  | Osubshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub r r1 (transl_shift s r2) :: k)
  | Orsubshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Prsb r r1 (transl_shift s r2) :: k)
  | Orsubimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (rsubimm r r1 n k)
  | Omul, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmul r r1 r2 :: k)
  | Omla, a1 :: a2 :: a3 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (Pmla r r1 r2 r3 :: k)
  | Omulhs, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psmull IR14 r r1 r2 :: k)
  | Omulhu, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pumull IR14 r r1 r2 :: k)
  | Odiv, a1 :: a2 :: nil =>
      assertion (mreg_eq res R0);
      assertion (mreg_eq a1 R0);
      assertion (mreg_eq a2 R1);
      OK (Psdiv :: k)
  | Odivu, a1 :: a2 :: nil =>
      assertion (mreg_eq res R0);
      assertion (mreg_eq a1 R0);
      assertion (mreg_eq a2 R1);
      OK (Pudiv :: k)
  | Oand, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand r r1 (SOreg r2) :: k)
  | Oandshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand r r1 (transl_shift s r2) :: k)
  | Oandimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (andimm r r1 n k)
  | Oor, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr r r1 (SOreg r2) :: k)
  | Oorshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr r r1 (transl_shift s r2) :: k)
  | Oorimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (orimm r r1 n k)
  | Oxor, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor r r1 (SOreg r2) :: k)
  | Oxorshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor r r1 (transl_shift s r2) :: k)
  | Oxorimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (xorimm r r1 n k)
  | Obic, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic r r1 (SOreg r2) :: k)
  | Obicshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic r r1 (transl_shift s r2) :: k)
  | Onot, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmvn r (SOreg r1) :: k)
  | Onotshift s, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmvn r (transl_shift s r1) :: k)
  | Oshl, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plsl r r1 r2 :: k)
  | Oshr, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pasr r r1 r2 :: k)
  | Oshru, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plsr r r1 r2 :: k)
  | Oshift s, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmov r (transl_shift s r1) :: k)
  | Oshrximm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      if Int.eq n Int.zero then
        OK (Pmov r (SOreg r1) :: k)
      else
        OK (Pmov IR14 (SOasr r1 (Int.repr 31)) ::
            Padd IR14 r1 (SOlsr IR14 (Int.sub Int.iwordsize n)) ::
            Pmov r (SOasr IR14 n) :: k)
  | Onegf, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfnegd r r1 :: k)
  | Oabsf, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfabsd r r1 :: k)
  | Oaddf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfaddd r r1 r2 :: k)
  | Osubf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfsubd r r1 r2 :: k)
  | Omulf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfmuld r r1 r2 :: k)
  | Odivf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfdivd r r1 r2 :: k)
  | Onegfs, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfnegs r r1 :: k)
  | Oabsfs, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfabss r r1 :: k)
  | Oaddfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfadds r r1 r2 :: k)
  | Osubfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfsubs r r1 r2 :: k)
  | Omulfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfmuls r r1 r2 :: k)
  | Odivfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfdivs r r1 r2 :: k)
  | Osingleoffloat, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfcvtsd r r1 :: k)
  | Ofloatofsingle, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfcvtds r r1 :: k)
  | Ointoffloat, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftosizd r r1 :: k)
  | Ointuoffloat, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftouizd r r1 :: k)
  | Ofloatofint, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfsitod r r1 :: k)
  | Ofloatofintu, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfuitod r r1 :: k)
  | Ointofsingle, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftosizs r r1 :: k)
  | Ointuofsingle, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftouizs r r1 :: k)
  | Osingleofint, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfsitos r r1 :: k)
  | Osingleofintu, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfuitos r r1 :: k)
  | Ocmp cmp, _ =>
      do r <- ireg_of res;
      transl_cond cmp args
        (Pmovite (cond_for_cond cmp) r (SOimm Int.one) (SOimm Int.zero) :: k)
  | _, _ =>
      Error(msg "Asmgen.transl_op")
  end.

(** Accessing data in the stack frame. *)

Definition indexed_memory_access
    (mk_instr: ireg -> int -> instruction)
    (mk_immed: int -> int)
    (base: ireg) (n: int) (k: code) :=
  let n1 := mk_immed n in
  if Int.eq n n1
  then mk_instr base n :: k
  else addimm IR14 base (Int.sub n n1) (mk_instr IR14 n1 :: k).

Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) :=
  indexed_memory_access (fun base n => Pldr dst base (SOimm n)) mk_immed_mem_word base ofs k.

Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
  match ty, preg_of dst with
  | Tint, IR r =>
      OK (indexed_memory_access (fun base n => Pldr r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tany32, IR r =>
      OK (indexed_memory_access (fun base n => Pldr_a r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tsingle, FR r =>
      OK (indexed_memory_access (Pflds r) mk_immed_mem_float base ofs k)
  | Tfloat, FR r =>
      OK (indexed_memory_access (Pfldd r) mk_immed_mem_float base ofs k)
  | Tany64, FR r =>
      OK (indexed_memory_access (Pfldd_a r) mk_immed_mem_float base ofs k)
  | _, _ =>
      Error (msg "Asmgen.loadind")
  end.

Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
  match ty, preg_of src with
  | Tint, IR r =>
      OK (indexed_memory_access (fun base n => Pstr r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tany32, IR r =>
      OK (indexed_memory_access (fun base n => Pstr_a r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tsingle, FR r =>
      OK (indexed_memory_access (Pfsts r) mk_immed_mem_float base ofs k)
  | Tfloat, FR r =>
      OK (indexed_memory_access (Pfstd r) mk_immed_mem_float base ofs k)
  | Tany64, FR r =>
      OK (indexed_memory_access (Pfstd_a r) mk_immed_mem_float base ofs k)
  | _, _ =>
      Error (msg "Asmgen.storeind")
  end.

(** Translation of memory accesses *)

Definition transl_memory_access
     (mk_instr_imm: ireg -> int -> instruction)
     (mk_instr_gen: option (ireg -> shift_op -> instruction))
     (mk_immed: int -> int)
     (addr: addressing) (args: list mreg) (k: code) :=
  match addr, args with
  | Aindexed n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (indexed_memory_access mk_instr_imm mk_immed r1 n k)
  | Aindexed2, a1 :: a2 :: nil =>
      match mk_instr_gen with
      | Some f =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          OK (f r1 (SOreg r2) :: k)
      | None =>
          Error (msg "Asmgen.Aindexed2")
      end
  | Aindexed2shift s, a1 :: a2 :: nil =>
      match mk_instr_gen with
      | Some f =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          OK (f r1 (transl_shift s r2) :: k)
      | None =>
          Error (msg "Asmgen.Aindexed2shift")
      end
  | Ainstack n, nil =>
      OK (indexed_memory_access mk_instr_imm mk_immed IR13 n k)
  | _, _ =>
      Error(msg "Asmgen.transl_memory_access")
  end.

Definition transl_memory_access_int
     (mk_instr: ireg -> ireg -> shift_op -> instruction)
     (mk_immed: int -> int)
     (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
  do rd <- ireg_of dst;
  transl_memory_access
    (fun r n => mk_instr rd r (SOimm n))
    (Some (mk_instr rd))
    mk_immed addr args k.

Definition transl_memory_access_float
     (mk_instr: freg -> ireg -> int -> instruction)
     (mk_immed: int -> int)
     (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
  do rd <- freg_of dst;
  transl_memory_access
    (mk_instr rd)
    None
    mk_immed addr args k.

Definition transl_load (chunk: memory_chunk) (addr: addressing)
                       (args: list mreg) (dst: mreg) (k: code) :=
  match chunk with
  | Mint8signed =>
      transl_memory_access_int Pldrsb mk_immed_mem_small dst addr args k
  | Mint8unsigned =>
      transl_memory_access_int Pldrb mk_immed_mem_word dst addr args k
  | Mint16signed =>
      transl_memory_access_int Pldrsh mk_immed_mem_small dst addr args k
  | Mint16unsigned =>
      transl_memory_access_int Pldrh mk_immed_mem_small dst addr args k
  | Mint32 =>
      transl_memory_access_int Pldr mk_immed_mem_word dst addr args k
  | Mfloat32 =>
      transl_memory_access_float Pflds mk_immed_mem_float dst addr args k
  | Mfloat64 =>
      transl_memory_access_float Pfldd mk_immed_mem_float dst addr args k
  | _ =>
      Error (msg "Asmgen.transl_load")
  end.

Definition transl_store (chunk: memory_chunk) (addr: addressing)
                       (args: list mreg) (src: mreg) (k: code) :=
  match chunk with
  | Mint8signed =>
      transl_memory_access_int Pstrb mk_immed_mem_small src addr args k
  | Mint8unsigned =>
      transl_memory_access_int Pstrb mk_immed_mem_word src addr args k
  | Mint16signed =>
      transl_memory_access_int Pstrh mk_immed_mem_small src addr args k
  | Mint16unsigned =>
      transl_memory_access_int Pstrh mk_immed_mem_small src addr args k
  | Mint32 =>
      transl_memory_access_int Pstr mk_immed_mem_word src addr args k
  | Mfloat32 =>
      transl_memory_access_float Pfsts mk_immed_mem_float src addr args k
  | Mfloat64 =>
      transl_memory_access_float Pfstd mk_immed_mem_float src addr args k
  | _ =>
      Error (msg "Asmgen.transl_store")
  end.

(** Translation of arguments to annotations *)

Definition transl_annot_param (p: Mach.annot_param) : Asm.annot_param :=
  match p with
  | Mach.APreg r => APreg (preg_of r)
  | Mach.APstack chunk ofs => APstack chunk ofs
  end.

(** Translation of a Mach instruction. *)

Definition transl_instr (f: Mach.function) (i: Mach.instruction)
                        (r12_is_parent: bool) (k: code) :=
  match i with
  | Mgetstack ofs ty dst =>
      loadind IR13 ofs ty dst k
  | Msetstack src ofs ty =>
      storeind src IR13 ofs ty k
  | Mgetparam ofs ty dst =>
      do c <- loadind IR12 ofs ty dst k;
      OK (if r12_is_parent
          then c
          else loadind_int IR13 f.(fn_link_ofs) IR12 c)
  | Mop op args res =>
      transl_op op args res k
  | Mload chunk addr args dst =>
      transl_load chunk addr args dst k
  | Mstore chunk addr args src =>
      transl_store chunk addr args src k
  | Mcall sig (inl arg) =>
      do r <- ireg_of arg; OK (Pblreg r sig :: k)
  | Mcall sig (inr symb) =>
      OK (Pblsymb symb sig :: k)
  | Mtailcall sig (inl arg) =>
      do r <- ireg_of arg;
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
           (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg r sig :: k))
  | Mtailcall sig (inr symb) =>
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
           (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb sig :: k))
  | Mbuiltin ef args res =>
      OK (Pbuiltin ef (map preg_of args) (map preg_of res) :: k)
  | Mannot ef args =>
      OK (Pannot ef (map transl_annot_param args) :: k)
  | Mlabel lbl =>
      OK (Plabel lbl :: k)
  | Mgoto lbl =>
      OK (Pb lbl :: k)
  | Mcond cond args lbl =>
      transl_cond cond args (Pbc (cond_for_cond cond) lbl :: k)
  | Mjumptable arg tbl =>
      do r <- ireg_of arg;
      OK (Pbtbl r tbl :: k)
  | Mreturn =>
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
            (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
             Pbreg IR14 f.(Mach.fn_sig) :: k))
  end.

(** Translation of a code sequence *)

Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool :=
  match i with
  | Msetstack src ofs ty => before
  | Mgetparam ofs ty dst => negb (mreg_eq dst R12)
  | Mop Omove args res => before && negb (mreg_eq res R12)
  | _ => false
  end.

(** This is the naive definition that we no longer use because it
  is not tail-recursive.  It is kept as specification. *)

Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  match il with
  | nil => OK nil
  | i1 :: il' =>
      do k <- transl_code f il' (it1_is_parent it1p i1);
      transl_instr f i1 it1p k
  end.

(** This is an equivalent definition in continuation-passing style
  that runs in constant stack space. *)

Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction)
                         (it1p: bool) (k: code -> res code) :=
  match il with
  | nil => k nil
  | i1 :: il' =>
      transl_code_rec f il' (it1_is_parent it1p i1)
        (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2)
  end.

Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  transl_code_rec f il it1p (fun c => OK c).

(** Translation of a whole function.  Note that we must check
  that the generated code contains less than [2^32] instructions,
  otherwise the offset part of the [PC] code pointer could wrap
  around, leading to incorrect executions. *)

Definition transl_function (f: Mach.function) :=
  do c <- transl_code f f.(Mach.fn_code) true;
  OK (mkfunction f.(Mach.fn_sig)
        (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
         Pstr IR14 IR13 (SOimm f.(fn_retaddr_ofs)) :: c)).

Definition transf_function (f: Mach.function) : res Asm.function :=
  do tf <- transl_function f;
  if zlt Int.max_unsigned (list_length_z tf.(fn_code))
  then Error (msg "code size exceeded")
  else OK tf.

Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
  transf_partial_fundef transf_function f.

Definition transf_program (p: Mach.program) : res Asm.program :=
  transform_partial_program transf_fundef p.


Require Import List Map Envs AllInRel Exp AppExpFree RenamedApart.
Require Import IL Annotation AnnotationLattice.
Require Import AutoIndTac Liveness.Liveness LabelsDefined.
Require Import DoSpill DoSpillRm.
Require Import SpillSound SpillUtil ReconstrLive ReconstrLiveSmall.
Require Import InVD Slot.
Require Import SlotLiftArgs SlotLiftParams.
Require Import PartialOrder AnnotationLattice.

Set Implicit Arguments.

(** * ReconstrLiveSound *)

Lemma sla_extargs_slp_length
      (slot : var -> var)
      RM RMapp
      (ZL : list params)
      (Z : params)
      (l : lab)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (Y : args)
  : length Y = length Z ->
    ❬slot_lift_args slot RM RMapp Y Z❭ = ❬slot_lift_params slot RM Z❭.
Proof.
  intros Len.
  general induction Len; simpl; eauto.
  repeat cases; simpl; eauto.
Qed.

Lemma reconstr_live_sound_s
      (slot : var -> var) o
      (ZL' ZL : list params)
      (G : ⦃var⦄)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (Lv : list ⦃var⦄)
      (s : stmt)
      (sl : spilling)
  :
    (forall G',
        live_sound o ZL' Lv
                   (do_spill slot s (clear_SpL sl) ZL Λ)
                   (reconstr_live (slot_merge slot ⊝ Λ) ZL' G'
                                  (do_spill slot s (clear_SpL sl) ZL Λ)
                                  (do_spill_rm slot (clear_SpL sl))))
   -> live_sound o ZL' Lv
                (do_spill slot s sl ZL Λ)
                (reconstr_live (slot_merge slot ⊝ Λ) ZL' G
                               (do_spill slot s sl ZL Λ)
                               (do_spill_rm slot sl)).
Proof.
  intros sls.

  rewrite do_spill_extract_writes.
  rewrite do_spill_rm_s.

  unfold count.

  (* prepare induction *)
  remember (elements (getSp sl)) as elSp.
  symmetry in HeqelSp.
  remember (elements (getL  sl)) as elL.
  symmetry in HeqelL.
  do 2 rewrite <- elements_length.
  rewrite HeqelL.
  rewrite HeqelSp.
  clear HeqelSp.
  revert G.
  induction elSp;
    intros G;
    simpl.
  - (*apply elements_nil_eset in HeqelSp as empty_Sp.*)
    revert G.
    clear HeqelL.
    induction elL;
      intros G;
      simpl in *.
    + apply sls.

    + rewrite add_anns_S.

      constructor; eauto; fold reconstr_live.
      * simpl.
        apply live_exp_sound_incl with (lv':=singleton (slot a)).
        -- econstructor.
           econstructor.
           cset_tac.
        -- clear.
           cset_tac.
      * clear.
        cset_tac.
      * apply reconstr_live_G.
        cset_tac.
  - rewrite add_anns_S.
    econstructor; simpl; eauto.
    * simpl.
      apply live_exp_sound_incl with (lv':=singleton a).
      -- econstructor.
         econstructor.
         cset_tac.
      -- clear.
         cset_tac.
    * clear.
      cset_tac.
    * apply reconstr_live_G.
      cset_tac.
Qed.

Lemma reconstr_live_sound
      (k : nat) VD
      (slot : Slot VD)
      (ZL : list params)
      (G : ⦃var⦄)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (R M : ⦃var⦄)
      (s : stmt)
      (Lv : list ⦃var⦄)
      (sl : spilling)
      (alv : ann ⦃var⦄)
      (ra : ann (⦃var⦄ * ⦃var⦄))
  : R ⊆ VD
    -> M ⊆ VD
    -> fst (getAnn ra) ∪ snd (getAnn ra) ⊆ VD
    -> app_expfree s
    -> renamedApart s ra
    -> spill_sound k ZL Λ (R,M) s sl
    -> spill_live VD sl alv
    -> PIR2 Equal (merge ⊝ Λ) Lv
    -> (forall (Z : params) n,
          get ZL n Z
          -> of_list Z ⊆ VD)
    -> live_sound Imperative ZL Lv s alv
    -> live_sound Imperative
                 ((slot_lift_params slot) ⊜ Λ ZL)
                 (slot_merge slot ⊝ Λ)
                 (do_spill slot s sl ZL Λ)
                 (reconstr_live (slot_merge slot ⊝ Λ)
                                ((slot_lift_params slot) ⊜ Λ ZL)
                                 G
                                 (do_spill slot s sl ZL Λ)
                                (do_spill_rm slot sl))
.
Proof.
  intros disj_VD R_VD M_VD aeFree renAp spillSnd spilli pir2_EQ Z_VD lvSnd.

  general induction lvSnd;
    invc aeFree;
    invc spillSnd;
    invc spilli;
    inv renAp;
    apply reconstr_live_sound_s;
    intros G'.

  - rename sl0 into sl.
    assert (x ∈ VD) as x_VD by (eapply x_VD; eauto).
    rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    econstructor; eauto.
    + eapply IHlvSnd with (ra:=an) (R:={x; (R\K ∪ L) \Kx}) (M:=Sp ∪ M); eauto.
      * eapply Rx_VD with (R:=R) (M:=M); eauto.
      * eapply M'_VD with (R:=R) (M:=M); eauto.
      * eapply renamedApart_incl in renAp as rena.
        rewrite rena. eauto.
    + apply live_exp_sound_incl with (lv':=Exp.freeVars e).
      * apply live_freeVars.
      * clear; cset_tac.
    + clear; cset_tac.
    + apply reconstr_live_G.
      eauto with cset.

  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    apply renamedApart_incl in renAp as [rena1 rena2].
    assert (R \ K ∪ L ⊆ VD) as R'_VD
        by (eapply R'_VD with (R:=R) (M:=M); eauto).
    assert (Sp ∪ M ⊆ VD) as M'_VD
        by (eapply M'_VD with (R:=R) (M:=M); eauto).
    econstructor.
    + eapply IHlvSnd1 with (ra:=ans) (R:=R\K ∪ L); eauto.
      rewrite rena1. eauto.
    + eapply IHlvSnd2 with (ra:=ant) (R:=R\K ∪ L); eauto.
      rewrite rena2; eauto.
    + apply live_op_sound_incl with (lv':=Ops.freeVars e).
      * apply Ops.live_freeVars.
      * clear; cset_tac.
    + clear; cset_tac.
    + clear; cset_tac.

  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.
    eapply get_get_eq in H; eauto.
    subst Z0.

    econstructor.
    + eapply zip_get; eauto.
    + simpl.
      unfold slot_merge.
      eapply map_get_eq; eauto.
    + simpl.
      assert (nth (labN l) (slot_merge slot ⊝ Λ) ∅ [=] R_f ∪ map slot M_f)
        as nth_EQ.
      {
        unfold slot_merge.
        assert ((fun RM => fst RM ∪ map slot (snd RM)) (R_f,M_f) = R_f ∪ map slot M_f)
          by (simpl; reflexivity).
        eapply map_get_eq in H13; eauto.
        erewrite get_nth; eauto.
        reflexivity.
      }
      rewrite nth_EQ.
      assert (of_list (nth (labN l) (slot_lift_params slot ⊜ Λ ZL) nil)
              [=] of_list (slot_lift_params slot (R_f,M_f) Z))
        as nth_slp by (erewrite nth_zip; eauto; simpl; reflexivity).
      rewrite nth_slp.
      clear; cset_tac.
    + erewrite !get_nth; try eassumption.
      apply sla_extargs_slp_length; eauto.
    + intros; inv_get.
      erewrite !nth_zip; eauto.
      erewrite !get_nth in H; eauto.
      erewrite !get_nth; eauto using map_get_1. simpl.
      eapply live_op_sound_incl. eapply Ops.live_freeVars.
      eapply get_list_union_map with (f:=Ops.freeVars) in H.
      rewrite <- H. cset_tac.
  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    econstructor; simpl; eauto.
    + apply live_op_sound_incl with (lv':=Ops.freeVars e).
      * apply Ops.live_freeVars.
      * clear; cset_tac.

  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    apply renamedApart_incl in renAp as [renaF rena2].
    rewrite fst_zip_pair by eauto with len.
    econstructor; simpl; eauto.
    + rewrite fst_zip_pair by eauto with len.
      rewrite slot_lift_params_app; eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|len_simpl; rewrite <- H13, <- H16; omega].
      rewrite slot_merge_app.
      apply live_sound_monotone with (LV:= slot_merge slot ⊝ (rms ++ Λ)).
      * eapply IHlvSnd with (ra:=ant) (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
        -- eapply R'_VD with (R:=R) (M:=M); eauto.
        -- eapply M'_VD with (R:=R) (M:=M); eauto.
        -- rewrite rena2; eauto.
        -- eapply getAnn_als_EQ_merge_rms; eauto.
        -- eapply get_ofl_VD; eauto.
      * rewrite <- slot_merge_app.
        apply PIR2_app with (L2:=slot_merge slot ⊝ Λ);
          swap 1 2.
        {
          apply PIR2_refl; eauto.
        }
        apply PIR2_get.
        -- intros n x x' H4 H5.
           inv_get; simpl.
           rename x into Zs.
           rename x0 into rm.
           rename x5 into sl_s.
           rename x1 into a.
           rename x2 into al.
           rename H33 into get_al.
           rename H32 into get_a.
           rename H26 into get_sls.
           rename H30 into get_Zs.
           rename H5 into get_rm.

           rewrite slot_merge_app.

           exploit H19 as H24'; eauto. (*H31*)
           exploit H23 as H20'; eauto. (*H32*)
           exploit renaF as renaF'; eauto.
           exploit H14 as H15'; eauto. (*H33*)
           exploit H2 as H2'; eauto.
           destruct H2' as [H2' _].
           destruct H15' as [A [B [C E]]].
           assert (rm = (fst rm, snd rm)) as rm_eta by apply pair_eta.
           rewrite rm_eta in H24'.
           rewrite <- reconstr_live_setTopAnn.
           erewrite reconstr_live_small with (VD:=VD)
                                             (ra:=a)
                                             (R:=fst rm)
                                             (M:=snd rm); eauto.
           ++ (*clear - pir2_EQ pir3 renaF H24 H20 H15 H2 H16 H20 H8 H13 H14 H H9 H18 ra_VD.*)
             clear - rm_eta H2' get_al get_a get_sls get_rm get_Zs H15.
             rewrite rm_eta in get_rm.
             eapply al_sub_RfMf in get_rm; eauto.
             rewrite rm_eta. unfold slot_merge; simpl.
              repeat apply union_incl_split;
                [clear; cset_tac | clear; cset_tac
                 | eapply ofl_slp_sub_rm; eauto ].
           ++ rewrite renaF'; eauto.
           ++ eapply getAnn_als_EQ_merge_rms; eauto.
           ++ eapply get_ofl_VD; eauto.

        -- eauto with len.
    + symmetry.
      apply zip_length2.
      repeat rewrite length_map.
      rewrite zip_length2;
        eauto with len.
    + intros; inv_get.
      simpl.
      rewrite fst_zip_pair by eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|unfold slot_merge; len_simpl; rewrite <- H13, <- H16; omega].
      rewrite slot_merge_app.
      rewrite slot_lift_params_app; eauto with len.
      rewrite <- reconstr_live_setTopAnn.
      apply live_sound_monotone with (LV:= slot_merge slot ⊝ (rms ++ Λ)).
      * assert ((fst x3, snd x3) = x3)
          by (destruct x3; simpl; reflexivity).
        rewrite <- H4 in H31.
        exploit H23; eauto.
        eapply H1 with (ra:=x0) (R:=fst x3) (M:=snd x3); eauto.
        -- exploit renaF as renaF'; eauto.
           rewrite renaF'; eauto.
        -- eapply getAnn_als_EQ_merge_rms; eauto.
        -- eapply get_ofl_VD; eauto.
      * rewrite <- slot_merge_app.
        apply PIR2_app with (L2:=slot_merge slot ⊝ Λ);
          swap 1 2.
        {
          apply PIR2_refl; eauto.
        }
        apply PIR2_get.
        -- intros.
           unfold slot_merge in H5.
           inv_get; simpl.
           rewrite slot_merge_app.
           exploit H19; eauto.
           exploit H23; eauto.
           exploit H9; eauto.
           destruct x5 as [R_f M_f].
           rewrite <- reconstr_live_setTopAnn.
           erewrite reconstr_live_small with (ra:=x6)
                                             (VD:=VD)
                                             (R:=R_f)
                                             (M:=M_f); eauto.
           ++ exploit H2 as H2'; eauto; dcr; simpl in *.

             rewrite ofl_slp_sub_rm; eauto.
             poLe_set. clear; cset_tac.
             eapply al_sub_RfMf; eauto.
           ++ rewrite renaF; eauto.
           ++ eapply getAnn_als_EQ_merge_rms; eauto.
           ++ eapply get_ofl_VD; eauto.
        -- unfold slot_merge. eauto with len.
    + intros.
      inv_get.
      simpl.
      split; [ | auto].
      * apply reconstr_live_G.
      * split; eauto.
        -- exploit H2; eauto; dcr.
           eapply PIR2_nth in H15; eauto; dcr.
           destruct x3. eapply NoDupA_slot_lift_params; eauto.
           unfold merge in H33.
           exploit H23; eauto; dcr. eauto with cset.
           rewrite <- M_VD. simpl.
           rewrite <- H27.
           rewrite <- incl_list_union; eauto using zip_get; [|reflexivity].
           unfold defVars. clear; cset_tac.
Qed.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef2.Layer.
Require Import TableDataOpsRef3.Code.data_create_unknown3.

Require Import TableDataOpsRef3.LowSpecs.data_create_unknown3.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _data_create ↦ gensem data_create_spec
      ⊕ _data_create_unknown2 ↦ gensem data_create_unknown2_spec
      ⊕ _data_create_unknown ↦ gensem data_create_unknown_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_data_create: block.
    Hypothesis h_data_create_s : Genv.find_symbol ge _data_create = Some b_data_create.
    Hypothesis h_data_create_p : Genv.find_funct_ptr ge b_data_create
                                 = Some (External (EF_external _data_create
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons Tptr Tnil))))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons Tptr Tnil))))) tulong cc_default).
    Local Opaque data_create_spec.

    Variable b_data_create_unknown2: block.
    Hypothesis h_data_create_unknown2_s : Genv.find_symbol ge _data_create_unknown2 = Some b_data_create_unknown2.
    Hypothesis h_data_create_unknown2_p : Genv.find_funct_ptr ge b_data_create_unknown2
                                          = Some (External (EF_external _data_create_unknown2
                                                           (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default))
                                                 (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default).
    Local Opaque data_create_unknown2_spec.

    Variable b_data_create_unknown: block.
    Hypothesis h_data_create_unknown_s : Genv.find_symbol ge _data_create_unknown = Some b_data_create_unknown.
    Hypothesis h_data_create_unknown_p : Genv.find_funct_ptr ge b_data_create_unknown
                                         = Some (External (EF_external _data_create_unknown
                                                          (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default))
                                                (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default).
    Local Opaque data_create_unknown_spec.

    Lemma data_create_unknown3_body_correct:
      forall m d d' env le g_rd_base g_rd_offset data_addr map_addr g_data_base g_data_offset res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTdata_addr: PTree.get _data_addr le = Some (Vlong data_addr))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTg_data: PTree.get _g_data le = Some (Vptr g_data_base (Int.repr g_data_offset)))
             (Hspec: data_create_unknown3_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned data_addr)) (VZ64 (Int64.unsigned map_addr)) (g_data_base, g_data_offset) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) data_create_unknown3_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec data_create_unknown3_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import ClassTestTypes.
Require Import NotVoidAssignability.

(* Simple function types *)
Definition dt_fun_void_void := dt_function dt_void (dts_cons dt_void dts_nil).
Definition dt_fun_void_dynamic := dt_function dt_dynamic (dts_cons dt_void dts_nil).
Definition dt_fun_dynamic_void := dt_function dt_void (dts_cons dt_dynamic dts_nil).
Definition dt_fun_dynamic_dynamic := dt_function dt_dynamic (dts_cons dt_dynamic dts_nil).
Definition dt_fun_Object_Object := dt_function dt_Object (dts_cons dt_Object dts_nil).
Definition dt_fun_Object_void := dt_function dt_void (dts_cons dt_Object dts_nil).
Definition dt_fun_void_Object := dt_function dt_Object (dts_cons dt_void dts_nil).

Hint Unfold
  dt_fun_void_void dt_fun_void_dynamic dt_fun_dynamic_void
  dt_fun_dynamic_dynamic dt_fun_Object_Object dt_fun_Object_void
  dt_fun_void_Object.

(* -------------------- Test cases from email -------------------- *)

(* A<Object> x = new A<void>(); // No *)
Goal NotVoidAssignable dt_A_void dt_A_Object.
  apply nva_class. unfold ct_A_void.
  apply nvact_upcast with (args1 := dts_cons dt_void dts_nil).
      apply dsscts_cons.
        apply dscts_first. apply dsct_args. apply dsp_cons.
          apply ds_Object.
        apply dsp_nil.
      apply dsscts_cons.
        apply dscts_rest. apply dscts_first. auto.
      apply dsscts_nil.
    apply ctn_first.
  apply nvap_cons_first. apply nva_base; discriminate.
Qed.

(* A<dynamic> x = new A<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_A_dynamic).
  unfold not. intros. inversion H. inversion H2.
    subst. unfold ct_A_void in *.
    assert (args1 = dts_cons dt_void dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1. contradiction H10. reflexivity.
    inversion H1.
  unfold ct_A_dynamic in *.
  assert (args2 = dts_cons dt_dynamic dts_nil).
    inversion H8.
      reflexivity.
    contradiction H15. reflexivity.
  subst args2. inversion H9.
    inversion H11. apply H16. reflexivity.
  inversion H11.
Qed.

(* A<Object> x = new A<dynamic>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_A_dynamic).
  unfold not. intros. inversion H. inversion H2; subst.
    unfold ct_A_void in *.
    assert (args1 = dts_cons dt_void dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1. apply H10. reflexivity.
    inversion H1.
  assert (args2 = dts_cons dt_dynamic dts_nil).
    inversion H8.
      reflexivity.
    contradiction H7. reflexivity.
  subst args2.
  inversion H9.
    inversion H1. apply H10. reflexivity.
  inversion H1.
Qed.

(* A<void> x = new A<dynamic>(); // voidV = dynamicV, yes *)
Goal ~(NotVoidAssignable dt_A_dynamic dt_A_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_A_dynamic in *.
    assert (args1 = dts_cons dt_dynamic dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1.
    inversion H1.
  assert (args2 = dts_cons dt_void dts_nil).
    inversion H8.
      reflexivity.
    contradiction H7. reflexivity.
  subst args2. inversion H9.
    inversion H1.
  inversion H1.
Qed.

(* A<void> x = new A<Object>(); // voidV = objectV, Yes *)
Goal ~(NotVoidAssignable dt_A_Object dt_A_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_A_Object in *.
    assert (args1 = dts_cons dt_Object dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1.
    inversion H1.
  assert (args2 = dts_cons dt_void dts_nil).
    inversion H8.
      reflexivity.
    contradiction H7. reflexivity.
  subst args2. inversion H9.
    inversion H1.
  inversion H1.
Qed.

(* dynamic x = new A<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_dynamic).
  unfold not. intros. inversion H.
Qed.

(* Object x = new A<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_Object).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_A_void in *.
    assert (args1 = dts_nil).
      inversion H9.
    subst args1. inversion H9.
  inversion H8. inversion H10.
Qed.

(* Iterable<void> x = new List<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_List_void dt_Iterable_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_List_void in *.
    assert (args1 = dts_cons dt_void dts_nil).
      inversion H8. inversion H10.
        reflexivity.
      inversion H17. inversion H24.
    subst args1. inversion H9.
      inversion H1. apply H6. reflexivity.
    inversion H1.
  inversion H8. inversion H10. inversion H17.
Qed.

(* List<void> x = new Iterable<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_Iterable_void dt_List_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_Iterable_void in *.
    inversion H8. inversion H10. inversion H17.
  assert (args2 = dts_cons dt_void dts_nil).
    inversion H8. inversion H10.
      reflexivity.
    contradiction H16. reflexivity.
  subst args2. inversion H9.
    inversion H1. apply H7. reflexivity.
  inversion H1.
Qed.

(* Iterable<Object> x = new List<void>(); // No *)
Goal NotVoidAssignable dt_List_void dt_Iterable_Object.
  apply nva_class. apply nvact_upcast with (args1 := dts_cons dt_void dts_nil).
      apply dsscts_cons.
        apply dscts_rest. apply dscts_first. apply dsct_args. apply dsp_cons.
          auto.
        auto.
      apply dsscts_cons.
        apply dscts_rest. apply dscts_rest. apply dscts_first. auto.
      auto.
    apply ctn_rest.
      discriminate.
    apply ctn_first.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* List<Object> x = new Iterable<void>(); // No *)
Goal NotVoidAssignable dt_Iterable_void dt_List_Object.
  apply nva_class. apply nvact_downcast with (args2 := dts_cons dt_Object dts_nil).
      apply dsscts_cons.
        apply dscts_rest. apply dscts_first. apply dsct_args. auto.
      apply dsscts_cons.
        apply dscts_rest. apply dscts_rest. apply dscts_first. apply dsct_args. auto.
      auto.
    apply ctn_rest.
      discriminate.
    apply ctn_first.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* void Function(void) f = func<dynamic, dynamic>; // Yes!! void-to-dynamic is OK! *)
Goal ~(NotVoidAssignable dt_fun_dynamic_dynamic dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5.
  inversion H5.
    inversion H7. intuition H12.
  inversion H7.
Qed.

(* void Function(void) f = func<dynamic, void>; // Yes!! void-to-dynamic is OK! *)
Goal ~(NotVoidAssignable dt_fun_dynamic_void dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5. intuition H0.
  inversion H5.
    inversion H7. intuition H12.
  inversion H7.
Qed.

(* void Function(void) f = func<void, dynamic>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_dynamic dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5.
  inversion H5.
    inversion H7. intuition H11.
  inversion H7.
Qed.

(* void Function(void) f = func<Object, Object>; // No *)
Goal NotVoidAssignable dt_fun_Object_Object dt_fun_void_void.
  apply nva_function_arg.
    unfold DartAssignable. left. apply ds_function.
      apply ds_void.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* void Function(void) f = func<Object, void>; // No *)
Goal NotVoidAssignable dt_fun_Object_void dt_fun_void_void.
  apply nva_function_arg.
    unfold DartAssignable. left. apply ds_function.
      apply ds_void.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* void Function(void) f = func<void, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_Object dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5.
  inversion H5.
    inversion H7. intuition H11.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<void, void>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_void dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. intuition H1.
    inversion H5. intuition H1.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<dynamic, void>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_dynamic_void dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. intuition H1.
    inversion H5. intuition H1.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<void, dynamic>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_dynamic dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<Object, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_Object_Object dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7. inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<Object, void>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_Object_void dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. intuition H8.
    inversion H5. intuition H8.
  inversion H3.
    inversion H5.
      inversion H8.
    inversion H8.
  inversion H5.
    inversion H8.
  inversion H8.
Qed.

(* dynamic Function(dynamic) g = func<void, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_Object dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* Object Function(Object) h = func<void, void>; // No *)
Goal NotVoidAssignable dt_fun_void_void dt_fun_Object_Object.
  apply nva_function_ret.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_void.
    auto.
  apply nva_base; discriminate.
Qed.

(* Object Function(Object) h = func<dynamic, void>; // No *)
Goal NotVoidAssignable dt_fun_dynamic_void dt_fun_Object_Object.
  apply nva_function_ret.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_dynamic.
    auto.
  apply nva_base; discriminate.
Qed.

(* Object Function(Object) h = func<void, dynamic>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_dynamic dt_fun_Object_Object).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* Object Function(Object) h = func<Object, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_Object_Object dt_fun_Object_Object).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. inversion H9.
        inversion H16.
      inversion H16.
    inversion H5. inversion H9.
      inversion H16.
    inversion H16.
  inversion H5. inversion H7.
    inversion H13.
      inversion H20.
    inversion H20.
  inversion H7.
Qed.

(* Object Function(Object) h = func<Object, void>; // No *)
Goal NotVoidAssignable dt_fun_Object_void dt_fun_Object_Object.
  apply nva_function_ret.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nva_base; discriminate.
Qed.

(* Object Function(Object) h = func<void, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_Object dt_fun_Object_Object).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. inversion H9.
        inversion H16.
      inversion H16.
    inversion H5. inversion H9.
      inversion H16.
    inversion H16.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

Goal NotVoidAssignable dt_fun_Object_Object dt_fun_void_Object. (* TODO: different from VoidnessType result *)
  apply nva_function_arg.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nvap_cons_first. apply nva_base; discriminate.
Qed.