Require Import Smallstep.
Require Import Machregs.
Require Import Asm.
Require Import Integers.
Require Import List.
Require Import ZArith.
Require Import Memtype.
Require Import Memory.
Require Import Archi.
Require Import Coqlib.
Require Import AST.
Require Import Globalenvs.
Require Import Events.
Require Import Values.
Require Import Conventions1.
Require Import SSAsm AsmFacts AsmRegs.

Section WFASM.

  Fixpoint in_builtin_arg (b: builtin_arg preg) (r: preg) :=
    match b with
    | BA x => if preg_eq r x then True else False
    | BA_splitlong ba1 ba2 => in_builtin_arg ba1 r \/ in_builtin_arg ba2 r
    | BA_addptr ba1 ba2 => in_builtin_arg ba1 r \/ in_builtin_arg ba2 r
    | _ => False
    end.

  Inductive is_alloc : instruction -> Prop :=
    is_alloc_intro sz ora olink:
      is_alloc (Pallocframe sz ora olink).

  Definition make_palloc f  : instruction :=
    let sz := fn_stacksize f in
    (Pallocframe sz (Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr))) (fn_ofs_link f)).

  Lemma make_palloc_is_alloc:
    forall f,
      is_alloc (make_palloc f).
  Proof. constructor. Qed.

  Inductive is_free : instruction -> Prop :=
    is_free_intro sz ora olink:
      is_free (Pfreeframe sz ora olink).

  Lemma is_free_dec:
    forall i,
      {is_free i} + {~ is_free i}.
  Proof.
    destruct i; try now (right; intro A; inv A).
    left. econstructor; eauto.
  Defined.
  Inductive is_jmp: instruction -> Prop :=
  | is_jmps_intro: forall i sg, is_jmp (Pjmp_s i sg)
  | is_jmpr_intro: forall ir sg, is_jmp (Pjmp_r ir sg).

  Inductive intermediate_instruction : instruction -> Prop :=
  | ii_alloc i: is_alloc i -> intermediate_instruction i
  | ii_jmp i: i = Pret \/ is_jmp i -> intermediate_instruction i.

  Record wf_asm_function (f: function): Prop :=
    {

      wf_asm_alloc_only_at_beginning:
        forall o sz ora olink,
          find_instr o (fn_code f) = Some (Pallocframe sz ora olink) ->
          o = 0;

      wf_asm_alloc_at_beginning:
        find_instr 0 (fn_code f) = Some (make_palloc f);

      wf_asm_after_freeframe:
        forall i o,
          find_instr (Ptrofs.unsigned o) (fn_code f) = Some i ->
          is_free i ->
          exists i' ,
            find_instr (Ptrofs.unsigned (Ptrofs.add o (Ptrofs.one))) (fn_code f) = Some i' /\
            (i' = Pret \/ is_jmp i' );

      wf_asm_ret_jmp_comes_after_freeframe:
        forall i o,
          find_instr (Ptrofs.unsigned o) (fn_code f) = Some i ->
          i = Pret \/ is_jmp i ->
          exists o' ifree,
            find_instr (Ptrofs.unsigned o') (fn_code f) = Some ifree /\
            is_free ifree /\
            Ptrofs.unsigned o' + 1 = Ptrofs.unsigned o;

      wf_asm_code_bounded:
        0 <= code_size (fn_code f) <= Ptrofs.max_unsigned;

      wf_asm_builtin_not_PC:
        forall o ef args res,
          find_instr o (fn_code f) = Some (Pbuiltin ef args res) ->
          ~ in_builtin_res res PC /\
          ~ in_builtin_res res RSP
          /\ Forall (fun arg : builtin_arg preg => ~ in_builtin_arg arg RA) args;

      wf_asm_jmp_no_rsp:
        forall o (r: ireg) sg,
          find_instr o (fn_code f) = Some (Pjmp_r r sg) ->
          r <> RSP;

      wf_asm_call_no_rsp:
        forall o (r: ireg) sg,
          find_instr o (fn_code f) = Some (Pcall_r r sg) ->
          r <> RSP;

      wf_asm_free_spec:
        forall o sz ora olink,
          find_instr o (fn_code f) = Some (Pfreeframe sz ora olink) ->
          sz = fn_stacksize f /\ ora = Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr));

      wf_allocframe_repr:
        forall o sz ora olink,
          find_instr o (fn_code f) = Some (Pallocframe sz ora olink) ->
          align sz 8 - size_chunk Mptr =
          Ptrofs.unsigned (Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr)));

      wf_freeframe_repr:
        forall o sz ora olink,
          find_instr o (fn_code f) = Some (Pfreeframe sz ora olink) ->
          Ptrofs.repr (align sz 8 - size_chunk Mptr) = Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr));
    }.

  Definition is_make_palloc a f :=  a = make_palloc f /\
                                    align (fn_stacksize f) 8 - size_chunk Mptr =
                                    Ptrofs.unsigned (Ptrofs.sub (Ptrofs.repr (align (fn_stacksize f) 8)) (Ptrofs.repr (size_chunk Mptr))).
(*
  Lemma pair_eq: forall {A B}
                   (Adec: forall (a b: A), {a = b} + {a <> b})
                   (Bdec: forall (a b: B), {a = b} + {a <> b}),
      forall (a b: A * B), {a = b} + {a <> b}.
  Proof.
    intros.
    destruct a, b.
    destruct (Adec a a0), (Bdec b b0); subst;
      first [ now (right; inversion 1; congruence)
            | left; reflexivity ].
  Defined.
*)
  Definition pallocframe_dec s s' o o' l l':
    {Pallocframe s o l= Pallocframe s' o' l'} + {Pallocframe s o l <> Pallocframe s' o' l'}.
  Proof.
    destruct (zeq s s'); subst. 2: (now right; inversion 1).
    destruct (Ptrofs.eq_dec o o'); subst. 2: (now right; inversion 1).
    destruct (Ptrofs.eq_dec l l'); subst. 2: (now right; inversion 1).
    left; reflexivity.
  Defined.

  Lemma and_dec: forall {A B: Prop},
      { A } + { ~ A } ->
      { B } + { ~ B } ->
      { A /\ B } + { ~ (A /\ B) }.
  Proof.
    intros. destruct H, H0; [left|right|right|right]; intuition.
  Qed.

  Definition is_make_palloc_dec a f : { is_make_palloc a f } + { ~ is_make_palloc a f }.
  Proof.
    unfold is_make_palloc, make_palloc.
    destruct a; try (now right; inversion 1).
    apply and_dec.
    apply pallocframe_dec.
    apply zeq.
  Defined.

  Definition check_ret_or_jmp roj :=
    match roj with
    | Pret |Pjmp_r _ _ | Pjmp_s _ _=> true
    | _ => false
    end.

  Definition valid_ret_or_jmp roj :=
    match roj with
    | Pjmp_r r _ =>  negb (preg_eq r RSP)
    | _ => true
    end.

  Definition check_free f sz ora :=
      sz = fn_stacksize f /\ ora = Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr)) /\
      Ptrofs.repr (align sz 8 - size_chunk Mptr) = Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr)).

  Definition check_free_dec f sz ora : { check_free f sz ora } + { ~ check_free f sz ora }.
  Proof.
    unfold check_free.
    apply and_dec. 2: apply and_dec.
    apply zeq. apply Ptrofs.eq_dec. apply Ptrofs.eq_dec.
  Defined.

  Definition check_builtin args res :=
    ~ in_builtin_res res PC /\
    ~ in_builtin_res res RSP
    /\ Forall (fun arg : builtin_arg preg => ~ in_builtin_arg arg RA) args.

  Lemma not_in_builtin_res_dec res r:
    {~ in_builtin_res res r} + {~ ~ in_builtin_res res r}.
  Proof.
    induction res; simpl.
    destruct (preg_eq x r); subst; intuition. left; inversion 1.
    destruct IHres1, IHres2; try (right; now intuition). left. intuition congruence.
  Qed.

  Lemma not_in_builtin_arg_dec arg r:
    {~ in_builtin_arg arg r} + {~ ~ in_builtin_arg arg r}.
  Proof.
    induction arg; simpl; try (try destr; left; now inversion 1).
    destruct IHarg1, IHarg2; try (right; now intuition). left. intuition congruence.
    destruct IHarg1, IHarg2; try (right; now intuition). left. intuition congruence.
  Qed.

  Definition check_builtin_dec args res: {check_builtin args res} + { ~ check_builtin args res}.
  Proof.
    unfold check_builtin.
    repeat apply and_dec.
    apply not_in_builtin_res_dec.
    apply not_in_builtin_res_dec.
    apply Forall_dec. intros.
    apply not_in_builtin_arg_dec.
  Defined.

  Lemma find_instr_bound:
    forall c o i,
      find_instr o c = Some i ->
      o + (instr_size i) <= code_size c.
  Proof.
    induction c; simpl; intros; eauto. congruence.
    destr_in H. inv H. generalize (code_size_non_neg c). lia.
    apply IHc in H. unfold instr_size in *. lia.
  Qed.

  Lemma find_instr_pos_positive:
        forall c o i,
          find_instr o c = Some i ->
          0 <= o.
   Proof.
     induction c; intros; simpl; inv H. destr_in H1. lia.
     eapply IHc in H1. lia.
   Qed.
  Lemma code_bounded_repr':
    forall c
      (RNG: 0 <= code_size c <= Ptrofs.max_unsigned)
      i o
      (FI: find_instr o c = Some i)
      sz
      (LE: 0 <= sz <= instr_size i),
      Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr o) (Ptrofs.repr sz)) = o + sz.
  Proof.
    intros.
    unfold Ptrofs.add.
    rewrite (Ptrofs.unsigned_repr sz). 2:generalize (instr_size_repr i); lia.
    generalize (find_instr_bound _ _ _ FI) (find_instr_pos_positive _ _ _ FI). intros.
    rewrite (Ptrofs.unsigned_repr o) by lia.
    apply Ptrofs.unsigned_repr; lia.
  Qed.

  Lemma code_bounded_repr:
    forall c
      (RNG: 0 <= code_size c <= Ptrofs.max_unsigned)
      i o
      (FI: find_instr (Ptrofs.unsigned o) c = Some i)
      sz
      (LE: 0 <= sz <= instr_size i),
      Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr sz)) = Ptrofs.unsigned o + sz.
  Proof.
    intros.
    erewrite <- code_bounded_repr'; eauto.
    unfold Ptrofs.add.
    rewrite Ptrofs.repr_unsigned. reflexivity.
  Qed.

  Lemma wf_asm_pc_repr' : forall f : function,
       wf_asm_function f ->
       forall (i : instruction) (o : ptrofs),
       find_instr (Ptrofs.unsigned o) (fn_code f) = Some i ->
       forall sz : Z, 0 <= sz <= instr_size i ->
       Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr sz)) = Ptrofs.unsigned o + sz.
  Proof.
    intros; eapply code_bounded_repr; eauto.
    apply wf_asm_code_bounded; eauto.
  Qed.

  Fixpoint check_asm_body (f: function) (next_roj: bool) (r: code) : bool :=
    match r with
    | nil => negb next_roj
    | i :: r =>
      let roj := proj_sumbool (is_free_dec i) in
      check_asm_body f roj r &&
      if next_roj then check_ret_or_jmp i && valid_ret_or_jmp i
      else
        negb (check_ret_or_jmp i) &&
        match i with
        | Pfreeframe sz ora olink =>     (* after a free, ret or jmp *)
          check_free_dec f sz ora
        | Pallocframe _ _ _ => false (* no alloc in body *)
        | Pcall_r r sg => negb (preg_eq r RSP)
        | Pbuiltin _ args res => check_builtin_dec args res
        | _ => true
      end
    end.

  Definition wf_asm_function_check (f: function) : bool :=
    match fn_code f with
    | nil => false
    | a::r => is_make_palloc_dec a f && check_asm_body f false r
    end && zle (code_size (fn_code f)) Ptrofs.max_unsigned.

  Lemma check_asm_body_no_alloc:
    forall f c b i,
      check_asm_body f b c = true ->
      In i c ->
      ~ is_alloc i.
  Proof.
    induction c; simpl; intros. easy.
    intro IA. inv IA.
    assert (exists b, check_asm_body f b c = true).
    {
      eexists. refine (proj1 _); apply andb_true_iff; eauto.
    }
    destruct H1.
    destruct H0. subst. simpl in *.
    apply andb_true_iff in H. destruct H. destr_in H0.
    eapply IHc in H0; eauto. apply H0; constructor.
  Qed.

  Lemma find_instr_app:
    forall a o b,
      0 <= o ->
      find_instr (o + code_size a) (a ++ b) = find_instr o b.
  Proof.
    induction a; simpl; intros; eauto.
    f_equal. lia.
    rewrite pred_dec_false.
    rewrite <- (IHa o b). f_equal. unfold instr_size. lia. lia.
    generalize (code_size_non_neg a0). unfold instr_size. lia.
  Qed.

  Lemma find_instr_app':
    forall a o b,
      code_size a <= o ->
      find_instr o (a ++ b) = find_instr (o - code_size a) b.
  Proof.
    intros.
    rewrite <- (find_instr_app a _ b). f_equal. lia. lia.
  Qed.

  Lemma find_instr_split:
    forall c o i,
      find_instr o c = Some i ->
      exists a b, c = a ++ i :: b /\ o = code_size a.
  Proof.
    induction c; simpl; intros; eauto. congruence.
    destr_in H. inv H. eexists nil, c; simpl. split; auto.
    edestruct IHc as (aa & b & EQ & SZ). apply H. subst.
    exists (a::aa), b; simpl; split; auto. unfold instr_size. lia.
  Qed.

  Lemma find_instr_app_pres: forall f1 f2 ofs i,
      find_instr ofs f1 = Some i ->
      find_instr ofs (f1 ++ f2) = Some i.
  Proof.
    induction f1 as [|i1 f1].
    - cbn. intros; congruence.
    - cbn. intros f2 i FI.
      destr. eauto.
  Qed.

  Lemma code_size_app:
    forall c1 c2,
      code_size (c1 ++ c2) = code_size c1 + code_size c2.
  Proof.
    induction c1; simpl; intros; eauto. rewrite IHc1. lia.
  Qed.

  Lemma check_asm_body_after_free:
    forall f a i b roj,
      check_asm_body f roj (a ++ i :: b) = true ->
      is_free i ->
      check_asm_body f true b = true.
  Proof.
    induction a; simpl; intros; eauto.
    apply andb_true_iff in H. destruct H as (H & _).
    inv H0. simpl in *. auto.
    apply andb_true_iff in H. destruct H as (H & B).
    destruct (is_free_dec a); simpl in *. inv i0.
    eapply IHa; eauto.
    eapply IHa; eauto.
  Qed.

  Lemma check_asm_body_call:
    forall f c b r sg,
      check_asm_body f b c = true ->
      In (Pcall_r r sg) c ->
      r <> RSP.
  Proof.
    induction c; simpl; intros. easy.
    assert (exists b, check_asm_body f b c = true).
    {
      eexists. refine (proj1 _); apply andb_true_iff; eauto.
    }
    apply andb_true_iff in H. destruct H. destruct H1. destruct H0; eauto. subst. simpl in *.
    destr_in H2; simpl in *.
    unfold proj_sumbool in H2; destr_in H2. simpl in H2. congruence.
  Qed.

  Lemma check_asm_body_free:
    forall f c b sz ora olink,
      check_asm_body f b c = true ->
      In (Pfreeframe sz ora olink) c ->
      check_free f sz ora.
  Proof.
    induction c; simpl; intros. easy.
    assert (exists b, check_asm_body f b c = true).
    {
      eexists. refine (proj1 _); apply andb_true_iff; eauto.
    }
    apply andb_true_iff in H. destruct H. destruct H1. destruct H0; eauto. subst. simpl in *.
    destr_in H2; simpl in *.
    unfold proj_sumbool in H2; destr_in H2.
  Qed.

  Lemma check_asm_body_before_roj:
    forall f a i b roj,
      check_asm_body f roj (a ++ i :: b) = true ->
      i = Pret \/ is_jmp i ->
      (a = nil /\ roj = true) \/ exists a0 i0, a = a0 ++ i0 :: nil /\ is_free i0.
  Proof.
    induction a; simpl; intros; eauto.
    - apply andb_true_iff in H. destruct H as (A & B).
      destruct H0 as [ROJ|ROJ]; inv ROJ; simpl in *. destr_in B.
      destruct roj. auto. congruence. destr_in B.
    - apply andb_true_iff in H. destruct H as (A & B).
      destruct (is_free_dec a); simpl in *. inv i0.
      + simpl in *. destr_in B. right.
        destruct a0. clear IHa. simpl in *.
        eexists nil, _. split. simpl. eauto. constructor.
        edestruct IHa as [ROJ|(a1 & i1 & EQ & IFR)]; eauto.
        destruct ROJ; congruence. rewrite EQ.
        eexists (_ :: a1), i1; split. simpl. reflexivity. auto.
      + edestruct IHa as [ROJ|(a1 & i1 & EQ & IFR)]; eauto.
        destruct ROJ; congruence. subst. right.
        eexists (_ :: a1), i1; split. simpl. reflexivity. auto.
  Qed.

  Lemma check_asm_body_builtin:
    forall f c b ef args res,
      check_asm_body f b c = true ->
      In (Pbuiltin ef args res) c ->
      check_builtin args res.
  Proof.
    induction c; simpl; intros. easy.
    assert (exists b, check_asm_body f b c = true).
    {
      eexists. refine (proj1 _); apply andb_true_iff; eauto.
    }
    destruct H1.
    destruct H0. subst. simpl in *.
    apply andb_true_iff in H. destruct H. destr_in H0.
    unfold proj_sumbool in H0; destr_in H0.
    eapply IHc in H0; eauto.
  Qed.

  Lemma check_asm_body_jmp:
    forall f c b r sg,
      check_asm_body f b c = true ->
      In (Pjmp_r  r sg) c ->
      r <> RSP.
  Proof.
    induction c; simpl; intros. easy.
    assert (exists b, check_asm_body f b c = true).
    {
      eexists. refine (proj1 _); apply andb_true_iff; eauto.
    }
    apply andb_true_iff in H. destruct H. destruct H1. destruct H0; eauto. subst. simpl in *.
    destr_in H2; simpl in *.
    unfold proj_sumbool in H2; destr_in H2. simpl in H2. congruence.
  Qed.

  Lemma wf_asm_function_check_correct f:
    wf_asm_function_check f = true ->
    wf_asm_function f.
  Proof.
    unfold wf_asm_function_check. destr. simpl. congruence.
    rewrite ! andb_true_iff. intros ((A & B) & C).
    unfold proj_sumbool in A, C. destr_in A; destr_in C.
    clear A C. rename Heqc into CODE. rename l into SIZE.
    constructor.
    - rewrite CODE. simpl. intros. destr_in H.
      apply Asmgenproof0.find_instr_in in H.
      eapply check_asm_body_no_alloc in H; eauto. contradict H. constructor.
    - rewrite CODE; simpl. clear - i0. destruct i0 as (A & B). subst. reflexivity.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros. destr_in H. inv H. inv H0.
      simpl in SIZE.
      rewrite pred_dec_false. unfold Ptrofs.one.
      replace (Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr 1)) - 1)
        with (Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr (Ptrofs.unsigned o - 1)) (Ptrofs.repr 1))).
      revert H.
      generalize (Ptrofs.unsigned o - 1).
      intros.
      edestruct find_instr_split as (a & b & EQ & SZ). apply H. subst.
      rewrite find_instr_app'.
      simpl. rewrite pred_dec_false.
      eapply check_asm_body_after_free in B; eauto.
      destruct b; simpl in B. congruence. simpl. rewrite pred_dec_true. eexists; split; eauto.
      apply andb_true_iff in B. destruct B as (B & CHK).
      unfold check_ret_or_jmp in CHK. apply andb_true_iff in CHK. destruct CHK as (CHK & _). destr_in CHK; try (right; constructor).
      unfold Ptrofs.add.
      rewrite (Ptrofs.unsigned_repr (code_size a) ).
      setoid_rewrite (Ptrofs.unsigned_repr 1).
      rewrite Ptrofs.unsigned_repr. lia.
      simpl in SIZE. rewrite code_size_app in SIZE. simpl in SIZE.
      generalize (code_size_non_neg a) (instr_size_positive i) (instr_size_positive i0) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      vm_compute. split; congruence.
      simpl in SIZE. rewrite code_size_app in SIZE. simpl in SIZE.
      generalize (code_size_non_neg a) (instr_size_positive i) (instr_size_positive i0) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      unfold Ptrofs.add.
      rewrite (Ptrofs.unsigned_repr (code_size a)).
      rewrite (Ptrofs.unsigned_repr 1).
      rewrite Ptrofs.unsigned_repr. generalize (instr_size_positive i); lia.
      simpl in SIZE. rewrite code_size_app in SIZE. simpl in SIZE.
      generalize (code_size_non_neg a) (instr_size_positive i) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      vm_compute. split; congruence.
      simpl in SIZE. rewrite code_size_app in SIZE. simpl in SIZE.
      generalize (code_size_non_neg a) (instr_size_positive i) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). simpl in SIZE. lia.
      unfold Ptrofs.add.
      rewrite (Ptrofs.unsigned_repr (code_size a)).
      rewrite (Ptrofs.unsigned_repr 1).
      rewrite Ptrofs.unsigned_repr. generalize (instr_size_positive i); lia.
      simpl in SIZE. rewrite code_size_app in SIZE. simpl in SIZE.
      generalize (code_size_non_neg a) (instr_size_positive i) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      vm_compute. split; congruence.
      simpl in SIZE. rewrite code_size_app in SIZE. simpl in SIZE.
      generalize (code_size_non_neg a) (instr_size_positive i) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      unfold Ptrofs.add.
      rewrite (Ptrofs.unsigned_repr 1).
      rewrite (Ptrofs.unsigned_repr (Ptrofs.unsigned o - _)).
      rewrite ! Ptrofs.unsigned_repr. lia.
      generalize (find_instr_bound _ _ _ H) (find_instr_pos_positive _ _ _ H).
      generalize (instr_size_positive i)
                 (instr_size_positive (make_palloc f)). lia.
      generalize (find_instr_bound _ _ _ H) (find_instr_pos_positive _ _ _ H).
      generalize (instr_size_positive i)
                 (instr_size_positive (make_palloc f)). lia.
      generalize (find_instr_bound _ _ _ H) (find_instr_pos_positive _ _ _ H).
      generalize (instr_size_positive i)
                 (instr_size_positive (make_palloc f)). lia.
      vm_compute. split; congruence.
      unfold Ptrofs.add. unfold Ptrofs.one.
      rewrite (Ptrofs.unsigned_repr 1).
      rewrite Ptrofs.unsigned_repr.
      generalize (Ptrofs.unsigned_range o) (instr_size_positive i); lia.
      generalize (find_instr_bound _ _ _ H) (find_instr_pos_positive _ _ _ H).
      generalize (instr_size_positive i)
                 (instr_size_positive (make_palloc f)). lia.
      vm_compute. split; congruence.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros i o FI ROJ.
      destr_in FI. inv FI. destruct ROJ as [ROJ|ROJ]; inv ROJ.
      edestruct find_instr_split as (a & b & EQ & SZ). apply FI. subst.
      destruct (check_asm_body_before_roj _ _ _ _ _ B ROJ) as [(NIL & ROJFALSE)|(a0 & i0 & EQ & IFR)]. congruence.
      subst.
      exists (Ptrofs.sub o (Ptrofs.repr (instr_size i0))), i0.
      rewrite pred_dec_false.
      replace (Ptrofs.unsigned (Ptrofs.sub o (Ptrofs.repr (instr_size i0))) - 1)
        with (0 + code_size a0). rewrite app_ass.
      rewrite find_instr_app. simpl. split; auto. split. auto.
      unfold Ptrofs.sub.
      rewrite (Ptrofs.unsigned_repr _ (instr_size_repr i0)).
      rewrite Ptrofs.unsigned_repr. unfold instr_size. lia.
      generalize (find_instr_bound _ _ _ FI) (find_instr_pos_positive _ _ _ FI). intros.
      simpl in *. rewrite ! code_size_app in *. simpl in *.
      generalize (code_size_non_neg a0) (instr_size_positive i) (instr_size_positive i0) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      lia.
      unfold Ptrofs.sub.
      rewrite (Ptrofs.unsigned_repr _ (instr_size_repr i0)).
      rewrite Ptrofs.unsigned_repr.
      simpl in *. rewrite ! code_size_app in *. simpl in *. lia.
      generalize (find_instr_bound _ _ _ FI) (find_instr_pos_positive _ _ _ FI). intros.
      simpl in *. rewrite ! code_size_app in *. simpl in *.
      generalize (code_size_non_neg a0) (instr_size_positive i) (instr_size_positive i0) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      unfold Ptrofs.sub.
      rewrite (Ptrofs.unsigned_repr _ (instr_size_repr i0)).
      rewrite Ptrofs.unsigned_repr.
      simpl in *. rewrite ! code_size_app in *. simpl in *.
      generalize (find_instr_bound _ _ _ FI) (find_instr_pos_positive _ _ _ FI). intros.
      simpl in *. rewrite ! code_size_app in *. simpl in *.
      generalize (code_size_non_neg a0) (instr_size_positive i) (instr_size_positive i0) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
      generalize (find_instr_bound _ _ _ FI) (find_instr_pos_positive _ _ _ FI). intros.
      simpl in *. rewrite ! code_size_app in *. simpl in *.
      generalize (code_size_non_neg a0) (instr_size_positive i) (instr_size_positive i0) (code_size_non_neg b)
                 (instr_size_positive (make_palloc f)). lia.
    - rewrite CODE; split; auto.
      generalize (code_size_non_neg (i::c)). lia.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros o ef args res FI.
      destr_in FI. inv FI.
      apply Asmgenproof0.find_instr_in in FI.
      eapply check_asm_body_builtin in FI; eauto.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros o r sg FI.
      destr_in FI. inv FI.
      apply Asmgenproof0.find_instr_in in FI.
      eapply check_asm_body_jmp in FI; eauto.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros o r sg FI.
      destr_in FI. inv FI.
      apply Asmgenproof0.find_instr_in in FI.
      eapply check_asm_body_call in FI; eauto.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros o sz ora olink FI.
      destr_in FI. inv FI.
      apply Asmgenproof0.find_instr_in in FI.
      edestruct check_asm_body_free as (A & BB & C); subst; eauto.
    - destruct i0 as (i0 & PA). subst. rewrite CODE. simpl.
      intros o sz pubrange ora FI.
      destr_in FI. inv FI; auto.
      apply Asmgenproof0.find_instr_in in FI.
      eapply check_asm_body_no_alloc in FI; eauto. contradict FI; constructor.
    - destruct i0 as (i0 & _). subst. rewrite CODE. simpl.
      intros o sz ora olink FI.
      destr_in FI. inv FI.
      apply Asmgenproof0.find_instr_in in FI.
      edestruct check_asm_body_free as (A & BB & C); subst; eauto.
  Qed.

  Lemma wf_asm_pc_repr:
    forall f (WF: wf_asm_function f) i o,
      find_instr (Ptrofs.unsigned o) (fn_code f) = Some i ->
      Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr (instr_size i))) = Ptrofs.unsigned o + instr_size i.
  Proof.
    intros; eapply wf_asm_pc_repr'; eauto. generalize (instr_size_positive i); lia.
  Qed.

  Lemma wf_asm_wf_allocframe:
    forall f (WF: wf_asm_function f) o sz ora olink
      (FI: find_instr o (fn_code f) = Some (Pallocframe sz ora olink)),
      make_palloc f = Pallocframe sz ora olink.
  Proof.
    intros.
    exploit wf_asm_alloc_only_at_beginning; eauto. intro; subst.
    erewrite wf_asm_alloc_at_beginning in FI; eauto. inv FI; auto.
  Qed.

End WFASM.

Section WITHGE.
  Variable ge : Genv.t Asm.fundef unit.

  Definition exec_instr f i rs (m: mem) :=
    match i with
    | Pallocframe sz ofs_ra ofs_link =>
      let aligned_sz := align sz 8 in
      let psp := (Val.offset_ptr (rs#RSP) (Ptrofs.repr (size_chunk Mptr))) in (* parent stack pointer *)
      let sp := Val.offset_ptr (rs#RSP) (Ptrofs.neg (Ptrofs.sub (Ptrofs.repr aligned_sz) (Ptrofs.repr (size_chunk Mptr)))) in
      match Mem.storev Mptr m (Val.offset_ptr sp ofs_link) psp with
        |None => Stuck
        |Some m1 =>
      Next (nextinstr (rs #RAX <- (Val.offset_ptr (rs RSP) (Ptrofs.repr (size_chunk Mptr))) #RSP <- sp)) m1
      end
    | Pfreeframe sz ofs_ra ofs_link =>
      let sp := Val.offset_ptr (rs RSP) (Ptrofs.sub (Ptrofs.repr (align sz 8)) (Ptrofs.repr (size_chunk Mptr))) in
      Next (nextinstr (rs#RSP <- sp)) m
    | Pcall_s i sg =>
      let sp := Val.offset_ptr (rs RSP) (Ptrofs.neg (Ptrofs.repr (size_chunk Mptr))) in
      match Mem.storev Mptr m sp (Val.offset_ptr rs#PC Ptrofs.one) with
        |None => Stuck
        |Some m1 =>
        Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one)
                #PC <- (Genv.symbol_address ge i Ptrofs.zero)
                #RSP <- sp) m1
      end
    |Pcall_r r sg =>
      let sp := Val.offset_ptr (rs RSP) (Ptrofs.neg (Ptrofs.repr (size_chunk Mptr))) in
      match Mem.storev Mptr m sp (Val.offset_ptr rs#PC Ptrofs.one) with
        |None => Stuck
        |Some m1 =>
        Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one)
                #PC <- (rs r)
                #RSP <- sp) m1
      end
    | Pret =>
      match loadvv Mptr m rs#RSP with
      | None => Stuck
      | Some ra =>
        let sp := Val.offset_ptr (rs RSP) (Ptrofs.repr (size_chunk Mptr)) in
        Next (rs #RSP <- sp
                 #PC <- ra
                 #RA <- Vundef) m
      end
    | _ => Asm.exec_instr ge f i rs m
    end.

  Inductive step  : state -> trace -> state -> Prop :=
  | exec_step_internal:
      forall b ofs f i rs m rs' m',
        rs PC = Vptr b ofs ->
        Genv.find_funct_ptr ge b = Some (Internal f) ->
        find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i ->
        exec_instr f i rs m = Next rs' m' ->
        step (State rs m) E0 (State rs' m')
  | exec_step_builtin:
      forall b ofs f ef args res rs m vargs t vres rs' m',
        rs PC = Vptr b ofs ->
        Genv.find_funct_ptr ge b = Some (Internal f) ->
        find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) ->
        eval_builtin_args ge rs (rs RSP) m args vargs ->
        external_call ef ge vargs m t vres m' ->
        rs' = nextinstr_nf
                (set_res res vres
                         (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) ->
        step (State rs m) t (State rs' m')
  | exec_step_external:
      forall b ef args res rs m t rs' m',
      rs PC = Vptr b Ptrofs.zero ->
      Genv.find_funct_ptr ge b = Some (External ef) ->
      extcall_arguments
        (rs # RSP <- (Val.offset_ptr (rs RSP) (Ptrofs.repr (size_chunk Mptr)))) m (ef_sig ef) args ->
        forall (SP_TYPE: Val.has_type (rs RSP) Tptr)
          ra (LOADRA: Mem.loadv Mptr m (rs RSP) = Some ra)
          (SP_NOT_VUNDEF: rs RSP <> Vundef)
          (RA_NOT_VUNDEF: ra <> Vundef),
      external_call ef ge args m t res m' ->
      rs' = (set_pair (loc_external_result (ef_sig ef))
                      res (undef_caller_save_regs rs))
              #PC <- ra
              #RA <- Vundef
              #RSP <- (Val.offset_ptr (rs RSP) (Ptrofs.repr (size_chunk Mptr)))
      ->
      step (State rs m) t (State rs' m').

End WITHGE.

Inductive initial_state (p: Asm.program): state -> Prop :=
  | initial_state_intro: forall m0 m1 m2 stk bmain,
      Genv.init_mem p = Some m0 ->
      Mem.alloc m0 0 (max_stacksize + (align (size_chunk Mptr)8)) = (m1, stk) ->
      Mem.storev Mptr m1 (Vptr stk (Ptrofs.repr (max_stacksize + align (size_chunk Mptr) 8 - size_chunk Mptr))) Vnullptr = Some m2 ->
      let ge := Genv.globalenv p in
      Genv.find_symbol ge p.(prog_main) = Some bmain ->
      let rs0 :=
        (Pregmap.init Vundef)
        # PC <- (Vptr bmain Ptrofs.zero)
        # RA <- Vnullptr
        # RSP <- (Val.offset_ptr
                   (Vptr stkblock ((Ptrofs.repr (max_stacksize + align (size_chunk Mptr) 8))))
                   (Ptrofs.neg (Ptrofs.repr (size_chunk Mptr)))) in
      initial_state p (State rs0 m2).

Definition semantics prog :=
  Semantics step (initial_state prog) final_state (Genv.globalenv prog).

Definition rs_state s :=
  let '(State rs _) := s in rs.
Definition m_state s :=
  let '(State _ m) := s in m.

  Section INVARIANT.

    Variable prog: Asm.program.
    Let ge := Genv.globalenv prog.

    Definition rsp_ptr (s: state) : Prop :=
      exists o, rs_state s RSP = Vptr stkblock  o /\ (align_chunk Mptr | Ptrofs.unsigned o).

    Definition bstack_perm (s: state) : Prop :=
      forall o k p,
        Mem.perm (m_state s) stkblock o k p ->
        Mem.perm (m_state s) stkblock o k Writable.

    Definition stack_top_state (s: state) : Prop :=
      exists tl st, Mem.stack(Mem.support (m_state s))= Node None (1%positive::nil) tl st.

    Definition fix_sid (s:state) : Prop :=
      Mem.sid (Mem.support (m_state s)) = Mem.tid.

    Inductive real_asm_inv : state -> Prop :=
    | real_asm_inv_intro:
        forall s
          (RSPPTR: rsp_ptr s)
          (BSTACKPERM: bstack_perm s)
          (STOP: stack_top_state s)
          (SID: fix_sid s),
          real_asm_inv s.

    Lemma storev_perm :
      forall m chunk addr v m', Mem.storev chunk m addr v = Some m' ->
                           (forall b o k p, Mem.perm m' b o k p <-> Mem.perm m b o k p).
      Proof.
        intros. unfold Mem.storev in H. destr_in H. split.
        eapply Mem.perm_store_2; eauto. eapply Mem.perm_store_1; eauto.
      Qed.

    Lemma real_initial_inv:
      forall is,
        initial_state prog is -> real_asm_inv is.
    Proof.
      intros. inv H.
      apply Genv.init_mem_stack in H0 as STK.
      apply Genv.init_mem_sid in H0 as SID.
      constructor.
      - red.
        simpl; unfold rs0; simpl_regs. eexists. split. reflexivity.
        apply div_ptr_add.
        apply div_unsigned_repr.
        apply Z.divide_add_r. apply align_Mptr_stack_limit. apply align_Mptr_align8.
        apply align_Mptr_modulus. unfold Ptrofs.neg. apply div_unsigned_repr.
        apply Zdivide_opp_r.
        apply div_unsigned_repr.
        apply align_size_chunk_divides.
        apply align_Mptr_modulus.
        apply align_Mptr_modulus.
        apply align_Mptr_modulus.
      - exploit Mem.alloc_result; eauto. intro. subst.
        unfold Mem.nextblock in H1. unfold Mem.fresh_block in H1.
        rewrite STK in H1. destr_in H1. simpl in Heqp. inv Heqp.
        red. unfold stkblock. intros o k p. rewrite SID in *.
        repeat erewrite (storev_perm _ _ _ _ _ H2). eauto.
        intro. exploit Mem.perm_alloc_3; eauto.
        intro. exploit Mem.perm_alloc_2; eauto. simpl. intro. eapply Mem.perm_implies; eauto.
        apply perm_F_any.
      - red. simpl. apply Mem.stack_alloc in H1. rewrite STK in H1.
        exists nil, None. simpl in H1. erewrite <- Mem.support_storev; eauto.
      - red. simpl. erewrite <- Mem.support_storev. 2: eauto. erewrite Mem.sid_alloc; eauto.
    Qed.

    Lemma exec_instr_invar_same:
      forall f i rs1 m1,
        stk_unrelated_instr i = true ->
        exec_instr ge f i rs1 m1 = SSAsm.exec_instr ge f i rs1 m1.
    Proof.
      intros f i rs1 m1 SI.
      destruct i; simpl in SI; simpl; congruence.
    Qed.
(*
    Inductive is_load_parent_pointer: instruction -> Prop :=
    | ilpp_intro i z: is_load_parent_pointer (Pload_parent_pointer i z).

    Lemma is_load_parent_pointer_dec i: { is_load_parent_pointer i } + { ~ is_load_parent_pointer i }.
    Proof.
      destruct i; first [ now (right; inversion 1) | left; econstructor ].
    Defined.
*)
    Lemma exec_instr_invar_same':
      forall f i rs1 m1,
        stk_unrelated_instr i = true ->
        Asm.exec_instr ge f i rs1 m1 = SSAsm.exec_instr ge f i rs1 m1.
    Proof.
      intros f i rs1 m1 SI.
      destruct i; simpl in SI; simpl; try congruence.
    Qed.

    Lemma exec_instr_invar_inv:
      forall f i rs1 m1 rs2 m2,
        asm_instr_unchange_rsp i ->
        stk_unrelated_instr i = true ->
        exec_instr ge f i rs1 m1 = Next rs2 m2 ->
        real_asm_inv (State rs1 m1) ->
        real_asm_inv (State rs2 m2).
    Proof.
      intros f i rs1 m1 rs2 m2 NORSP INVAR EI RAI; inv RAI.
      erewrite exec_instr_invar_same in EI; eauto.
      erewrite <- exec_instr_invar_same' in EI; eauto.
      exploit NORSP; eauto. intro EQ.
      generalize (asm_prog_unchange_sup i INVAR _ _ _ _ _ _ EI). intros (A & B).
      constructor.
      + red in RSPPTR; red. simpl in *; rewrite <- EQ. eauto.
      + red in BSTACKPERM; red. simpl in *. setoid_rewrite <- B. eauto.
      + red in STOP; red; simpl in *. rewrite <- A; eauto.
      + red in SID; red; simpl in *. rewrite <- A; eauto.
    Qed.

    Lemma align_Mptr_sub:
      forall o,
        (align_chunk Mptr | Ptrofs.unsigned o) ->
        (align_chunk Mptr | Ptrofs.unsigned (Ptrofs.add o (Ptrofs.neg (Ptrofs.repr (size_chunk Mptr))))).
    Proof.
      intros.
      apply div_ptr_add; auto.
      apply div_unsigned_repr.
      apply Z.divide_opp_r.
      apply div_unsigned_repr.
      apply align_size_chunk_divides.
      apply align_Mptr_modulus.
      apply align_Mptr_modulus.
      apply align_Mptr_modulus.
    Qed.

    Lemma align_Mptr_add:
      forall o,
        (align_chunk Mptr | Ptrofs.unsigned o) ->
        (align_chunk Mptr | Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr (size_chunk Mptr)))).
    Proof.
      intros.
      apply div_ptr_add; auto.
      apply div_unsigned_repr.
      apply align_size_chunk_divides.
      apply align_Mptr_modulus.
      apply align_Mptr_modulus.
    Qed.

    Lemma align_Mptr_add_gen:
      forall o d,
        (align_chunk Mptr | Ptrofs.unsigned o) ->
        (align_chunk Mptr | Ptrofs.unsigned d) ->
        (align_chunk Mptr | Ptrofs.unsigned (Ptrofs.add o d)).
    Proof.
      intros.
      apply div_ptr_add; auto.
      apply align_Mptr_modulus.
    Qed.

    Definition asm_prog_no_rsp (ge: Genv.t Asm.fundef unit):=
      forall b f,
        Genv.find_funct_ptr ge b = Some (Internal f) ->
        asm_code_no_rsp (fn_code f).

    Definition wf_asm_prog (ge: Genv.t Asm.fundef unit):=
      forall b f,
        Genv.find_funct_ptr ge b = Some (Internal f) ->
        wf_asm_function f.

    Lemma real_asm_inv_inv:
      forall (prog_no_rsp: asm_prog_no_rsp ge) (WF: wf_asm_prog ge) s1 t s2,
        step ge s1 t s2 ->
        real_asm_inv s1 ->
        real_asm_inv s2.
    Proof.
      intros prog_no_rsp WF s1 t s2 STEP INV; inv STEP.
      - destruct (stk_unrelated_instr i) eqn:INVAR.
        eapply exec_instr_invar_inv; eauto.
        eapply prog_no_rsp; eauto. eapply Asmgenproof0.find_instr_in; eauto.
        destruct i; simpl in INVAR; try congruence.
        + (* call_s *)
          simpl in H2. destr_in H2. inv H2. inv INV; constructor; simpl.
          * red. simpl. simpl_regs. destruct RSPPTR as (o & EQ & AL); simpl in *; rewrite EQ.
            simpl. eexists; split; eauto. apply align_Mptr_sub; auto.
          * red in BSTACKPERM; red; simpl in *.
            intros o k p. erewrite storev_perm; eauto. intro. erewrite storev_perm; eauto.
          * red in STOP; red; simpl in *. erewrite <- Mem.support_storev; eauto.
          * red in SID; red; simpl in *. erewrite <- Mem.support_storev; eauto.
        + (* call_r *)
          simpl in H2. destr_in H2. inv H2. inv INV; constructor; simpl.
          * red. simpl. simpl_regs. destruct RSPPTR as (o & EQ & AL); simpl in *; rewrite EQ.
            simpl. eexists; split; eauto. apply align_Mptr_sub; auto.
          * red in BSTACKPERM; red; simpl in *.
            intros o k p. erewrite storev_perm; eauto. intro. erewrite storev_perm; eauto.
          * red in STOP; red; simpl in *. erewrite <- Mem.support_storev; eauto.
          * red in SID; red; simpl in *. erewrite <- Mem.support_storev; eauto.
        + (* ret *)
          simpl in H2; repeat destr_in H2; inv INV; constructor; simpl.
          * red. simpl. simpl_regs. destruct RSPPTR as (o & EQ & AL); simpl in *; rewrite EQ.
            simpl. eexists; split; eauto. apply align_Mptr_add; auto.
          * red in BSTACKPERM; red; simpl in *.
            intros o k p. eauto.
          * red in STOP; red; simpl in *. eauto.
          * red in STOP; red; simpl in *. eauto.
        + (* allocframe *)
          simpl in H2; repeat destr_in H2; inv INV; constructor; simpl.
          * red. simpl. simpl_regs. destruct RSPPTR as (o & EQ & AL); simpl in *; rewrite EQ.
            simpl. eexists; split; eauto. apply align_Mptr_add_gen; auto.
            unfold Ptrofs.neg. apply div_unsigned_repr; auto. apply Z.divide_opp_r.
            unfold Ptrofs.sub. apply div_unsigned_repr; auto.
            apply Z.divide_sub_r.
            apply div_unsigned_repr; auto.
            transitivity 8. unfold Mptr. destr; simpl. exists 1; lia. exists 2; lia. apply align_divides. lia.
            apply align_Mptr_modulus.
            apply div_unsigned_repr; auto.
            apply align_size_chunk_divides.
            apply align_Mptr_modulus.
            apply align_Mptr_modulus.
            apply align_Mptr_modulus.
          * red in BSTACKPERM; red; simpl in *.
            intros o k p. erewrite storev_perm; eauto. intro. erewrite storev_perm; eauto.
          * red in STOP; red; simpl in *. erewrite <- Mem.support_storev; eauto.
          * red in STOP; red; simpl in *. erewrite <- Mem.support_storev; eauto.
        + (* freeframe *)
          simpl in H2; repeat destr_in H2; inv INV; constructor; simpl.
          * red. simpl. simpl_regs. destruct RSPPTR as (o & EQ & AL); simpl in *; rewrite EQ.
            simpl. eexists; split; eauto. apply align_Mptr_add_gen; auto.
            unfold Ptrofs.sub. apply div_unsigned_repr; auto.
            apply Z.divide_sub_r.
            apply div_unsigned_repr; auto.
            transitivity 8. unfold Mptr. destr; simpl. exists 1; lia. exists 2; lia. apply align_divides. lia.
            apply align_Mptr_modulus.
            apply div_unsigned_repr; auto.
            apply align_size_chunk_divides.
            apply align_Mptr_modulus.
            apply align_Mptr_modulus.
          * red in BSTACKPERM; red; eauto.
          * red in STOP; red; eauto.
          * red; eauto.
      - inv INV; constructor.
        + red in RSPPTR; red; simpl in *. unfold nextinstr_nf. repeat simpl_regs.
          rewrite Asmgenproof0.undef_regs_other.
          2: simpl; intuition subst; congruence.
          exploit wf_asm_builtin_not_PC; eauto.
          intros (NPC & NRSP & NRA).
          rewrite set_res_other; auto.
          rewrite Asmgenproof0.undef_regs_other.
          eauto. setoid_rewrite in_map_iff. intros r' (x & PREG & IN). subst.
          intro EQ. symmetry in EQ. apply preg_of_not_rsp in EQ. congruence.
        + red in BSTACKPERM; red. simpl in *. intros o k p.
          repeat erewrite (external_perm_stack _ _ _ _ _ _ _ _ _ _ _ H3); eauto.
           simpl. auto. red in STOP; simpl in STOP.  unfold stkblock.
           simpl. destruct STOP as (tl & st & STOP). red in SID. simpl in SID. destr.
           rewrite STOP. split. auto. left. auto. rewrite SID in Heqb0.
           apply Nat.eqb_neq in Heqb0. congruence.
           simpl. auto. red in STOP; simpl in STOP.  unfold stkblock.
           simpl. destruct STOP as (tl & st & STOP). rewrite STOP. destr.
           split. auto. left. auto. red in SID; simpl in SID. rewrite SID in Heqb0.
           apply Nat.eqb_neq in Heqb0. congruence.
        + red in STOP; red; simpl in *. destruct STOP as (tl & st & STOP).
          exploit external_call_stack; eauto. destr. intros.
          rewrite STOP in H4. simpl in H4. destruct st. eauto. eauto.
          intros. rewrite H4. eauto.
        + red; eauto. simpl. erewrite <- external_call_mem_sid; eauto.
      - inv INV; constructor.
        + Opaque destroyed_at_call.
          red in RSPPTR; red; simpl in *. repeat simpl_regs.
          destruct RSPPTR as (o & EQ & AL); simpl in *. rewrite EQ.
          simpl. eexists; split; eauto. apply align_Mptr_add; auto.
        + red in BSTACKPERM; red. simpl in *. intros o k p.
          repeat erewrite (external_perm_stack _ _ _ _ _ _ _ _ _ _ _ H2); eauto.
           simpl. auto. red in STOP; simpl in STOP.  unfold stkblock.
           simpl. destruct STOP as (tl & st & STOP). rewrite STOP. destr.
           split. auto. left. auto. red in SID; simpl in *. rewrite SID in Heqb0.
           apply Nat.eqb_neq in Heqb0. congruence.
           simpl. auto. red in STOP; simpl in STOP.  unfold stkblock.
           simpl. destruct STOP as (tl & st & STOP). rewrite STOP. destr.
           split. auto. left. auto. red in SID. simpl in *. rewrite SID in Heqb0.
           apply Nat.eqb_neq in Heqb0. congruence.
        + red in STOP; red; simpl in *. destruct STOP as (tl & st & STOP).
          exploit external_call_stack; eauto. destr. intros.
          rewrite STOP in H3. simpl in H3. destruct st. eauto. eauto.
          intros. rewrite H3. eauto.
        + red. simpl. eauto. erewrite <- external_call_mem_sid; eauto.
    Qed.

End INVARIANT.

Section WITHGETGE.

    Variable (ge tge: Genv.t Asm.fundef unit).
    Hypothesis (SADDR_EQ: forall id ofs, Genv.symbol_address tge id ofs = Genv.symbol_address ge id ofs).
    Hypothesis (FPTR_EQ: forall b, Genv.find_funct_ptr ge b = None <-> Genv.find_funct_ptr tge b = None).

    Lemma fptr_some_eq:
      forall b f, Genv.find_funct_ptr ge b = Some f ->
             exists f', Genv.find_funct_ptr tge b = Some f'.
    Proof.
      intros.
      destruct (Genv.find_funct_ptr tge b) eqn:EQ; eauto.
      rewrite <- FPTR_EQ in EQ. congruence.
    Qed.

    Lemma funct_some_eq:
      forall b f, Genv.find_funct ge b = Some f ->
             exists f', Genv.find_funct tge b = Some f'.
    Proof.
      unfold Genv.find_funct.
      intros. destruct b; auto; try congruence.
      destr_in H; eauto.
      subst.
      eapply fptr_some_eq; eauto.
    Qed.

    Lemma funct_none_eq: forall b, Genv.find_funct ge b = None <-> Genv.find_funct tge b = None.
    Proof.
      intros. unfold Genv.find_funct.
      destruct b; split; eauto.
      destr; eauto.
      subst. intros. rewrite <- FPTR_EQ. auto.
      destr; eauto.
      subst. intros. rewrite FPTR_EQ. auto.
    Qed.

 (*   Lemma goto_ofs_eq: forall sz ofs rs m,
        goto_ofs ge sz ofs rs m = goto_ofs tge sz ofs rs m.
    Proof.
      intros. unfold goto_ofs. destr; auto.
      destr.
      exploit fptr_some_eq; eauto.
      intros (f1 & FT). rewrite FT. auto.
      rewrite FPTR_EQ in Heqo. rewrite Heqo. auto.
    Qed.
*)
    Ltac unfold_loadstore :=
      match goal with
      | [ |- context[ exec_load _ _ _ _ _  _] ] =>
        unfold exec_load
      | [ |- context[ exec_store _ _ _ _  _ _ _] ] =>
        unfold exec_store
      end.

    Ltac rewrite_eval_addrmode :=
      match goal with
      | [ |- context[ eval_addrmode _ _ _ ] ] =>
        erewrite eval_addrmode_same; eauto
      end.

    Lemma exec_valid_instr_same : forall (i:instruction) f f' i rs m,
        instr_valid i ->
        exec_instr ge f i rs m = exec_instr tge f' i rs m.
    Proof.
      intros i f f' i0 rs m VI.
      destruct i0; cbn; auto;
        try (unfold_loadstore; rewrite_eval_addrmode);
        try (red in VI; cbn in VI; contradiction).
      - congruence.
      - erewrite eval_addrmode32_same; eauto.
      - erewrite eval_addrmode64_same; eauto.
      - erewrite SADDR_EQ. unfold Genv.find_funct.
        destruct (Genv.symbol_address ge symb Ptrofs.zero); auto.
        destruct (Ptrofs.eq_dec i0 Ptrofs.zero); auto.
        destr; destr.
        apply FPTR_EQ in Heqo0. congruence.
        apply FPTR_EQ in Heqo. congruence.
      - unfold Genv.find_funct.
        destruct (rs r); auto.
        destruct (Ptrofs.eq_dec i0 Ptrofs.zero); auto.
        destr; destr.
        apply FPTR_EQ in Heqo0. congruence.
        apply FPTR_EQ in Heqo. congruence.
      - erewrite SADDR_EQ. auto.
    Qed.

    Lemma goto_label_eq : forall (i:instruction) f f' l rs m,
        (forall lbl ofs, label_pos lbl ofs (fn_code f) = label_pos lbl ofs (fn_code f')) ->
        goto_label ge f l rs m = goto_label tge f' l rs m.
    Proof.
      intros.
      unfold goto_label. destr.
      - rewrite <- H. rewrite Heqo.
        destr; auto.
        destr.
        exploit fptr_some_eq; eauto.
        intros (f1 & FT). rewrite FT. auto.
        rewrite FPTR_EQ in Heqo0. rewrite Heqo0. auto.
      - rewrite <- H. rewrite Heqo. auto.
    Qed.

    Lemma exec_instr_same : forall (i:instruction) f f' i rs m,
        (forall lbl ofs, label_pos lbl ofs (fn_code f) = label_pos lbl ofs (fn_code f')) ->
        exec_instr ge f i rs m = exec_instr tge f' i rs m.
    Proof.
      intros i f f' i0 rs m LP.
      destruct (instr_valid_dec i0).
      eapply exec_valid_instr_same; eauto.
      unfold instr_valid in n.
      destruct i0; try tauto.
      - cbn. eapply goto_label_eq; eauto.
      - cbn. destr; auto. destr; auto.
        eapply goto_label_eq; eauto.
      - cbn. destr; auto. destr; auto.
        destr; auto. destr; auto.
        eapply goto_label_eq; eauto.
      - cbn. destr; auto. cbn. destr; auto.
        eapply goto_label_eq; eauto.
    Qed.

End WITHGETGE.

Section RECEPTIVEDET.

  Theorem real_asm_single_events p:
    single_events (semantics p).
  Proof.
    red. simpl. intros s t s' STEP.
    inv STEP; simpl. lia.
    eapply external_call_trace_length; eauto.
    eapply external_call_trace_length; eauto.
  Qed.

  Theorem real_asm_receptive p:
    receptive (semantics p).
  Proof.
    split.
    - simpl. intros s t1 s1 t2 STEP MT.
      inv STEP.
      inv MT. eexists. eapply exec_step_internal; eauto.
      edestruct external_call_receptive as (vres2 & m2 & EC2); eauto.
      eexists. eapply exec_step_builtin; eauto.
      edestruct external_call_receptive as (vres2 & m2 & EC2); eauto.
      eexists. eapply exec_step_external; eauto.
    - eapply real_asm_single_events; eauto.
  Qed.

  Theorem real_asm_determinate p :
    determinate (semantics p).
  Proof.
    split.
    - simpl; intros s t1 s1 t2 s2 STEP1 STEP2.
      inv STEP1.
      + inv STEP2; rewrite_hyps. split. constructor.  congruence.
        simpl in H2. inv H2.
      + inv STEP2; rewrite_hyps. inv H11.
        exploit eval_builtin_args_determ. apply H2. apply H9. intro; subst.
        exploit external_call_determ. apply H3. apply H10. intros (A & B); split; auto. intro C.
        destruct B; auto. congruence.
      + inv STEP2; rewrite_hyps.
        exploit extcall_arguments_determ. apply H1. apply H7. intro; subst.
        exploit external_call_determ. apply H2. apply H8. intros (A & B); split; auto. intro C.
        destruct B; auto. congruence.
    - apply real_asm_single_events.
    - simpl. intros s1 s2 IS1 IS2; inv IS1; inv IS2. rewrite_hyps.
      inv H0. rewrite_hyps. unfold rs0, rs1, ge, ge0 in *. rewrite_hyps. congruence.
    - simpl. intros s r FS.
      red. intros t s' STEP.
      inv FS. inv STEP; rewrite_hyps.
    - simpl. intros s r1 r2 FS1 FS2.
      inv FS1; inv FS2. congruence.
  Qed.

End RECEPTIVEDET.


Require Import compcert.lib.Axioms.

Require Import concurrency.sepcomp. Import SepComp.
Require Import sepcomp.semantics_lemmas.

Require Import concurrency.pos.
Require Import concurrency.concurrent_machine.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

(*NOTE: because of redefinition of [val], these imports must appear
  after Ssreflect eqtype.*)
Require Import compcert.common.AST.     (*for typ*)
Require Import compcert.common.Values. (*for val*)
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.lib.Integers.
Require Import veric.shares msl.msl_standard.
Require Import concurrency.threads_lemmas.

Require Import Coq.ZArith.ZArith.

Require Import (*compcert_linking*) concurrency.permissions.

Module ThreadPool.
  Section ThreadPool.

    Variable cT : Type.

    Record t := mk
                  { num_threads : pos
                    ; pool :> 'I_num_threads -> (@ctl cT)
                    ; share_maps : 'I_num_threads -> share_map
                  }.

    Definition containsThread: t -> nat -> Prop:=
      fun tp tid => tid < (num_threads tp).

  End ThreadPool.
End ThreadPool.

Section poolDefs.

  Variable cT : Type.

  Import ThreadPool.

  Notation "x <= y" := (x <= y)%nat.
  Notation "x < y" := (x < y)%nat.
  Notation thread_pool := (t cT).

  Variable (tp : thread_pool).
  Notation num_threads := (ThreadPool.num_threads tp).

  (* Per-thread disjointness definition*)
  Definition race_free (tp : thread_pool) :=
    forall tid0 tid0' (Htid0 : containsThread tp tid0)
      (Htid0' : containsThread tp tid0')
      (Htid: tid0 <> tid0'),
      shareMapsJoins (share_maps tp (Ordinal Htid0))
                       (share_maps tp (Ordinal Htid0')).

  Definition newShareMap_wf smap :=
    forall tid0 (Htid0 : containsThread tp tid0),
      shareMapsJoins ((share_maps tp) (Ordinal Htid0)) smap.

  Require Import fintype.

  Lemma unlift_m_inv : forall tid (Htid : tid < num_threads.+1) ord
                         (Hunlift: unlift (ordinal_pos_incr num_threads)
                                          (Ordinal (n:=num_threads.+1) (m:=tid) Htid)
                                   = Some ord),
                         nat_of_ord ord = tid.
  Proof.
    intros.
    assert (Hcontra:
              unlift_spec (ordinal_pos_incr num_threads)
                          (Ordinal (n:=num_threads.+1) (m:=tid) Htid) (Some ord)).
    rewrite <- Hunlift.
    apply/unliftP.
    inversion Hcontra; subst.
    inversion H0.
    unfold bump.
    assert (pf: ord < num_threads)
      by (by rewrite ltn_ord).
    assert (H: num_threads <= ord = false).
    rewrite ltnNge in pf.
    rewrite <- Bool.negb_true_iff. auto.
    rewrite H. simpl. rewrite add0n. reflexivity.
  Defined.

  Definition addThread (c : cT) (smap : share_map) : thread_pool :=
    let: new_num_threads := pos_incr num_threads in
    let: new_tid := ordinal_pos_incr num_threads in
    mk new_num_threads
        (fun (n : 'I_new_num_threads) =>
           match unlift new_tid n with
             | None => Kresume c (*Could be a new state Kinit?? *)
             | Some n' => tp n'
           end)
        (fun (n : 'I_new_num_threads) =>
           match unlift new_tid n with
             | None => smap
             | Some n' => (share_maps tp) n'
           end).

  Lemma addThread_racefree :
    forall c p (Hwf: newShareMap_wf p) (Hrace: race_free tp),
      race_free (addThread c p).
  Proof.
    unfold race_free in *. intros.
    simpl.
    match goal with
      | [ |- context[ match ?Expr with _ => _ end]] =>
        destruct Expr as [ord0|] eqn:Hget0
    end;
      match goal with
        | [ |- context[ match ?Expr with _ => _ end]] =>
          destruct Expr as [ord1|] eqn:Hget1
      end; simpl in *.
    - apply unlift_m_inv in Hget0.
      apply unlift_m_inv in Hget1. subst.
      destruct ord0 as [tid0 pf0], ord1 as [tid1 pf1]; simpl in Htid.
      eapply Hrace; eauto.
    - apply unlift_m_inv in Hget0.
      subst. unfold newShareMap_wf in Hwf.
      destruct ord0. eapply Hwf; eauto.
    - apply unlift_m_inv in Hget1.
      subst. unfold newShareMap_wf in Hwf.
      destruct ord1. apply shareMapsJoins_comm. eapply Hwf; eauto.
    - destruct (tid0 == num_threads) eqn:Heq0.
      + move/eqP:Heq0=>Heq0. subst.
        assert (Hcontra: (ordinal_pos_incr num_threads) !=
                                                        (Ordinal (n:=num_threads.+1) (m:=tid0') Htid0')).
        { apply/eqP. intros Hcontra.
          unfold ordinal_pos_incr in Hcontra.
          inversion Hcontra; auto.
        }
        exfalso. apply unlift_some in Hcontra. rewrite Hget1 in Hcontra.
        destruct Hcontra. discriminate.
      + move/eqP:Heq0=>Heq0.
        assert (Hcontra: (ordinal_pos_incr num_threads) !=
                                                        (Ordinal (n:=num_threads.+1) (m:=tid0) Htid0)).
        { apply/eqP. intros Hcontra.
          unfold ordinal_pos_incr in Hcontra. inversion Hcontra. subst. auto. }
        exfalso. apply unlift_some in Hcontra. rewrite Hget0 in Hcontra. destruct Hcontra.
        discriminate.
  Defined.

  Definition updThreadC tid (cont: containsThread tp tid) (c' : ctl) : thread_pool :=
    mk num_threads (fun (n : 'I_num_threads) =>
                      if n == (Ordinal cont) then c' else tp n) (share_maps tp).

  Definition updThreadS tid (cont: containsThread tp tid) (smap' : share_map) :
    thread_pool :=
    mk num_threads (pool tp) (fun (n : 'I_num_threads) =>
                                if n == (Ordinal cont) then smap'
                                else (share_maps tp) n).

  Definition shareMap_wf smap tid :=
    forall tid0 (Htid0 : tid0 < num_threads) (Hneq: tid <> tid0),
      shareMapsJoins ((share_maps tp) (Ordinal Htid0)) smap.

  Definition updThread tid (cont : containsThread tp tid) (c' : ctl)
             (smap : share_map) : thread_pool :=
    mk num_threads
        (fun (n : 'I_num_threads) =>
           if n == (Ordinal cont) then c' else tp n)
        (fun (n : 'I_num_threads) =>
           if n == (Ordinal cont) then smap else (share_maps tp) n).

  Lemma updThread_wf : forall tid (pf : containsThread tp tid) smap
                         (Hwf: shareMap_wf smap tid)
                         c'
                         (Hrace_free: race_free tp),
                         race_free (updThread pf c' smap).
  Proof.
    intros.
    unfold race_free. intros.
    simpl.
    destruct (Ordinal (n:=num_threads) (m:=tid0) Htid0 ==  Ordinal (n:=num_threads) (m:=tid) pf) eqn:Heq0,
                                                                                (Ordinal (n:=num_threads) (m:=tid0') Htid0' == Ordinal (n:=num_threads) (m:=tid) pf) eqn:Heq0'.
    - move/eqP:Heq0 => Heq0. subst.
      move/eqP:Heq0' => Heq0'. inversion Heq0'. inversion Heq0; subst. exfalso; auto.
    - move/eqP:Heq0=>Heq0. inversion Heq0. subst.
      apply shareMapsJoins_comm.
      eapply Hwf. simpl; auto.
    - move/eqP:Heq0'=>Heq0'. inversion Heq0'. subst.
      eapply Hwf. simpl; auto.
    - simpl in *. eapply Hrace_free; eauto.
  Defined.

  Definition getThreadC tid (cont : containsThread tp tid) : ctl :=
    tp (Ordinal cont).

  Definition getThreadS tid (cont : containsThread tp tid) : share_map :=
    (share_maps tp) (Ordinal cont).

  Import Maps.

  Definition perm_compatible p :=
    forall tid (cont : containsThread tp tid) (b : positive) (ofs : Z) ,
      Mem.perm_order'' (Maps.PMap.get b p ofs)
                       (Maps.PMap.get b (share_to_access_map (getThreadS cont)) ofs).

  Record mem_compatible m :=
    { perm_comp: perm_compatible (getMaxPerm m);
      mem_canonical: isCanonical (getMaxPerm m)
    }.

End poolDefs.

Section poolLemmas.

  Context {cT : Type} (tp : ThreadPool.t cT).

  Import ThreadPool.

  Lemma updThreadS_cnt : forall tid tp' (cnt: containsThread tp tid) smap
                           (Hupd: tp' = updThreadS cnt smap),
      containsThread tp' tid.
  Proof.
    intros. unfold containsThread, updThreadS in *. subst. now simpl.
  Defined.

  (*This broke owhen lifting getters and setters for ThreadC. Should be fixed. Nick
    suggested to abstract the machine_state for both machines and have only one set
    of proofs.*)
  (*
  Lemma gssThreadCode (tid : 'I_(num_threads tp)) c' p' counter' :
    getThreadC (updThread tp tid c' p' counter') tid = c'.
  Proof. by rewrite /getThreadC /updThread /= eq_refl. Defined.

  Lemma gsoThread (tid tid' : 'I_(num_threads tp)) c' p' counter':
    tid' != tid -> getThreadC (updThread tp tid c' p' counter') tid' = getThreadC tp tid'.
  Proof. by rewrite /getThreadC /updThread /=; case Heq: (tid' == tid). Defined.

  Lemma gssThreadPerm (tid : 'I_(num_threads tp)) c' p' counter' :
    getThreadPerm (updThread tp tid c' p' counter') tid = p'.
  Proof. by rewrite /getThreadC /updThread /= eq_refl. Defined.

  Lemma gsoThreadPerm (tid tid' : 'I_(num_threads tp)) c' p' counter':
    tid' != tid -> getThreadPerm (updThread tp tid c' p' counter') tid' = getThreadPerm tp tid'.
  Proof. by rewrite /getThreadPerm /updThread /=; case Heq: (tid' == tid). Defined.

  Lemma getAddThread c pmap tid :
    tid = ordinal_pos_incr (num_threads tp) ->
    getThreadC (addThread tp c pmap) tid = c.
  Proof. by rewrite /getThreadC /addThread /= => <-; rewrite unlift_none. Qed. *)

  Lemma permMapsInv_lt : forall p (Hinv: perm_compatible tp p) tid
                           (cont : containsThread tp tid),
      permMapLt (share_to_access_map (getThreadS cont)) p.
  Proof.
    intros.
    unfold permMapLt; auto.
  Qed.

  Definition restrPermMap p' m (Hlt: permMapLt p' (getMaxPerm m)) : mem.
  Proof.
    refine ({|
               Mem.mem_contents := Mem.mem_contents m;
               Mem.mem_access :=
                 (fun ofs k =>
                    match k with
                      | Cur => None
                      | Max => fst (Mem.mem_access m) ofs k
                    end, Maps.PTree.map (fun b f =>
                                           fun ofs k =>
                                             match k with
                                               | Cur =>
                                                 (Maps.PMap.get b p') ofs
                                               | Max =>
                                                 f ofs Max
                                             end) (Mem.mem_access m).2);
               Mem.nextblock := Mem.nextblock m;
               Mem.access_max := _;
               Mem.nextblock_noaccess := _;
               Mem.contents_default := Mem.contents_default m |}).
    - unfold permMapLt in Hlt.
      assert (Heq: forall b ofs, Maps.PMap.get b (getMaxPerm m) ofs =
                            Maps.PMap.get b (Mem.mem_access m) ofs Max).
      { unfold getMaxPerm. intros.
        rewrite Maps.PMap.gmap. reflexivity. }
      intros.
      specialize (Hlt b ofs).
      specialize (Heq b ofs).
      unfold getMaxPerm in Hlt.
      unfold Maps.PMap.get in *. simpl in *.
      rewrite Maps.PTree.gmap; simpl.
      match goal with
        | [|- context[match Coqlib.option_map ?Expr1 ?Expr2  with _ => _ end]] =>
          destruct (Coqlib.option_map Expr1 Expr2) as [f|] eqn:?
      end; auto; unfold Coqlib.option_map in Heqo.
      destruct (Maps.PTree.get b (Mem.mem_access m).2) eqn:?; try discriminate.
      + inversion Heqo; subst; clear Heqo.
        rewrite Heq in Hlt. auto.
      + unfold Mem.perm_order''. by destruct ((Mem.mem_access m).1 ofs Max).
    - intros b ofs k Hnext.
    - unfold permMapLt in Hlt.
      assert (Heq: forall b ofs, Maps.PMap.get b (getMaxPerm m) ofs =
                            Maps.PMap.get b (Mem.mem_access m) ofs Max).
      { unfold getMaxPerm. intros.
        rewrite Maps.PMap.gmap. reflexivity. }
      specialize (Hlt b ofs).
      specialize (Heq b ofs).
      unfold Maps.PMap.get in *.
      simpl in *.
      rewrite Maps.PTree.gmap; simpl.
      assert (H := Mem.nextblock_noaccess m).
      specialize (H b). unfold Maps.PMap.get in H.
      match goal with
        | [|- context[match Coqlib.option_map ?Expr1 ?Expr2  with _ => _ end]] =>
          destruct (Coqlib.option_map Expr1 Expr2) as [f|] eqn:?
      end; auto; unfold Coqlib.option_map in Heqo;
      destruct (Maps.PTree.get b (Mem.mem_access m).2) eqn:Heqo2; try discriminate.
      inversion Heqo. subst f. clear Heqo.
      destruct k; auto.
      rewrite Heq in Hlt.
      specialize (H ofs Max). rewrite H in Hlt; auto.
      unfold Mem.perm_order'' in Hlt. destruct (Maps.PTree.get b p'.2).
      destruct (o0 ofs); tauto.
      destruct (p'.1 ofs); tauto.
      rewrite H; auto. destruct k; auto.
  Defined.

  Lemma restrPermMap_nextblock :
    forall p' m (Hlt: permMapLt p' (getMaxPerm m)),
      Mem.nextblock (restrPermMap Hlt) = Mem.nextblock m.
  Proof.
    intros. unfold restrPermMap. reflexivity.
  Qed.

  Lemma restrPermMap_irr : forall p' p'' m
                             (Hlt : permMapLt p' (getMaxPerm m))
                             (Hlt': permMapLt p'' (getMaxPerm m))
                             (Heq_new: p' = p''),
                             restrPermMap Hlt = restrPermMap Hlt'.
  Proof.
    intros. subst.
    apply f_equal. by apply proof_irr.
  Qed.

  Lemma restrPermMap_disjoint_inv:
    forall (mi mj m : mem) (pi pj : access_map)
      (Hcan_m: isCanonical (getMaxPerm m))
      (Hltj: permMapLt pj (getMaxPerm m))
      (Hlti: permMapLt pi (getMaxPerm m))
      (Hdisjoint: permMapsDisjoint pi pj)
      (Hrestrj: restrPermMap Hltj = mj)
      (Hrestri: restrPermMap Hlti = mi),
      permMapsDisjoint (getCurPerm mi) (getCurPerm mj).
  Proof.
    intros. rewrite <- Hrestri. rewrite <- Hrestrj.
    unfold restrPermMap, getCurPerm, permMapsDisjoint. simpl in *.
    intros b ofs.
    do 2 rewrite Maps.PMap.gmap.
    clear Hrestrj Hrestri.
    unfold permMapLt, Mem.perm_order'' in *.
    specialize (Hltj b ofs); specialize (Hlti b ofs).
    unfold getMaxPerm in *; simpl in *.
    rewrite Maps.PMap.gmap in Hlti, Hltj.
    unfold permMapsDisjoint, Maps.PMap.get in *; simpl in *.
    do 2 rewrite Maps.PTree.gmap. unfold Coqlib.option_map.
    specialize (Hdisjoint b ofs).
    assert (Hnone: (Mem.mem_access m).1 ofs Max = None)
      by (unfold isCanonical in Hcan_m; simpl in Hcan_m;
            by apply equal_f with (x:=ofs) in Hcan_m).
    destruct (Maps.PTree.get b (Mem.mem_access m).2) eqn:?; auto.
    rewrite Hnone in Hlti, Hltj;
      destruct (Maps.PTree.get b pi.2)
      as [f1 |] eqn:?;
                destruct (Maps.PTree.get b pj.2) as [f2|] eqn:?;
      repeat match goal with
               | [H: match ?Expr with _ => _ end |- _] => destruct Expr
             end; tauto.
  Qed.

  Lemma no_race_wf : forall tid (cont: containsThread tp tid) (Hrace: race_free tp),
                       shareMap_wf tp (getThreadS cont) tid.
  Proof.
    intros; unfold shareMap_wf, getThreadS in *; auto.
  Defined.

End poolLemmas.

Module Concur.
  Section Concur.

    Import ThreadPool.
    Context {cT G : Type} {the_sem : CoreSemantics G cT Mem.mem}.

    Notation thread_pool := (t cT).
    Notation perm_map := access_map.

    Variable the_ge : G.
    Definition ls_id : nat := 0.
    Definition sp_id : nat := 1.

    Record invariant (tp : thread_pool) :=
      { no_race : race_free tp;
        lock_set : forall (cont : containsThread tp ls_id), exists c,
              getThreadC cont = Krun c /\ halted the_sem c;
        share_pool : forall (cont : containsThread tp sp_id), exists c,
              getThreadC cont = Krun c /\ halted the_sem c }.

    (* Semantics of the coarse-grained concurrent machine*)
    (* Definition cont2ord {ms tid0} (cnt: containsThread ms tid0) := *)
    (*   Ordinal cnt. *)

    Inductive dry_step {tid0 tp m} (cnt: containsThread tp tid0)
      (Hcompatible: mem_compatible tp m) : thread_pool -> mem  -> Prop :=
    | step_dry :
        forall (tp':thread_pool) c m1 m' (c' : cT),
          let: smap := getThreadS cnt in
          forall (Hrestrict_pmap:
               restrPermMap (permMapsInv_lt (perm_comp Hcompatible) cnt) = m1)
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt = Krun c)
            (Hcorestep: corestep the_sem the_ge c m1 c' m')
            (Htp': tp' = updThread cnt (Krun c')
                                   (access_to_share_map smap (getCurPerm m'))),
            dry_step cnt Hcompatible tp' m'.

    (*missing lock-ranges*)
    Inductive ext_step {tid0 tp m}
              (cnt0: containsThread tp tid0) (Hcompat: mem_compatible tp m):
      thread_pool -> mem -> Prop :=
    | step_lock :
        forall (tp' tp'':thread_pool) m1 c c' m' b ofs smap_sp' smap_tid' tmap
          (cnt_ls: containsThread tp ls_id)
          (cnt_sp: containsThread tp sp_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_sp := getThreadS cnt_sp in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (LOCK, ef_sig LOCK, Vptr b ofs::nil))
            (Hcompatible: mem_compatible tp m)
            (Hrestrict_pmap:
               restrPermMap (permMapsInv_lt (perm_comp Hcompatible) cnt_ls) = m1)
            (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.one))
            (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
            (Hat_external: after_external the_sem (Some (Vint Int.zero)) c = Some c')
            (Hjoin1: shareMapsJoin smap_sp' tmap smap_sp)
            (Hjoin2: shareMapsJoin smap_tid tmap smap_tid')
            (Htp': tp' = updThreadS cnt_sp smap_sp')
            (Htp'': tp'' = updThread (updThreadS_cnt Htp') (Kresume c')
                                     smap_tid'),
            ext_step cnt0 Hcompat tp'' m'

    | step_unlock :
        forall  (tp' tp'':thread_pool) m1 c c' m' b ofs smap_sp' smap_tid' tmap
           (cnt_ls: containsThread tp ls_id)
           (cnt_sp: containsThread tp sp_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_sp := getThreadS cnt_sp in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (UNLOCK, ef_sig UNLOCK, Vptr b ofs::nil))
            (Hrestrict_pmap:
               restrPermMap (permMapsInv_lt (perm_comp Hcompat) cnt_ls) = m1)
            (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.zero))
            (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.one) = Some m')
            (Hat_external: after_external the_sem (Some (Vint Int.zero)) c = Some c')
            (Hjoin1: shareMapsJoin smap_tid' tmap smap_tid)
            (Hjoin2: shareMapsJoin smap_sp tmap smap_sp')
            (Htp': tp' = updThreadS cnt_sp smap_sp')
            (Htp'': tp'' = updThread (updThreadS_cnt Htp') (Kresume c')
                                   smap_tid'),
            ext_step cnt0 Hcompat tp'' m'

    | step_create :
        forall  (tp_upd tp':thread_pool) c c' c_new vf arg smap_tid' tmap
           (cnt_ls: containsThread tp ls_id)
           (cnt_sp: containsThread tp sp_id),
          let: smap_tid := getThreadS cnt0 in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (CREATE, ef_sig CREATE, vf::arg::nil))
            (Hinitial: initial_core the_sem the_ge vf (arg::nil) = Some c_new)
            (Hafter_external: after_external the_sem
                                             (Some (Vint Int.zero)) c = Some c')
            (Hjoin: shareMapsJoin smap_tid' tmap smap_tid)
            (Htp_upd: tp_upd = updThread cnt0 (Kresume c') smap_tid')
            (Htp': tp' = addThread tp_upd c_new tmap),
            ext_step cnt0 Hcompat tp' m

    | step_mklock :
        forall  (tp' tp'': thread_pool) m1 c c' m' b ofs smap_tid' smap_ls'
           (cnt_ls: containsThread tp ls_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_ls := getThreadS cnt_ls in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (MKLOCK, ef_sig MKLOCK, Vptr b ofs::nil))
            (Hrestrict_pmap: restrPermMap
                               (permMapsInv_lt (perm_comp Hcompat) cnt_ls) = m1)
            (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
            (Hdrop_share:
               setShare extern_retainer b (Int.intval ofs) smap_tid = smap_tid')
            (Hlp_share: setShare Ews
                               b (Int.intval ofs) smap_ls = smap_ls')
            (Hafter_external: after_external
                                the_sem (Some (Vint Int.zero)) c = Some c')
            (Htp': tp' = updThreadS cnt_ls smap_ls')
            (Htp'':
               tp'' = updThread (updThreadS_cnt Htp') (Kresume c') smap_tid'),
            ext_step cnt0 Hcompat tp'' m'

    | step_freelock :
        forall  (tp' tp'': thread_pool) c c' b ofs smap_tid' smap_ls'
           (cnt_ls: containsThread tp ls_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_ls := getThreadS cnt_ls in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (FREE_LOCK, ef_sig FREE_LOCK, Vptr b ofs::nil))
            (Hdrop_share:
               setShare Share.bot b (Int.intval ofs) smap_ls = smap_ls')
            (Hafter_external: after_external
                                the_sem (Some (Vint Int.zero)) c = Some c')
            (Htp': tp' = updThreadS cnt_ls smap_ls')
            (Htp'':
               tp'' = updThread (updThreadS_cnt Htp') (Kresume c') smap_tid'),
            ext_step cnt0 Hcompat  tp'' m

    | step_lockfail :
        forall  c b ofs m1
           (cnt_ls: containsThread tp ls_id),
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (LOCK, ef_sig LOCK, Vptr b ofs::nil))
            (Hrestrict_pmap: restrPermMap
                               (permMapsInv_lt (perm_comp Hcompat) cnt_ls) = m1)
            (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.zero)),
            ext_step cnt0 Hcompat tp m.
  End Concur.

  Module ShareMachineSig (Sem: Semantics) <: ConcurrentMachineSig NatTID.
    (*TID = NAT*)
    Definition tid := nat.
    (*Memories*)
    Definition richMem: Type:= Sem.M.
    Definition dryMem: richMem -> mem:= fun x => x.

    (*CODE*)
    Definition cT: Type:= Sem.C.
    Definition G: Type:= Sem.G.
    Definition Sem := Sem.Sem.
    Definition cT': Type := @ctl cT.

    (*thread pool*)
    Import ThreadPool.
    Notation thread_pool := (t cT).

    (*MACHINE VARIABLES*)
    Definition machine_state: Type:= thread_pool.
    Definition containsThread: machine_state -> tid -> Prop:=
      fun ms tid0 => tid0 < (num_threads ms).
    Definition ls_id : tid:= 0.
    Definition sp_id : tid:= 1.

    (*INVARIANTS*)
    (*The state respects the memory*)
    Definition mem_compatible: machine_state -> mem -> Prop:=
      @mem_compatible cT.

    (*CODE GETTER AND SETTER*)
    Definition getThreadC: forall {ms tid0}, containsThread ms tid0 -> @ctl cT:= @getThreadC cT.
    Definition updThreadC: forall {ms tid0}, containsThread ms tid0 -> @ctl cT -> machine_state:= @updThreadC cT.

    (*Steps*)
    Definition cstep (genv:G): forall {tid0 ms m},
                                 containsThread ms tid0 -> mem_compatible ms m ->
                                 machine_state -> mem -> Prop:=
      @dry_step cT G Sem genv.

    Definition conc_call (genv:G):
      forall {tid0 ms m},
        containsThread ms tid0 -> mem_compatible ms m ->
        machine_state -> mem -> Prop:=
      fun tid ms m => @ext_step cT G Sem genv tid ms m.

    Inductive threadHalted': forall {tid0 ms},
                               containsThread ms tid0 -> Prop:=
    | thread_halted':
        forall tp c tid0
          (cnt: containsThread tp tid0),
          let: tid := Ordinal cnt in
          forall
            (Hthread: getThreadC cnt = Krun c)
            (Hcant: halted Sem c),
            threadHalted' cnt.
    Definition threadHalted: forall {tid0 ms},
                               containsThread ms tid0 -> Prop:= @threadHalted'.

    Lemma onePos: (0<1)%coq_nat. auto. Qed.
    Definition initial_machine c:=
      @mk cT (mkPos onePos) (fun _ => c) (fun _ => empty_share_map) .
    Definition init_mach  (genv:G)(v:val)(args:list val):option machine_state:=
      match initial_core Sem genv v args with
      | Some c => Some (initial_machine (Kresume c) )
      | None => None
      end.
  End ShareMachineSig.

  (* Here I make the core semantics*)
  Variable example_G: Type.
  Variable example_C: Type.
  Variable example_sem: CoreSemantics example_G example_C mem.
  Module Sem: Semantics.
    Definition G:= example_G.
    Definition C:= example_C.
    Definition M:= mem.
    Definition Sem:=example_sem.
  End Sem.
  Module mySchedule := ListScheduler NatTID.
  Module mySem := ShareMachineSig Sem.
  Module myCoarseSemantics :=
    CoarseMachine NatTID mySchedule mySem.
  Module myFineSemantics :=
    FineMachine NatTID mySchedule mySem.

  Definition coarse_semantics:=
    myCoarseSemantics.MachineSemantics.
  Definition fine_semantics:=
    myFineSemantics.MachineSemantics.

End Concur.

(* After this there needs to be some cleaning. *)

(* Section InitialCore. *)

(*   Context {cT G : Type} {the_sem : CoreSemantics G cT Mem.mem}. *)
(*   Import ThreadPool. *)

(*   Notation thread_pool := (t cT). *)
(*   Notation perm_map := access_map. *)

(*   Definition at_external (st : (list nat) * thread_pool) *)
(*   : option (external_function * signature * seq val) := None. *)

(*   Definition after_external (ov : option val) (st : list nat * thread_pool) : *)
(*     option (list nat * thread_pool) := None. *)

(*   Definition two_pos : pos := mkPos NPeano.Nat.lt_0_2. *)

(*   Definition ord1 := Ordinal (n := two_pos) (m := 1) (leqnn two_pos). *)

(*   (*not clear what the value of halted should be*) *)
(*   Definition halted (st : list nat * thread_pool) : option val := None. *)

(*   Variable compute_init_perm : G -> access_map. *)
(*   Variable lp_code : cT. *)
(*   Variable sched : list nat. *)

(*   Definition initial_core the_ge (f : val) (args : list val) : option (list nat * thread_pool) := *)
(*     match initial_core the_sem the_ge f args with *)
(*       | None => None *)
(*       | Some c => *)
(*         Some (sched, ThreadPool.mk *)
(*                        two_pos *)
(*                        (fun tid => if tid == ord0 then lp_code *)
(*                                 else if tid == ord1 then c *)
(*                                      else c (*bogus value; can't occur*)) *)
(*                        (fun tid => if tid == ord0 then empty_map else *)
(*                                   if tid == ord1 then compute_init_perm the_ge *)
(*                                   else empty_map) *)
(*                        0) *)
(*     end. *)

(*   Variable aggelos : nat -> access_map. *)

(*   Definition cstep (the_ge : G) (st : list nat * thread_pool) m *)
(*              (st' : list nat * thread_pool) m' := *)
(*     @step cT G the_sem the_ge aggelos (@coarse_step cT G the_sem the_ge) *)
(*           (fst st) (snd st) m (fst st') (snd st') m'. *)

(*   Definition fstep (the_ge : G) (st : list nat * thread_pool) m *)
(*              (st' : list nat * thread_pool) m' := *)
(*     @step cT G the_sem the_ge aggelos (@fine_step cT G the_sem the_ge) *)
(*           (fst st) (snd st) m (fst st') (snd st') m'. *)

(*   Program Definition coarse_semantics : *)
(*     CoreSemantics G (list nat * thread_pool) mem := *)
(*     Build_CoreSemantics _ _ _ *)
(*                         initial_core *)
(*                         at_external *)
(*                         after_external *)
(*                         halted *)
(*                         cstep *)
(*                         _ _ _. *)

(*   Program Definition fine_semantics : *)
(*     CoreSemantics G (list nat * thread_pool) mem := *)
(*     Build_CoreSemantics _ _ _ *)
(*                         initial_core *)
(*                         at_external *)
(*                         after_external *)
(*                         halted *)
(*                         fstep *)
(*                         _ _ _. *)

(* End InitialCore. *)

(* End Concur. *)


Require Import BinNat.
Require Import Bool.
Require Import Omega.
Require Import sflib.

Require Import Common.
Require Import Value.
Require Import Memory.
Require Import State.
Require Import Behaviors.
Require Import SmallStep.

Module Ir.

Module Refinement.

Definition refines_value (v_tgt v_src:Ir.val): bool :=
  match (v_tgt, v_src) with
  | (_, Ir.poison) => true
  | (Ir.num ntgt, Ir.num nsrc) => Nat.eqb ntgt nsrc
  | (Ir.ptr ptgt, Ir.ptr psrc) => Ir.ptr_eqb ptgt psrc
  | (_, _) => false
  end.

Definition refines_bit (b_tgt b_src:Ir.Bit.t): bool :=
  match (b_src, b_tgt) with
  | (Ir.Bit.bpoison, _) => true
  | (_, Ir.Bit.bpoison) => false
  | (Ir.Bit.bint b1, Ir.Bit.bint b2) => Bool.eqb b1 b2
  | (Ir.Bit.baddr p1 o1, Ir.Bit.baddr p2 o2) =>
    Nat.eqb o1 o2 && Ir.ptr_eqb p1 p2
  | (_, _) => false
  end.

Definition refines_byte (b_tgt b_src:Ir.Byte.t): bool :=
  refines_bit b_tgt.(Ir.Byte.b0) b_src.(Ir.Byte.b0) &&
  refines_bit b_tgt.(Ir.Byte.b1) b_src.(Ir.Byte.b1) &&
  refines_bit b_tgt.(Ir.Byte.b2) b_src.(Ir.Byte.b2) &&
  refines_bit b_tgt.(Ir.Byte.b3) b_src.(Ir.Byte.b3) &&
  refines_bit b_tgt.(Ir.Byte.b4) b_src.(Ir.Byte.b4) &&
  refines_bit b_tgt.(Ir.Byte.b5) b_src.(Ir.Byte.b5) &&
  refines_bit b_tgt.(Ir.Byte.b6) b_src.(Ir.Byte.b6) &&
  refines_bit b_tgt.(Ir.Byte.b7) b_src.(Ir.Byte.b7).

Definition refines_event (e_tgt e_src:Ir.event): bool :=
  match (e_tgt, e_src) with
  | (Ir.e_some vtgt, Ir.e_some vsrc) => Nat.eqb vtgt vsrc
  | (Ir.e_none, Ir.e_none) => true
  | _ => false
  end.

Definition refines_trace (tr_tgt tr_src:Ir.trace):bool :=
  let tr_tgt' := List.filter Ir.not_none tr_tgt in
  let tr_src' := List.filter Ir.not_none tr_src in
  if Nat.eqb (List.length tr_tgt') (List.length tr_src') then
    List.forallb (fun ee => refines_event ee.(fst) ee.(snd))
                 (List.combine tr_tgt' tr_src')
  else false.

(* If tgts_prefix is true, check whether tr_tgt has a prefix
   that refines tr_src.
   If tgts_prefix is false, check whether tr_src has a prefix
   so tr_tgt refines the prefix. *)
Definition refines_trace_prefix (tr_tgt tr_src:Ir.trace) (tgts_prefix:bool)
: bool :=
  let tr_tgt' := List.filter Ir.not_none tr_tgt in
  let tr_src' := List.filter Ir.not_none tr_src in
  let (tr_tgt', tr_src') :=
      if tgts_prefix then (List.firstn (List.length tr_src') tr_tgt', tr_src')
      else (tr_tgt', List.firstn (List.length tr_tgt') tr_src') in
  refines_trace tr_tgt' tr_src'.

(* Checks whether the behavior of a target program refines the behavior of a source program. *)
Definition refines (pb_tgt pb_src:Ir.program_behavior):bool :=
  match (pb_tgt, pb_src) with
  | (Ir.b_terminates tr_tgt ret_tgt, Ir.b_terminates tr_src ret_src) =>
    refines_trace tr_tgt tr_src && refines_value ret_tgt ret_src

  | (Ir.b_terminates tr_tgt ret_tgt, Ir.b_diverges tr_src) =>
    (* infinite loop without any event is UB.
       Chech whether target's trace has a prefix that refines trace of the source. *)
    refines_trace_prefix tr_tgt tr_src true

  | (Ir.b_terminates tr_tgt ret_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace_prefix tr_tgt tr_src true

  | (Ir.b_diverges tr_tgt, Ir.b_diverges tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_diverges tr_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_goes_wrong tr_tgt, Ir.b_diverges tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_goes_wrong tr_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_oom tr_tgt, Ir.b_terminates tr_src ret_src) =>
    refines_trace_prefix tr_tgt tr_src false

  | (Ir.b_oom tr_tgt, Ir.b_diverges tr_src) =>
    (* If source has UB and target has OOM,
       either the trace of source may be the prefix of the trace of target,
       or the trace of target may be the prefix of the trace of source. *)
    refines_trace_prefix tr_tgt tr_src true ||
    refines_trace_prefix tr_tgt tr_src false

  | (Ir.b_oom tr_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace_prefix tr_tgt tr_src true ||
    refines_trace_prefix tr_tgt tr_src false

  | (Ir.b_oom tr_tgt, Ir.b_oom tr_src) =>
    (* target trace should be prefix of source trace. *)
    refines_trace_prefix tr_tgt tr_src true

  | (_, _) => false
  end.

(***********************************************************
   Propositional definition of refinements on memory, state
 ***********************************************************)

Definition refines_memblock (mb_tgt mb_src:Ir.MemBlock.t) :=
  mb_tgt.(Ir.MemBlock.bt) = mb_src.(Ir.MemBlock.bt) /\
  mb_tgt.(Ir.MemBlock.r) = mb_src.(Ir.MemBlock.r) /\
  mb_tgt.(Ir.MemBlock.n) = mb_src.(Ir.MemBlock.n) /\
  mb_tgt.(Ir.MemBlock.a) = mb_src.(Ir.MemBlock.a) /\
  List.Forall2 (fun b1 b2 => refines_byte b1 b2 = true)
               mb_tgt.(Ir.MemBlock.c) mb_src.(Ir.MemBlock.c) /\
  mb_tgt.(Ir.MemBlock.P) = mb_src.(Ir.MemBlock.P).

Definition refines_memory (m_tgt m_src:Ir.Memory.t) :=
  m_tgt.(Ir.Memory.mt) = m_src.(Ir.Memory.mt) /\
  List.Forall2 (fun mbid_tgt mbid_src =>
                  fst mbid_tgt = fst mbid_src /\
                  refines_memblock (snd mbid_tgt) (snd mbid_src))
               m_tgt.(Ir.Memory.blocks) m_src.(Ir.Memory.blocks) /\
  m_tgt.(Ir.Memory.calltimes) = m_src.(Ir.Memory.calltimes) /\
  m_tgt.(Ir.Memory.fresh_bid) = m_src.(Ir.Memory.fresh_bid).

Definition refines_regfile (rf_tgt rf_src:Ir.Regfile.t) :=
  forall regid,
    (Ir.Regfile.get rf_tgt regid = None <-> Ir.Regfile.get rf_src regid = None) /\
    (forall vtgt
            (HGET:Ir.Regfile.get rf_tgt regid = Some vtgt),
        exists vsrc, Ir.Regfile.get rf_src regid = Some vsrc /\
                     refines_value vtgt vsrc = true).

Definition refines_stack (s_tgt s_src:Ir.Stack.t) :=
  List.Forall2 (fun itm_tgt itm_src =>
                  fst itm_tgt = fst itm_src /\
                  fst (snd itm_tgt) = fst (snd itm_src) /\
                  refines_regfile (snd (snd itm_tgt)) (snd (snd itm_src)))
               s_tgt s_src.

Definition refines_state (s_tgt s_src:Ir.Config.t) :=
  refines_memory s_tgt.(Ir.Config.m) s_src.(Ir.Config.m) /\
  refines_stack s_tgt.(Ir.Config.s) s_src.(Ir.Config.s) /\
  s_tgt.(Ir.Config.cid_to_f) = s_src.(Ir.Config.cid_to_f) /\
  s_tgt.(Ir.Config.cid_fresh) = s_src.(Ir.Config.cid_fresh).

Import Ir.SmallStep.

(* refines_step_res <tgt> <src> *)
Inductive refines_step_res: step_res -> step_res -> Prop :=
| srref_tgt_oom:
    forall sr_src,
      refines_step_res sr_oom sr_src
| srref_src_goes_wrong:
    forall sr_tgt,
      refines_step_res sr_tgt sr_goes_wrong
| srref_finish:
    forall v_tgt v_src
           (HREFV:refines_value v_tgt v_src),
    refines_step_res (sr_prog_finish v_tgt) (sr_prog_finish v_src)
| srref_success:
    forall e_tgt e_src s_tgt s_src
           (HREFE:refines_event e_tgt e_src)
           (HREFS:refines_state s_tgt s_src), (* Just checks equality. *)
    refines_step_res (sr_success e_tgt s_tgt) (sr_success e_src s_src).

(***********************************************************
               Lemmas about refinement.
 ***********************************************************)

Theorem refines_value_refl:
  forall (v:Ir.val), refines_value v v = true.
Proof.
  intros.
  destruct v; unfold refines_value.
  - rewrite Nat.eqb_eq. auto.
  - rewrite Ir.ptr_eqb_refl. reflexivity.
  - reflexivity.
Qed.

Theorem refines_value_trans:
  forall (v1 v2 v3:Ir.val)
         (HREF1:refines_value v1 v2 = true)
         (HREF2:refines_value v2 v3 = true),
    refines_value v1 v3 = true.
Proof.
  intros.
  unfold refines_value in *.
  des_ifs.
  rewrite PeanoNat.Nat.eqb_eq in *.
  congruence.
  unfold Ir.ptr_eqb in *.
  des_ifs; try rewrite andb_true_iff in *;
    repeat (rewrite PeanoNat.Nat.eqb_eq in *);
    destruct HREF1; destruct HREF2;
    try congruence.
  split; congruence.
  repeat (rewrite andb_true_iff in *);
    repeat (rewrite PeanoNat.Nat.eqb_eq in *).
  destruct H. destruct H. destruct H1.  destruct H1.
  split; try congruence.
  split; try congruence.
  split; try congruence.
  eapply list_inclb_trans. eapply H4. ss.
  eapply list_inclb_trans. eapply H5. ss.
  split; try ss.
  repeat (rewrite andb_true_iff in *).
  repeat (rewrite PeanoNat.Nat.eqb_eq in *).
  intuition.
  eapply list_inclb_trans. eapply H6. ss.
  eapply list_inclb_trans. eapply H5. ss.
Qed.

Theorem refines_bit_refl:
  forall b, refines_bit b b = true.
Proof.
  unfold refines_bit.
  intros.
  destruct b. destruct b; reflexivity.
  unfold Ir.ptr_eqb.
  destruct p; repeat (rewrite PeanoNat.Nat.eqb_refl); try reflexivity.
  repeat (rewrite Common.list_inclb_refl).
  destruct o. rewrite PeanoNat.Nat.eqb_refl. reflexivity.
  reflexivity.
  reflexivity.
Qed.

Lemma ptr_eqb_trans:
  forall p1 p2 p3
         (H1:Ir.ptr_eqb p1 p2 = true)
         (H2:Ir.ptr_eqb p2 p3 = true),
    Ir.ptr_eqb p1 p3 = true.
Proof.
  intros.
  unfold Ir.ptr_eqb in *.
  des_ifs; repeat (rewrite andb_true_iff in *);
           repeat (rewrite PeanoNat.Nat.eqb_eq in *);
           try (inv H1; inv H0; fail);
           try (inv H2; inv H0; fail).
  intuition.
  { inv H1. inv H. inv H0.
    inv H2. inv H. inv H0.
    split; try ss.
    split. { split. congruence.
             eapply list_inclb_trans. eapply H3. ss. }
           { eapply list_inclb_trans. eapply H2. ss. }
  }
  { inv H1. inv H. inv H1.
    inv H2. inv H. inv H2.
    split; try ss.
    split. { split. congruence.
             eapply list_inclb_trans. eapply H4. ss. }
           { eapply list_inclb_trans. eapply H5. ss. }
  }
Qed.

Theorem refines_bit_trans:
  forall b1 b2 b3
         (HREF1:refines_bit b1 b2 = true)
         (HREF2:refines_bit b2 b3 = true),
    refines_bit b1 b3 = true.
Proof.
  intros.
  unfold refines_bit in *.
  des_ifs.
  unfold eqb in *. des_ifs.
  rewrite andb_true_iff in *.
  repeat (rewrite PeanoNat.Nat.eqb_eq in *).
  intuition.
  eapply ptr_eqb_trans. eassumption. ss.
Qed.

Ltac unfold_all_ands_H :=
  repeat (match goal with
  | [ H : _ /\ _ |- _ ] => destruct H
  end).

Theorem refines_byte_trans:
  forall b1 b2 b3
         (HREF1:refines_byte b1 b2 = true)
         (HREF2:refines_byte b2 b3 = true),
    refines_byte b1 b3 = true.
Proof.
  intros.
  unfold refines_byte in *.
  repeat (rewrite andb_true_iff in *).
  unfold_all_ands_H.
  repeat (split; try (eapply refines_bit_trans; try eassumption; assumption)).
Qed.

Theorem refines_memblock_refl:
  forall mb1,
    refines_memblock mb1 mb1.
Proof.
  intros.
  repeat (split;try congruence).
  apply Forall2_samelist.
  intros.
  unfold refines_byte.
  repeat (rewrite andb_true_iff).
  repeat (rewrite refines_bit_refl).
  repeat (split; try reflexivity).
Qed.

Theorem refines_memblock_trans:
  forall mb1 mb2 mb3
         (HREF1:refines_memblock mb1 mb2)
         (HREF1:refines_memblock mb2 mb3),
    refines_memblock mb1 mb3.
Proof.
  intros.
  inv HREF1. inv H0. inv H2. inv H3.
  inv HREF0. inv H5. inv H7. inv H8.
  inv H4. inv H9.
  repeat (split;try congruence).
  eapply Forall2_trans.
  { intros. eapply refines_byte_trans. eassumption. ss.
  }
  eassumption. assumption.
Qed.

Theorem refines_memory_refl:
  forall (m1:Ir.Memory.t),
    refines_memory m1 m1.
Proof.
  intros.
  split.
  { congruence. }
  split.
  { eapply Forall2_samelist.
    intros. split. reflexivity. apply refines_memblock_refl.
  }
  split; reflexivity.
Qed.

Theorem refines_memory_trans:
  forall m1 m2 m3
         (HREF1:refines_memory m1 m2)
         (HREF1:refines_memory m2 m3),
    refines_memory m1 m3.
Proof.
  intros.
  destruct HREF1.
  destruct HREF0.
  unfold_all_ands_H.
  repeat (split; try congruence).
  eapply Forall2_trans.
  { intros.
    unfold_all_ands_H.
    split. congruence. eapply refines_memblock_trans. eassumption. ss.
  }
  eassumption. assumption.
Qed.

Theorem refines_event_refl:
  forall (e:Ir.event), refines_event e e = true.
Proof.
  intros.
  destruct e. unfold refines_event. reflexivity.
  unfold refines_event. rewrite Nat.eqb_eq. reflexivity.
Qed.

Theorem refines_trace_refl:
  forall (t:Ir.trace), refines_trace t t = true.
Proof.
  intros.
  induction t.
  - reflexivity.
  - unfold refines_trace in *.
    assert (forall {X:Type} (l:list X), (List.length l =? List.length l) = true).
    { intros.
      rewrite Nat.eqb_eq. reflexivity. }
    rewrite H. rewrite H in IHt.
    simpl.
    destruct (Ir.not_none a) eqn:HNN.
    simpl. rewrite IHt. rewrite refines_event_refl. reflexivity.
    assumption.
Qed.

Theorem refines_trace_prefix_refl:
  forall (t:Ir.trace) b, refines_trace_prefix t t b = true.
Proof.
  intros.
  destruct b; unfold refines_trace_prefix in *;
    rewrite List.firstn_all in *;
    rewrite refines_trace_refl;
    reflexivity.
Qed.

Lemma regfile_eq_empty_false:
  forall st1 st,
    ~ Ir.Regfile.eq (st::st1) [].
Proof.
  intros.
  intros HEQ.
  unfold Ir.Regfile.eq in HEQ.
  destruct st.
  assert (H := HEQ n).
  unfold Ir.Regfile.get in H.
  simpl in H. rewrite PeanoNat.Nat.eqb_refl in H. inv H.
Qed.

Theorem refines_regfile_eq:
  forall st1 st2 (HEQ:Ir.Regfile.eq st1 st2),
    refines_regfile st1 st2.
Proof.
  intros.
  unfold Ir.Regfile.eq in HEQ.
  unfold refines_regfile.
  intros.
  assert (HEQ' := HEQ regid).
  split.
  { split; intros; congruence. }
  { intros.
    eexists. rewrite HEQ' in HGET. split. eassumption.
    eapply refines_value_refl. }
Qed.

Theorem refines_regfile_trans:
  forall st1 st2 st3
         (HREF1:refines_regfile st1 st2)
         (HREF2:refines_regfile st2 st3),
    refines_regfile st1 st3.
Proof.
  intros.
  unfold refines_regfile in *.
  unfold_all_ands_H.
  intros.
  assert (H1 := HREF1 regid).
  assert (H2 := HREF2 regid).
  unfold_all_ands_H.

  split.
  {
    destruct H1. destruct H.
    split.
    { intros. apply H. apply H1. assumption. }
    { intros. apply H3. apply H4. assumption. }
  }
  intros.
  apply H2 in HGET.
  destruct HGET. destruct H3.
  apply H0 in H3. destruct H3. destruct H3.
  eexists. split. eassumption.
  eapply refines_value_trans. eassumption. ss.
Qed.

Theorem refines_stack_eq:
  forall st1 st2 (HEQ:Ir.Stack.eq st1 st2),
    refines_stack st1 st2.
Proof.
  intros.
  generalize dependent st1.
  induction st2.
  { intros. destruct st1. constructor.
    inv HEQ. }
  { intros.
    destruct st1. inv HEQ.
    inv HEQ.
    inv H2. inv H0.
    constructor.
    { split.  congruence. split. congruence.
      apply refines_regfile_eq. assumption. }
    eapply Forall2_implies.
    eapply H4.
    { intros.
      destruct x. destruct y. simpl in *.
      inv H0. inv H5. split. congruence. split. congruence.
      apply refines_regfile_eq. assumption.
    }
  }
Qed.

Theorem refines_stack_trans:
  forall st1 st2 st3
         (HREF1:refines_stack st1 st2)
         (HREF1:refines_stack st2 st3),
    refines_stack st1 st3.
Proof.
  intros.
  generalize dependent st2.
  generalize dependent st3.
  induction st1.
  { intros. inv HREF1. assumption. }
  { intros.
    destruct st2. inv HREF1.
    destruct st3. inv HREF0.
    inv HREF1. inv HREF0.
    unfold_all_ands_H.
    constructor.
    { split. congruence. split. congruence.
      eapply refines_regfile_trans. eassumption. ss. }
    { eapply Forall2_trans.
      intros.
      unfold_all_ands_H.
      split. congruence. split. congruence.
      eapply refines_regfile_trans. eassumption. ss.
      eassumption. ss.
    }
  }
Qed.

Theorem refines_state_eq:
  forall st1 st2 (HEQ:Ir.Config.eq st1 st2),
    refines_state st1 st2.
Proof.
  intros.
  inv HEQ.
  split.
  { rewrite H. eapply refines_memory_refl. }
  inv H0. split.
  apply refines_stack_eq. assumption.
  assumption.
Qed.

Theorem refines_refl:
  forall (pb:Ir.program_behavior), refines pb pb = true.
Proof.
  intros.
  destruct pb; unfold refines.
  - rewrite refines_trace_refl.
    rewrite refines_value_refl. reflexivity.
  - rewrite refines_trace_refl. reflexivity.
  - rewrite refines_trace_refl. reflexivity.
  - rewrite refines_trace_prefix_refl. reflexivity.
Qed.

Theorem refines_trace_none:
  forall (t1 t2:Ir.trace)
         (HREF:refines_trace t1 t2 = true),
    refines_trace (Ir.e_none::t1) t2 = true.
Proof. intros. unfold refines_trace in *.
       simpl. assumption.
Qed.

Theorem refines_trace_none2:
  forall (t1 t2:Ir.trace)
         (HREF:refines_trace t1 t2 = true),
    refines_trace t1 (Ir.e_none::t2) = true.
Proof. intros. unfold refines_trace in *.
       simpl. assumption.
Qed.

End Refinement.

End Ir.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import riscv.Utility.Monads.
Require Import riscv.Utility.MonadNotations.
Require Import riscv.Spec.Decode.
Require Import riscv.Spec.Machine.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Primitives.
Require Import riscv.Spec.MetricPrimitives.
Require Import Coq.Lists.List. Import ListNotations.
Require Export riscv.Platform.RiscvMachine.
Require Export riscv.Platform.MetricRiscvMachine.
Require Import riscv.Platform.MinimalNoMul.
Require Import riscv.Platform.MetricLogging.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.Tactics.
Import MetricRiscvMachine.

Local Open Scope Z_scope.
Local Open Scope bool_scope.

Section Riscv.
  Import List.
  Import free.

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

  Local Notation M := (free riscv_primitive primitive_result).

  Definition metrics_of(p: riscv_primitive): MetricLog -> MetricLog :=
    match p with
    | GetRegister a => id
    | SetRegister a b => id
    | LoadByte a b => addMetricLoads 1
    | LoadHalf a b => addMetricLoads 1
    | LoadWord a b => addMetricLoads 1
    | LoadDouble a b => addMetricLoads 1
    | StoreByte a b c => addMetricStores 1
    | StoreHalf a b c => addMetricStores 1
    | StoreWord a b c => addMetricStores 1
    | StoreDouble a b c => addMetricStores 1
    | MakeReservation a => id
    | ClearReservation a => id
    | CheckReservation a => id
    | GetCSRField f => id
    | SetCSRField f v => id
    | GetPrivMode => id
    | SetPrivMode m => id
    | Fence a b => id
    | GetPC => id
    | SetPC a => addMetricJumps 1
    | StartCycle => id
    | EndCycleNormal => addMetricInstructions 1
    | EndCycleEarly A => addMetricInstructions 1
    end.

  Definition interp_action p (m: MetricRiscvMachine) post :=
    interpret_action p m.(getMachine)
      (fun r mach => post r (mkMetricRiscvMachine mach (metrics_of p m.(getMetrics))))
      (fun _ => False).

  Arguments Memory.load_bytes: simpl never.
  Arguments Memory.store_bytes: simpl never.
  Arguments LittleEndian.combine: simpl never.

  Global Instance MetricMinimalNoMulPrimitivesParams: PrimitivesParams M MetricRiscvMachine :=
  {
    Primitives.mcomp_sat := @free.interp _ _ _ interp_action;
    Primitives.is_initial_register_value x := True;
    Primitives.nonmem_load := Primitives.nonmem_load (PrimitivesParams := MinimalNoMulPrimitivesParams);
    Primitives.nonmem_store := Primitives.nonmem_store (PrimitivesParams := MinimalNoMulPrimitivesParams);
    Primitives.valid_machine mach := no_M mach.(getMachine);
  }.

  Global Instance MinimalNoMulSatisfies_mcomp_sat_spec: mcomp_sat_spec MetricMinimalNoMulPrimitivesParams.
  Proof.
    split; cbv [mcomp_sat MetricMinimalNoMulPrimitivesParams Monad_free Bind Return].
    { symmetry. eapply interp_bind_ex_mid; intros.
      eapply MinimalNoMul.interpret_action_weaken_post; eauto; cbn; eauto. }
    { symmetry. rewrite interp_ret; eapply iff_refl. }
  Qed.

  Lemma interp_action_weaken_post a (post1 post2:_->_->Prop)
    (H: forall r s, post1 r s -> post2 r s) s
    : interp_action a s post1 -> interp_action a s post2.
  Proof. eapply MinimalNoMul.interpret_action_weaken_post; eauto. Qed.
  Lemma interp_action_appendonly' a s post :
    interp_action a s post ->
    interp_action a s (fun v s' => post v s' /\ endswith s'.(getLog) s.(getLog)).
  Proof. eapply MinimalNoMul.interpret_action_appendonly''; eauto. Qed.
  Lemma interp_action_total{memOk: map.ok Mem} a (s: MetricRiscvMachine) post :
    no_M s ->
    interp_action a s post ->
    exists v s, post v s /\ no_M s.
  Proof.
    intros H H1.
    unshelve epose proof (MinimalNoMul.interpret_action_total _ _ _ _ _ H1) as H0; eauto.
    destruct H0 as (?&?&[[]|(?&?)]); eauto.
  Qed.
  Lemma interp_action_preserves_valid{memOk: map.ok Mem} a s post :
    no_M s.(getMachine) ->
    interp_action a s post ->
    interp_action a s (fun v s' => post v s' /\ no_M s'.(getMachine)).
  Proof.
    intros D I.
    unshelve epose proof (MinimalNoMul.interpret_action_preserves_valid' _ _ _ D I) as H0; eauto.
  Qed.

  Global Instance MetricMinimalNoMulPrimitivesSane{memOk: map.ok Mem} :
    MetricPrimitivesSane MetricMinimalNoMulPrimitivesParams.
  Proof.
    split; cbv [mcomp_sane valid_machine MetricMinimalNoMulPrimitivesParams];
      intros *; intros D M;
      (split; [ exact (interp_action_total _ st _ D M)
              | eapply interp_action_preserves_valid; try eassumption;
                eapply interp_action_appendonly'; try eassumption ]).
  Qed.

  Global Instance MetricMinimalNoMulSatisfiesPrimitives{memOk: map.ok Mem}:
    MetricPrimitives MetricMinimalNoMulPrimitivesParams.
  Proof.
    split; try exact _.
    all : cbv [mcomp_sat spec_load spec_store MetricMinimalNoMulPrimitivesParams invalidateWrittenXAddrs].
    all: intros; destruct initialL;
      repeat match goal with
      | _ => progress subst
      | _ => Option.inversion_option
      | _ => progress cbn -[Memory.load_bytes Memory.store_bytes HList.tuple] in *
      | _ => progress cbv [id valid_register is_initial_register_value load store Memory.loadByte Memory.loadHalf Memory.loadWord Memory.loadDouble Memory.storeByte Memory.storeHalf Memory.storeWord Memory.storeDouble] in *
      | H : exists _, _ |- _ => destruct H
      | H : _ /\ _ |- _ => destruct H
      | |- _ => solve [ intuition (eauto || blia) ]
      | H : _ \/ _ |- _ => destruct H
      | |- context[match ?x with _ => _ end] => destruct x eqn:?
      | |- _ => progress unfold getReg, setReg
      | |-_ /\ _ => split
      end.
      (* setRegister *)
      destruct getMachine; eassumption.
  Qed.

End Riscv.