(** * Block labels and freshness frames

    Specialization of [VariableBinding] to block labels.
 *)
Require Import Helix.LLVMGen.Correctness_Prelude.
Require Import Helix.LLVMGen.VariableBinding.
Require Import Helix.LLVMGen.IdLemmas.
Require Import Helix.LLVMGen.StateCounters.

From Coq Require Import ZArith.

Import ListNotations.

Set Implicit Arguments.
Set Strict Implicit.

Opaque incBlockNamed.
Opaque incVoid.
Opaque incLocal.

Section BidBound.
  (* Block id has been generated by an earlier IRState *)
  Definition bid_bound (s : IRState) (bid: block_id) : Prop
    := state_bound block_count incBlockNamed s bid.

  (* If an id has been bound between two states.

     The primary use for this is in lemmas like, bid_bound_fresh,
     which let us know that since a id was bound between two states,
     it can not possibly collide with an id from an earlier state.
   *)
  Definition bid_bound_between (s1 s2 : IRState) (bid : block_id) : Prop
    := state_bound_between block_count incBlockNamed s1 s2 bid.

  Lemma incBlockNamed_count_gen_injective :
    count_gen_injective block_count incBlockNamed.
  Proof.
    unfold count_gen_injective.
    intros s1 s1' s2 s2' name1 name2 id1 id2 GEN1 GEN2 H1 H2 H3.

    Transparent incBlockNamed.
    inv GEN1.
    inv GEN2.
    Opaque incBlockNamed.
    cbn in *.

    intros CONTRA.
    apply Name_inj in CONTRA.
    apply valid_prefix_neq_differ in CONTRA; eauto.
  Qed.

  Lemma bid_bound_only_block_count :
    forall s lc vc γ bid,
      bid_bound s bid ->
      bid_bound {| block_count := block_count s; local_count := lc; void_count := vc; Γ := γ |} bid.
  Proof.
    intros s lc vc γ bid BOUND.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
  Qed.

  Lemma bid_bound_between_only_block_count_r :
    forall s1 s2 lc vc γ bid,
      bid_bound_between s1 s2 bid ->
      bid_bound_between s1 {| block_count := block_count s2; local_count := lc; void_count := vc; Γ := γ |} bid.
  Proof.
    intros s1 s2 lc vc γ bid BOUND.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
  Qed.

  Lemma bid_bound_mono : forall s1 s2 b,
      bid_bound s1 b ->
      (block_count s1 <= block_count s2)%nat ->
      bid_bound s2 b.
  Proof.
    intros; eapply state_bound_mono; eauto.
  Qed.

  Lemma bid_bound_fresh :
    forall (s1 s2 : IRState) (bid bid' : block_id),
      bid_bound s1 bid ->
      bid_bound_between s1 s2 bid' ->
      bid ≢ bid'.
  Proof.
    intros s1 s2 bid bid' BOUND BETWEEN.
    eapply state_bound_fresh; eauto.
    apply incBlockNamed_count_gen_injective.
  Qed.

  Lemma bid_bound_fresh' :
    forall (s1 s2 s3 : IRState) (bid bid' : block_id),
      bid_bound s1 bid ->
      (block_count s1 <= block_count s2)%nat ->
      bid_bound_between s2 s3 bid' ->
      bid ≢ bid'.
  Proof.
    intros s1 s2 s3 bid bid' BOUND COUNT BETWEEN.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    destruct BETWEEN as (n2 & sm' & sm'' & N_S2 & COUNT_Sm_ge & COUNT_Sm_lt & GEN_bid').

    inversion GEN_bid.
    destruct s1'. cbn in *.

    inversion GEN_bid'.
    intros CONTRA.
    apply Name_inj in CONTRA.
    apply valid_prefix_neq_differ in CONTRA; eauto.
    cbn.
    lia.
  Qed.

  Lemma bid_bound_bound_between :
    forall (s1 s2 : IRState) (bid : block_id),
      bid_bound s2 bid ->
      ~(bid_bound s1 bid) ->
      bid_bound_between s1 s2 bid.
  Proof.
    intros s1 s2 bid BOUND NOTBOUND.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound_between.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
    pose proof (NatUtil.lt_ge_dec (block_count s1') (block_count s1)) as [LT | GE].
    - (* If this is the case, I must have a contradiction, which would mean that
         bid_bound s1 bid... *)
      assert (bid_bound s1 bid).
      unfold bid_bound.
      exists n1. exists s1'. exists s1''.
      auto.
      contradiction.
    - auto.
  Qed.

  Lemma bid_bound_between_bound_earlier :
    forall s1 s2 bid,
      bid_bound_between s1 s2 bid ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid BOUND.
    unfold bid_bound_between, state_bound_between in BOUND.
    destruct BOUND as (name & s1' & s2' & PREF' & COUNT1 & COUNT2 & GEN).
    exists name. exists s1'. exists s2'.
    repeat (split; auto).
  Qed.

  Lemma not_bid_bound_incBlockNamed :
    forall s1 s2 n bid,
      is_correct_prefix n ->
      incBlockNamed n s1 ≡ inr (s2, bid) ->
      ~ (bid_bound s1 bid).
  Proof.
    intros s1 s2 n bid NEND GEN BOUND.
    unfold bid_bound, state_bound in BOUND.
    destruct BOUND as (n' & s' & s'' & NEND' & COUNT & GEN').
    Transparent incBlockNamed.
    unfold incBlockNamed in *.
    Opaque incBlockNamed.
    cbn in *.
    simp.
    apply valid_prefix_string_of_nat_forward in H1; auto.
    lia.
  Qed.

  Lemma bid_bound_name :
    forall s1 n x,
      is_correct_prefix n ->
      bid_bound s1 (Name (n @@ string_of_nat x)) ->
      (x < block_count s1)%nat.
  Proof.
    intros s1 s2 n PREF BOUND.
    unfold bid_bound, state_bound in BOUND.
    destruct BOUND as (name & s' & s'' & PREF' & COUNT & GEN).
    cbn in GEN.
    inv GEN.
    eapply valid_prefix_string_of_nat_forward in H1; eauto; lia.
  Qed.

  Lemma bid_bound_incBlockNamed :
    forall name s1 s2 bid,
      is_correct_prefix name ->
      incBlockNamed name s1 ≡ inr (s2, bid) ->
      bid_bound s2 bid.
  Proof.
    intros name s1 s2 bid ENDS INC.
    exists name. exists s1. exists s2.
    repeat (split; auto).
    erewrite incBlockNamed_block_count with (s':=s2); eauto.
  Qed.

  Lemma incBlockNamed_bound_between :
    forall s1 s2 n bid,
      is_correct_prefix n ->
      incBlockNamed n s1 ≡ inr (s2, bid) ->
      bid_bound_between s1 s2 bid.
  Proof.
    intros s1 s2 n bid NEND GEN.
    apply bid_bound_bound_between.
    - eapply bid_bound_incBlockNamed; eauto.
    - eapply not_bid_bound_incBlockNamed; eauto.
  Qed.

  (* TODO: typeclasses for these mono lemmas to make automation easier? *)
  Lemma bid_bound_incVoid_mono :
    forall s1 s2 bid bid',
      bid_bound s1 bid ->
      incVoid s1 ≡ inr (s2, bid') ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid bid' BOUND INC.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    intuition.
    apply incVoid_block_count in INC.
    lia.
  Qed.

  Lemma bid_bound_incLocal_mono :
    forall s1 s2 bid bid',
      bid_bound s1 bid ->
      incLocal s1 ≡ inr (s2, bid') ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid bid' BOUND INC.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    intuition.
    apply incLocal_block_count in INC.
    lia.
  Qed.

  Lemma bid_bound_between_sep :
    ∀ (bid : block_id) s1 s2 s3,
      bid_bound_between s1 s2 bid → ¬ (bid_bound_between s2 s3 bid).
  Proof.
    intros. cbn in H. red in H.
    intro.
    assert (((bid ≡ bid) -> False) -> False). auto. apply H1. clear H1.
    eapply bid_bound_fresh; eauto.
    destruct H as (? & ? & ? & ? & ? & ? & ?).
    red. red. exists x. exists x0, x1. split; eauto.
  Qed.

  Lemma not_bid_bound_between :
    forall bid s1 s2, bid_bound s1 bid -> not (bid_bound_between s1 s2 bid).
  Proof.
    repeat intro.
    assert (((bid ≡ bid) -> False) -> False). auto. apply H1. clear H1.
    eapply bid_bound_fresh; eauto.
  Qed.

  Lemma bid_bound_newLocalVar_mono :
    forall s1 s2 bid bid' p x,
      bid_bound s1 bid ->
      newLocalVar p x s1 ≡ inr (s2, bid') ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid bid' * BOUND INC.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    intuition.
    apply newLocalVar_block_count in INC.
    lia.
  Qed.

  Lemma bid_bound_incBlock_neq:
    forall i i' bid bid',
      incBlock i ≡ inr (i', bid) ->
      bid_bound i bid' ->
      bid ≢ bid'.
  Proof.
    intros.
    destruct (rel_dec_p bid bid'); auto.
    subst; exfalso.
    cbn in H; inv H.
    destruct H0 as (? & ? & ? & ? & ? & ?).
    cbn in *.
    inv H1.
    apply valid_prefix_string_of_nat_forward in H4 as [? ?]; subst; cbn in *; auto.
    lia.
  Qed.

 Lemma bid_bound_incBlockNamed_mono :
    forall name s1 s2 bid bid',
      bid_bound s1 bid ->
      incBlockNamed name s1 ≡ inr (s2, bid') ->
      bid_bound s2 bid.
  Proof.
    intros name s1 s2 bid bid' BOUND INC.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    intuition.
    apply incBlockNamed_block_count in INC.
    lia.
  Qed.

  Lemma bid_bound_genNExpr_mono :
    forall s1 s2 bid nexp e c,
      bid_bound s1 bid ->
      genNExpr nexp s1 ≡ inr (s2, (e, c)) ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid nexp e c BOUND GEN.
    apply genNExpr_block_count in GEN.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
    rewrite GEN.
    auto.
  Qed.

  Lemma bid_bound_genMExpr_mono :
    forall s1 s2 bid mexp e c,
      bid_bound s1 bid ->
      genMExpr mexp s1 ≡ inr (s2, (e, c)) ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid mexp e c BOUND GEN.
    apply genMExpr_block_count in GEN.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
    rewrite GEN.
    auto.
  Qed.

  Lemma bid_bound_genAExpr_mono :
    forall s1 s2 bid aexp e c,
      bid_bound s1 bid ->
      genAExpr aexp s1 ≡ inr (s2, (e, c)) ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid nexp e c BOUND GEN.
    apply genAExpr_block_count in GEN.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
    rewrite GEN.
    auto.
  Qed.

  Lemma bid_bound_genIR_mono :
    forall s1 s2 bid op nextblock b bks,
      bid_bound s1 bid ->
      genIR op nextblock s1 ≡ inr (s2, (b, bks)) ->
      bid_bound s2 bid.
  Proof.
    intros s1 s2 bid op nextblock b bks BOUND GEN.
    apply genIR_block_count in GEN.
    destruct BOUND as (n1 & s1' & s1'' & N_S1 & COUNT_S1 & GEN_bid).
    unfold bid_bound.
    exists n1. exists s1'. exists s1''.
    repeat (split; auto).
    lia.
  Qed.

End BidBound.

Hint Resolve incBlockNamed_count_gen_injective : CountGenInj.

Ltac solve_bid_bound :=
  repeat
    match goal with
    | H: incBlockNamed ?msg ?s1 ≡ inr (?s2, ?bid) |-
      bid_bound ?s2 ?bid =>
      eapply bid_bound_incBlockNamed; try eapply H; solve_prefix
    | H: incBlock ?s1 ≡ inr (?s2, ?bid) |-
      bid_bound ?s2 ?bid =>
      eapply bid_bound_incBlockNamed; try eapply H; solve_prefix

    | H: incBlockNamed ?msg ?s1 ≡ inr (_, ?bid) |-
      ~(bid_bound ?s1 ?bid) =>
      eapply gen_not_state_bound; try eapply H; solve_prefix
    | H: incBlock ?s1 ≡ inr (_, ?bid) |-
      ~(bid_bound ?s1 ?bid) =>
      eapply gen_not_state_bound; try eapply H; solve_prefix

    (* Monotonicity *)
    | |- bid_bound {| block_count := block_count ?s; local_count := ?lc; void_count := ?vc; Γ := ?γ |} ?bid =>
      apply bid_bound_only_block_count

    | H: incVoid ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_incVoid_mono; try eapply H
    | H: incLocal ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_incLocal_mono; try eapply H
    | H: incBlockNamed _ ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_incBlockNamed_mono; try eapply H
    | H: incBlock ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_incBlockNamed_mono; try eapply H
    | H: genNExpr ?n ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_genNExpr_mono; try eapply H
    | H: genMExpr ?n ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_genMExpr_mono; try eapply H
    | H: genAExpr ?n ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_genAExpr_mono; try eapply H
    | H: genIR ?op ?n ?s1 ≡ inr (?s2, _) |-
      bid_bound ?s2 _ =>
      eapply bid_bound_genIR_mono; try eapply H
    | H : resolve_PVar _ _ ≡ inr _ |- _ =>
      apply resolve_PVar_state in H; subst
    end.

Ltac invert_err2errs :=
  match goal with
  | H : ErrorWithState.err2errS (MInt64asNT.from_nat ?n) ?s1 ≡ inr (?s2, _) |- _ =>
    destruct (MInt64asNT.from_nat n); inversion H; subst
  | H : ErrorWithState.err2errS (inl _) _ ≡ inr _ |- _ =>
    inversion H
  | H : ErrorWithState.err2errS (inr _) _ ≡ inr _ |- _ =>
    inversion H; subst
  end.

Ltac block_count_replace :=
  repeat match goal with
         | H : incVoid ?s1 ≡ inr (?s2, ?bid) |- _
           => apply incVoid_block_count in H; cbn in H
         | H : incBlockNamed ?name ?s1 ≡ inr (?s2, ?bid) |- _
           => apply incBlockNamed_block_count in H; cbn in H
         | H : incBlock ?s1 ≡ inr (?s2, ?bid) |- _
           => apply incBlockNamed_block_count in H; cbn in H
         | H : incLocal ?s1 ≡ inr (?s2, ?bid) |- _
           => apply incLocal_block_count in H; cbn in H
         | H: genNExpr ?n ?s1 ≡ inr (?s2, _) |- _
           => eapply genNExpr_block_count in H; cbn in H
         | H: genMExpr ?n ?s1 ≡ inr (?s2, _) |- _
           => eapply genMExpr_block_count in H; cbn in H
         | H: genAExpr ?n ?s1 ≡ inr (?s2, _) |- _
           => eapply genAExpr_block_count in H; cbn in H
         | H: genIR ?op ?nextblock ?s1 ≡ inr (?s2, _) |- _
           => eapply genIR_block_count in H; cbn in H
         end.

Ltac solve_block_count :=
  match goal with
  | |- (block_count ?s1 <= block_count ?s2)%nat
    => block_count_replace; cbn; lia
  | |- (block_count ?s1 >= block_count ?s2)%nat
    => block_count_replace; cbn; lia
  end.

Ltac solve_not_bid_bound :=
  match goal with
  | H: incBlockNamed ?name ?s1 ≡ inr (?s2, ?bid) |-
    ~(bid_bound ?s3 ?bid) =>
    eapply (not_id_bound_gen_mono incBlockNamed_count_gen_injective); [eassumption |..]
  | H: incBlock ?s1 ≡ inr (?s2, ?bid) |-
    ~(bid_bound ?s3 ?bid) =>
    eapply (not_id_bound_gen_mono incBlockNamed_count_gen_injective); [eassumption |..]
  end.

Ltac solve_count_gen_injective :=
  match goal with
  | |- count_gen_injective _ _
    => eauto with CountGenInj
  end.

Ltac big_solve :=
  repeat
    (try invert_err2errs;
     try solve_block_count;
     try solve_not_bid_bound;
     try solve_prefix;
     try solve_count_gen_injective;
     try match goal with
         | |- Forall _ (?x::?xs) =>
           apply Forall_cons; eauto
         | |- bid_bound_between ?s1 ?s2 ?bid =>
           eapply bid_bound_bound_between; solve_bid_bound
         | |- bid_bound_between ?s1 ?s2 ?bid ∨ ?bid ≡ ?nextblock =>
           try auto; try left
         end).

Lemma bid_bound_genIR_entry :
  forall op s1 s2 nextblock bid bks,
    genIR op nextblock s1 ≡ inr (s2, (bid, bks)) ->
    bid_bound s2 bid.
Proof.
  induction op;
    intros s1 s2 nextblock b bks GEN.
  10: {
    cbn in GEN; simp.
    eapply IHop1; eauto.
  }
  all: cbn in GEN; simp; solve_bid_bound.
Qed.

Section Inputs.

  (* Lemmas about the inputs to blocks *)
  Lemma inputs_bound_between :
    forall (op : DSHOperator) (s1 s2 : IRState) (nextblock op_entry : block_id) (bk_op : list (LLVMAst.block typ)),
      genIR op nextblock s1 ≡ inr (s2, (op_entry, bk_op)) ->
      Forall (bid_bound_between s1 s2) (inputs (convert_typ [ ] bk_op)).
  Proof.
    induction op;
      intros s1 s2 nextblock op_entry bk_op GEN;
      pose proof GEN as BACKUP_GEN;
      cbn in GEN; simp; cbn.
    all: try (solve [big_solve]).
    - big_solve; cbn in *; try solve_not_bid_bound; cbn in *; big_solve.

      rewrite convert_typ_ocfg_app.

      (* TODO: clean this up *)
      unfold tfmap.
      rewrite map_app.

      apply Forall_app.
      split.
      + eapply all_state_bound_between_shrink.
        eapply IHop; eauto.
        solve_block_count.
        solve_block_count.
      + cbn.
        rewrite List.Forall_cons_iff.
        split.
        2: { apply List.Forall_nil. }
        big_solve.
    - apply Forall_cons.
      + big_solve.
      + eapply Forall_impl.
        apply bid_bound_between_only_block_count_r.
        eapply all_state_bound_between_shrink.
        eapply IHop; eapply Heqs0.
        cbn. auto.
        block_count_replace.
        lia.
    - rewrite add_comment_inputs_typ.
      rewrite convert_typ_ocfg_app.

      unfold inputs.
      setoid_rewrite map_app.

      apply Forall_app.
      split.
      + eapply all_state_bound_between_shrink.
        eapply IHop1; eauto.
        all: solve_block_count.
      + eapply all_state_bound_between_shrink.
        eapply IHop2; eauto.
        all: solve_block_count.
  Qed.

  Lemma inputs_not_earlier_bound :
    forall (op : DSHOperator) (s1 s2 s3 : IRState) (bid nextblock op_entry : block_id) (bk_op : list (LLVMAst.block typ)),
      bid_bound s1 bid ->
      (block_count s1 <= block_count s2)%nat ->
      genIR op nextblock s2 ≡ inr (s3, (op_entry, bk_op)) ->
      Forall (fun x => x ≢ bid) (inputs (convert_typ [ ] bk_op)).
  Proof.
    intros op s1 s2 s3 bid nextblock op_entry bk_op BOUND COUNT GEN.
    pose proof (inputs_bound_between _ _ _ GEN) as BETWEEN.
    apply Forall_forall.
    intros x H.
    assert (bid ≢ x) as BIDX; auto.
    { eapply state_bound_fresh'.
      - apply incBlockNamed_count_gen_injective.
      - assert (bid_bound_between s2 s3 x).
        eapply Forall_forall. apply BETWEEN.
        auto.
        apply BOUND.
      - apply COUNT.
      - eapply Forall_forall.
        apply BETWEEN.
        auto.
    }
  Qed.

  (* TODO: may not actually needs this. *)
  Lemma inputs_nextblock :
    forall (op : DSHOperator) (s1 s2 s3 : IRState) (nextblock op_entry : block_id) (bk_op : list (LLVMAst.block typ)),
      bid_bound s1 nextblock ->
      (block_count s1 <= block_count s2)%nat ->
      genIR op nextblock s2 ≡ inr (s3, (op_entry, bk_op)) ->
      Forall (fun bid => bid ≢ nextblock) (inputs (convert_typ [ ] bk_op)).
  Proof.
    intros op s1 s2 s3 nextblock op_entry bk_op BOUND COUNT GEN.
    eapply inputs_not_earlier_bound; eauto.
  Qed.
End Inputs.

Section Outputs.
  Lemma entry_bound_between :
    forall (op : DSHOperator) (s1 s2 : IRState) (nextblock op_entry : block_id) (bk_op : list (LLVMAst.block typ)),
      genIR op nextblock s1 ≡ inr (s2, (op_entry, bk_op)) ->
      bid_bound_between s1 s2 op_entry.
  Proof.
    induction op;
      intros s1 s2 nextblock op_entry bk_op GEN;
      pose proof GEN as BACKUP_GEN;
      cbn in GEN; simp; cbn.
    all: try (solve [big_solve]).

    apply IHop1 in Heqs2.
    eapply state_bound_between_shrink; eauto.
    solve_block_count.
  Qed.

Opaque incBlockNamed.
Opaque incVoid.
Opaque incLocal.

  Lemma outputs_bound_between :
    forall (op : DSHOperator) (s1 s2 : IRState) (nextblock op_entry : block_id) (bk_op : list (LLVMAst.block typ)),
      genIR op nextblock s1 ≡ inr (s2, (op_entry, bk_op)) ->
      Forall (fun bid => bid_bound_between s1 s2 bid \/ bid ≡ nextblock) (outputs (convert_typ [ ] bk_op)).
  Proof.
    induction op;
      intros s1 s2 nextblock op_entry bk_op GEN;
      pose proof GEN as BACKUP_GEN;
      cbn in GEN; simp; cbn.
    all: try (solve [big_solve]).
    - cbn.
      clear BACKUP_GEN.
      cbn* in *; simp.
      rename i into s1, i6 into s2.
      rewrite convert_typ_ocfg_app.
      rewrite fold_left_app.
      cbn.
      clean_goal.

      assert (bid_bound_between s1 s2 b2) as B2.
      { eapply incBlockNamed_bound_between in Heqs3.
        eapply state_bound_between_shrink; eauto.
        solve_block_count.
        solve_block_count.
        reflexivity.
      }

      assert (bid_bound_between s1 s2 b0) as B0.
      { eapply entry_bound_between in Heqs2.
        eapply state_bound_between_shrink; eauto.
        solve_block_count.
        solve_block_count.
      }

      rewrite outputs_acc.
      (* Can probably prove stuff for b2 and nextblock to save space *)
      rewrite Forall_app.
      split.
      rewrite Forall_app.
      split.

      + auto.
      + epose proof (IHop _ _ _ _ _ Heqs2).

        (* TODO: may want to pull this out as a lemma *)
        eapply Forall_impl; [| eapply H].
        intros bid BOUND.
        destruct BOUND.
        * left.
          eapply state_bound_between_shrink; eauto.
          solve_block_count.
          solve_block_count.
        * left; subst.
          eapply incBlockNamed_bound_between in Heqs1.
          eapply state_bound_between_shrink; eauto.
          solve_block_count.
          reflexivity.
      + auto.
    -
      (* Should show me that the outputs of l (genIR op result) are all bound between s1 and i *)
      epose proof (IHop _ _ _ _ _ Heqs0).
      cbn in H.
      unfold outputs in H.

      cbn in Heqs; inversion Heqs; subst.

      rewrite outputs_acc.
      apply Forall_app.
      split.
      + apply Forall_cons; [|apply Forall_nil].
        cbn in Heqs.
        left.
        eapply entry_bound_between in Heqs0.
        eapply state_bound_between_shrink; eauto.
        cbn. solve_block_count.
      +
        (* TODO: may want to pull this out as a lemma *)
        assert (forall bid, bid_bound_between s1 i bid \/ bid ≡ nextblock -> bid_bound_between s1 i1 bid \/ bid ≡ nextblock) as WEAKEN.
        { intros bid BOUND.
          destruct BOUND.
          - left.
            eapply state_bound_between_shrink; eauto.
            solve_block_count.
          - right; auto.
        }

        eapply Forall_impl.
        * eapply WEAKEN.
        * eauto.
    - rewrite add_comment_outputs_typ.
      rewrite convert_typ_ocfg_app.
      setoid_rewrite outputs_app.
      apply Forall_app.
      split.
      +
        (* TODO: may want to pull this out as a lemma *)
        assert (forall bid, bid_bound_between i s2 bid \/ bid ≡ b -> bid_bound_between s1 s2 bid \/ bid ≡ nextblock) as WEAKEN.
        { intros bid BOUND.
          destruct BOUND.
          - left.
            eapply state_bound_between_shrink; eauto.
            solve_block_count.
          - left.
            eapply entry_bound_between in Heqs0.
            subst.
            eapply state_bound_between_shrink; eauto.
            solve_block_count.
        }

        eapply Forall_impl.
        * eapply WEAKEN.
        * eauto.
      +
        (* TODO: may want to pull this out as a lemma *)
        assert (forall bid, bid_bound_between s1 i bid \/ bid ≡ nextblock -> bid_bound_between s1 s2 bid \/ bid ≡ nextblock) as WEAKEN.
        { intros bid BOUND.
          destruct BOUND.
          - left.
            eapply state_bound_between_shrink; eauto.
            solve_block_count.
          - right; auto.
        }

        eapply Forall_impl.
        * eapply WEAKEN.
        * eauto.
  Qed.
End Outputs.

Ltac get_block_count_hyps :=
  repeat
    match goal with
    (* | H: incBlockNamed ?n ?s1 ≡ inr (?s2, _) |- _ => *)
      (* apply incBlockNamed_block_count in H *)
    (* | H: incLocalNamed ?n ?s1 ≡ inr (?s2, _) |- _ => *)
    (* apply incLocalNamed_block_count in H *)
    | H: resolve_PVar _ _ ≡ _ |- _ => apply resolve_PVar_state in H
    | H: incVoid ?s1 ≡ inr (?s2, _) |- _ =>
      apply incVoid_block_count in H
    | H: incLocal ?s1 ≡ inr (?s2, _) |- _ =>
      apply incLocal_block_count in H
    | H : genNExpr _ _ ≡ inr _ |- _ =>
      apply genNExpr_local_count in H
    | H: genMExpr ?m ?s1 ≡ inr (?s2, _) |- _ =>
      apply genMExpr_block_count in H
    | H: genAExpr ?a ?s1 ≡ inr (?s2, _) |- _ =>
      apply genAExpr_block_count in H
    | H: genIR ?op ?id ?s1 ≡ inr (?s2, _) |- _ =>
      apply genIR_block_count in H
    end.

(* This establishes that the generated code does not contain any two blocks with the same id. *)
Transparent incBlockNamed.
Lemma generates_wf_ocfg_bids :
  ∀ (op : DSHOperator) (s1 s2 : IRState) (nextblock b : block_id) (bk_op : list (LLVMAst.block typ)),
    bid_bound s1 nextblock ->
    genIR op nextblock s1 ≡ inr (s2, (b, bk_op)) →
    wf_ocfg_bid bk_op.
Proof.
  induction op; intros * NEXT GEN.
  - cbn* in *; simp; cbn.
    eapply wf_ocfg_bid_singleton.
  - cbn* in *; simp; cbn in *.
    eapply wf_ocfg_bid_singleton.
  - destruct NEXT as (? & [?bid ? ? ?] & [?bid ? ? ?] & ? & ? & ?).
    cbn* in *.
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    get_block_count_hyps; subst; cbn in *.
    repeat match goal with
           | h: IRState |- _ => destruct h as [?bid ? ? ?]
           end; cbn in *.
    subst.
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_singleton.
  - destruct NEXT as (? & [?bid ? ? ?] & [?bid ? ? ?] & ? & ? & ?).
    cbn* in *.
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    get_block_count_hyps; subst; cbn in *.
    repeat match goal with
           | h: IRState |- _ => destruct h as [?bid ? ? ?]
           end; cbn in *.
    subst.
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_singleton.

  - destruct NEXT as (? & [?bid ? ? ?] & [?bid ? ? ?] & ? & ? & ?).
    cbn* in *.
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    get_block_count_hyps; subst; cbn in *.
    repeat match goal with
           | h: IRState |- _ => destruct h as [?bid ? ? ?]
           end; cbn in *.
    subst.
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_singleton.

  - destruct NEXT as (? & [?bid ? ? ?] & [?bid ? ? ?] & ? & ? & ?).
    cbn* in *.
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    get_block_count_hyps; subst; cbn in *.
    repeat match goal with
           | h: IRState |- _ => destruct h as [?bid ? ? ?]
           end; cbn in *.
    subst.
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition;
        match goal with
        | h: Name _ ≡ Name _ |- _ => apply Name_inj in h; inv h
        end.
    }
    eapply wf_ocfg_bid_singleton.

  - cbn* in *.
    simp.
    clean_goal.

    pose proof Heqs1.
    eapply inputs_bound_between in H.

    apply IHop in Heqs1.
    2:{
      eapply bid_bound_incBlockNamed with (name := "Loop_lcont")
                                         (s1 := {|
                                             block_count := (block_count i);
                                             local_count := S (local_count i);
                                             void_count := void_count i;
                                             Γ := (ID_Local (Name ("Loop_i" @@ string_of_nat (local_count i))), TYPE_I 64%N) :: Γ i |}); reflexivity.
    }
    clear IHop; clean_goal.
    cbn in *.
    simp.
    cbn in *.
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition.
      match goal with
      | h: Name _ ≡ Name _ |- _ =>
        apply Name_inj in h;
          first [now inv h | apply valid_prefix_string_of_nat_forward in h as [abs _]; intuition]
      end.

      rewrite map_app in H1.
      eapply in_app_or in H1.
      destruct H1.
      - rewrite inputs_convert_typ in H.

        eapply Forall_forall in H0; eauto.
        eapply bid_bound_between_bound_earlier in H0.

        eapply bid_bound_name in H0; [lia | solve_prefix].
      - cbn in H0. destruct H0; inversion H0.
    }

    (* TODO: Automate this... *)
    eapply wf_ocfg_bid_cons'.
    { cbn.
      intuition.

      rewrite inputs_app in H0.
      eapply in_app_or in H0.
      destruct H0.
      - rewrite inputs_convert_typ in H.

        eapply Forall_forall in H0; eauto.
        eapply bid_bound_between_bound_earlier in H0.

        eapply bid_bound_name in H0; [lia | solve_prefix].
      - cbn in H0. destruct H0; inversion H0.
    }

    unfold wf_ocfg_bid.
    rewrite inputs_app. cbn.
    apply Coqlib.list_norepet_append; eauto.

    { constructor.
      intros CONTRA; inv CONTRA.
      constructor.
    }

    unfold Coqlib.list_disjoint.
    intros x y H0 H1.

    cbn in H1. destruct H1; inv H1.

    rewrite inputs_convert_typ in H.

    eapply Forall_forall in H0; eauto.

    destruct H0 as (name & s' & s'' & PREF & COUNT & GEN).
    cbn in GEN; inv GEN.
    intros NAME. inv H1.
    rename H4 into NAME.
    apply Name_inj in NAME.
    eapply valid_prefix_string_of_nat_forward in NAME; eauto.
    destruct NAME; subst.
    lia.

  - rename nextblock into entryblock, b into nextblock.
    simpl in GEN.
    break_match_hyp; [simp |].
    inv GEN.
    break_match_hyp; [simp |].
    destruct s1 as [bid1  lid1  void1  Γ1]; cbn in *.
    destruct NEXT as (? & [?bid ? ? ?] & [?bid ? ? ?] & ? & ? & ?); cbn in *.
    inv H1; cbn in *.
    destruct p as [s' [bblock bcode]].
    destruct s' as [bid2  lid2  void2  Γ2]; cbn in *.
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    cbn* in *; simp; cbn in *.
    generalize Heqs0; intros GEN.
    apply genIR_block_count in Heqs0.
    cbn in *.
    assert (BOUND:bid_bound
                    {|
                      block_count := bid1;
                      local_count := S lid1;
                      void_count := void1;
                      Γ := (ID_Local (Name ("a" @@ string_of_nat lid1)),
                            TYPE_Pointer (TYPE_Array (Z.to_N (Int64.intval size)) TYPE_Double)) :: Γ1 |}
                    (Name (x @@ string_of_nat bid))).
    {
      do 2 red.
      exists x.
      exists {|
          block_count := bid;
          local_count := S lid1;
          void_count := void1;
          Γ := (ID_Local (Name ("a" @@ string_of_nat lid1)),
                TYPE_Pointer (TYPE_Array (Z.to_N (Int64.intval size)) TYPE_Double)) :: Γ1 |}.
      eexists; repeat split; cbn; eauto.
    }
    generalize GEN; intros WF;
    apply IHop in WF; auto; clear IHop.
    apply wf_ocfg_bid_cons'; auto; clear WF.
    cbn.
    cbn in *; intros abs; apply ListUtil.in_map_elim in abs as (? & ? & ?).
    cbn in *.
    clean_goal.

    eapply inputs_bound_between in GEN.
    rewrite inputs_convert_typ in GEN.

    assert (In (blk_id x0) (map blk_id bcode)).
    { apply in_map; eauto. }

    eapply Forall_forall in GEN; eauto.
    rewrite <- H2 in GEN.
    destruct GEN as (n & s' & s'' & PREF & COUNT1 & COUNT2 & GEN').
    cbn in *.

    inv GEN'.
    eapply valid_prefix_string_of_nat_forward in H6; eauto.
    destruct H6; subst.
    lia.
  - rename nextblock into entryblock, b into nextblock.
    simpl in GEN.
    break_match_hyp; [simp |].
    inv GEN.
    break_match_hyp; [simp |].
    destruct s1 as [bid1  lid1  void1  Γ1]; cbn in *.
    destruct NEXT as (? & [?bid ? ? ?] & [?bid ? ? ?] & ? & ? & ?); cbn in *.
    inv H1; cbn in *.
    destruct p as [s' [bblock bcode]].
    destruct s' as [bid2  lid2  void2  Γ2]; cbn in *.
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    cbn* in *; simp; cbn in *.
    generalize Heqs0; intros GEN.
    apply resolve_PVar_state in Heqs0.
    inv Heqs0.
    cbn in *.

    apply wf_ocfg_bid_cons'; cbn.
    { intros CONTRA.
      destruct CONTRA; inv H1.
      inv H2.
      inv H2.
      inv H1.
      auto.
    }

    apply wf_ocfg_bid_cons'; cbn.
    { intros CONTRA.
      destruct CONTRA; inv H1.
      inv H2.
      inv H2.
    }

    apply wf_ocfg_bid_cons'; cbn.
    { intros CONTRA.
      destruct CONTRA; auto.

      rename H1 into NAME.
      eapply Name_inj in NAME.
      eapply valid_prefix_string_of_nat_forward in NAME; eauto.
      destruct NAME. inv H2.
    }

    unfold wf_ocfg_bid.
    cbn.
    constructor.
    auto.
    constructor.
  - rename nextblock into entryblock, b into nextblock.
    simpl in GEN.
    break_match_hyp; [simp |].
    inv GEN.
    break_match_hyp; [simp |].
    destruct s1 as [bid1  lid1  void1  Γ1]; cbn in *.
    destruct NEXT as (? & s' & s'' & ? & ? & ?); cbn in *.
    inv H1; cbn in *.
    destruct p as [s''' [bblock bcode]].
    simp.
    cbn* in *; simp; cbn in *.
    clean_goal.
    cbn* in *; simp; cbn in *.
    generalize Heqs0; intros GEN.
    apply genIR_block_count in Heqs0.
    cbn in *.

    unfold wf_ocfg_bid.
    unfold add_comment; cbn.
    break_match_goal.
    constructor.
    cbn.

    pose proof Heqs1 as OP1BOUND; eapply inputs_bound_between in OP1BOUND.
    pose proof GEN as OP2BOUND; eapply inputs_bound_between in OP2BOUND.

    eapply IHop1 in Heqs1.
    eapply IHop2 in GEN.

    change (blk_id b :: map blk_id l0) with (map blk_id (b :: l0)).
    rewrite <- Heql0.

    rewrite map_app.
    rewrite inputs_convert_typ in *.

    {  apply Coqlib.list_norepet_append_commut.
       unfold wf_ocfg_bid in *.
       eapply state_bound_between_disjoint_norepet; eauto.
       apply incBlockNamed_count_gen_injective.
    }

    { exists x. do 2 eexists.
      repeat split; eauto.
    }

    { eapply bid_bound_genIR_entry; eauto.
    }
Qed.

Lemma genWhileLoop_entry_in_scope : forall op b s1 s2 entry_body bodyV,
    genIR op b s1 ≡ inr (s2, (entry_body, bodyV)) ->
    In entry_body (inputs bodyV).
Proof.
  induction op; intros *; try (cbn; intros GEN; clear -GEN; simp; cbn; auto; fail).
  cbn; intros GEN; simp.
  rewrite add_comment_inputs, inputs_app.
  apply ListUtil.in_appl; eauto.
Qed.


Require Import VST.msl.Axioms.
Require Import compcert.common.Memory.
Require Import VST.sepcomp.semantics.

Module FSem.
Record t M TM := mk {
    F : forall C, @CoreSemantics C M -> @CoreSemantics C TM
  ; E : TM -> M
  ; P : TM -> TM -> Prop
  ; step  : forall C sem c m c' m',
            @corestep _ _ (F C sem) c m c' m' =
           (@corestep _ _ sem c (E m) c' (E m') /\ P m m')
(*  ; init : forall C sem n m m' v vl q,
     initial_core (F C sem) n m q m' v vl <->
     initial_core sem n (E m) q (E m') v vl*) (* Should this really be true? *)
  ; atext  : forall C sem c m,
      at_external (F C sem) c m = at_external sem c (E m)
  ; aftext : forall C sem ret c m,
      after_external (F C sem) ret c m = after_external sem ret c (E m)
  ; halted : forall C sem, halted (F C sem) = halted sem
  }.
End FSem.

Module IdFSem.
Program Definition t M : FSem.t M M :=
  FSem.mk M M (fun C sem => sem) id (fun _ _ => True) _ _ _ _.
Next Obligation.
apply prop_ext.
split; intros H.
split; auto.
destruct H; auto.
Qed.
(*Next Obligation.
intuition.
Qed.*)
End IdFSem.

Require Import VST.veric.juicy_mem.
Require Import VST.veric.juicy_extspec.
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.own.

Module JuicyFSem.
Program Definition t : FSem.t mem juicy_mem :=
  FSem.mk mem juicy_mem (@juicy_core_sem) m_dry
    (fun jm jm' => resource_decay (Mem.nextblock (m_dry jm)) (m_phi jm) (m_phi jm') /\
       ageable.level jm = S (ageable.level jm') /\
       ghost_of (m_phi jm') = ghost_approx jm' (ghost_of (m_phi jm)))
    _ _ _ _.
End JuicyFSem.


(* Other library imports *)
Add LoadPath "../libs".
Add LoadPath "../libs/CompCert-Toolkit".
Require Import Tactics.
Require Import Bits.
Require Import Consider.

Require Import Flocq.Appli.Fappli_IEEE_bits.

Require Import Coqlib.
Require Import Axioms.

(* Illvm imports *)
Require Import Utility.
Require Import IllvmAST.
Require Import TargetData.

(* ---------------------------------------------------------------------- *)
(* Run-time tags and values *)

(* Tags that a run-time value can have *)
Inductive rt_tag :=
| RT_int : forall sz, (sz < MAX_I_BITS)%nat -> Word.int sz -> rt_tag
| RT_fun : lab -> rt_tag. (* We can get rid of this ... *)

(* Floats, doubles and pointers are just bit-vectors. *)
Definition RT_float (f:float_t) := RT_int 31 lt_31_MAX_I_BITS (Word.repr (Word.unsigned f)).
Definition RT_double (d:double_t) := RT_int 63 lt_63_MAX_I_BITS (Word.repr (Word.unsigned d)).
Definition RT_ptr i := RT_int WORDSIZE_BITS lt_63_MAX_I_BITS i.

(* Run-time value, note that its flat, i.e., the typ's give it structure. *)
Definition rt_val := list rt_tag.

(* Convert a tag into a run-time value *)
Definition tag2rt (tag:rt_tag) := tag :: nil.

(* Size of a tag in bytes *)
Definition size_rttag (lo:layout) (tag:rt_tag) : Z :=
  match tag with
    | RT_int sz pf _ => size_ftyp lo (Ftyp_int sz pf)
    | RT_fun _ => size_ftyp lo (Ftyp_fun nil nil None)
  end.
Definition size_rttag_nat (lo:layout) (tag:rt_tag) : nat :=
  nat_of_Z (size_rttag lo tag).

(* Random bit-pattern generator. *)
Parameter UNDEF_STREAM : unit -> Z.

Fixpoint undef_ls ts :=
  match ts with
    | nil => nil
    | t::ts =>
      match t with
        | Ftyp_float => (RT_float (Word.repr (UNDEF_STREAM tt)) :: undef_ls ts)
        | Ftyp_double => (RT_double (Word.repr (UNDEF_STREAM tt)) :: undef_ls ts)
        | Ftyp_int sz pf => (RT_int sz pf (Word.repr (UNDEF_STREAM tt)) :: undef_ls ts)
        | Ftyp_ptr _ _ => (RT_ptr (Word.repr (UNDEF_STREAM tt)) :: undef_ls ts)
        | Ftyp_fun _ _ _ => (RT_fun (Word.repr (UNDEF_STREAM tt)) :: undef_ls ts)
        | Ftyp_ptrU _ _ => (RT_ptr (Word.repr (UNDEF_STREAM tt)) :: undef_ls ts)
      end
  end.

(* Convert a constant to rt_val *)
Definition const2rtv (c:const) : rt_val :=
  match c with
    | Const_null => (RT_ptr (Word.repr 0) :: nil)
    | Const_nullU => (RT_ptr (Word.repr 0) :: nil)
    | Const_float f => (RT_float f :: nil)
    | Const_double d => (RT_double d :: nil)
    | Const_int sz pf i => (RT_int sz pf i :: nil)
    | Const_fun l => (RT_fun l :: nil)
    | Const_undef ts => undef_ls ts
    | Const_baddr l1 l2 => (RT_ptr l2 :: nil)
    (* | Const_struct ls => List.fold_left (fun acc c => const2rtv c ++ acc) ls nil *)
  end.

Section OP.
  Variable o : operand.
  Variable env : Nenv.t rt_val.

  (* Convert an operand to rt_val *)
  Definition op2rtv : option rt_val :=
    match o with
      | Op_reg x => Nenv.find x env
      | Op_const c => Some (const2rtv c)
    end.

  (* Convert an operand to a pointer *)
  Definition op2ptr : option PTRTYP :=
    match op2rtv with
      | Some rt => match rt with
                     | RT_int WORDSIZE_BITS _ addr :: nil => Some (Word.repr (Word.unsigned addr))
                     | _ => None
                   end
      | None => None
    end.

  (* Convert an operand to a function pointer *)
  Definition op2fun : option lab :=
    match op2rtv with
      | Some rt => match rt with
                     | RT_fun l :: nil => Some l
                     | _ => None
                   end
      | None => None
    end.
End OP.

(* ---------------------------------------------------------------------- *)
(* Value Typing *)

(* ---------------------------------------------------------------------- *)
(* Heap Typing Definitions *)

Definition heap_t := Zenv.t (ftyp * rgn).

Section HT_SEC.

  Variable lo : layout.
  Variable HT : heap_t.

  Fixpoint check_HT' (base:Z) (r:rgn) (t:ftyps) : bool :=
    match t with
      | nil => true
      | t'::ts =>
        match Zenv.find base HT with
          | Some (t'',r'') =>
            if rgn_dec r r''
              then
                if ftyp_eq_dec t' t'' (* ftyp_sub t' t'' *)
                  then check_HT' (base + size_ftyp lo t') r ts
                  else false
            else false
          | None => false
        end
  end.

  Definition check_HT (base:Z) (r:rgn) (t:ftyps) : bool :=
    if zeq base 0 then true else check_HT' base r t.

  Fixpoint construct_HT (base:Z) (r:rgn) (t:ftyps) : heap_t :=
    match t with
      | nil => HT
      | t'::ts =>
        let HT' := construct_HT (base + size_ftyp lo t') r ts in
          Zenv.add base (t',r) HT'
    end.

End HT_SEC.

Ltac t_simpl_check_HT :=
  repeat
    match goal with
      | [ H: context [ match ?p with | (_, _) => _ end ] |- _ ] => destruct p
      | [ H: context [ match ?x with | Some _ => _ | None => _ end ] |- _ ] =>
        (consider x); intros; try congruence
      | [ H: context [ if ?x then _ else _ ] |- _ ] =>
        (consider x); intros; try congruence
    end; simpl in *; subst.

(* Heap type extension *)
Definition heapt_ext (HT HT':heap_t) : Prop :=
  forall n t r,
    Zenv.find n HT = Some (t,r) ->
    Zenv.find n HT' = Some (t,r).

(* Another heap type extension stating all values in the new heap type that are
   in the previous live regions also belong to the old heap type. *)
Definition heapt_ext2 (live:list rgn) (HT HT':heap_t) : Prop :=
  forall n t r,
    Zenv.find n HT' = Some (t,r) ->
    In r live ->
    Zenv.find n HT = Some (t,r).

(* Well-formed heap-type *)
Definition wf_HT (lo:layout) (HT:heap_t) : Prop :=
  forall n t r,
    Zenv.find n HT = Some (t,r) ->
    (forall n' t' r',
      n <> n' ->
      Zenv.find n' HT = Some (t',r') ->
      n' + size_ftyp lo t' <= n \/
      n + size_ftyp lo t <= n') /\
    0 < n /\
    n + size_ftyp lo t < Word.modulus WORDSIZE_BITS.

(* The regions a heap-type mentions is closed under live *)
Definition wf_HT_live (live:list rgn) (HT:heap_t) : Prop :=
  forall n r t,
    Zenv.find n HT = Some (t, r) ->
    wf_tenv_ftyp live t.

(* Get the maximum address mapped in the heap-typing *)
Fixpoint max_HT (HT:heap_t) : Z :=
    match HT with
      | nil => 0
      | (x,y)::HT' =>
        let n := max_HT HT' in if zlt n x then x else n
    end.

Lemma max_HT_spec : forall HT n t,
  Zenv.find n HT = Some t ->
  n <= max_HT HT.
Proof.
  induction HT; simpl; intros; try congruence. destruct a.
  destruct (OrderedTypeEx.Z_as_OT.eq_dec n z); subst.
  destruct zlt; omega.
  destruct zlt; crush.
Qed.

Definition wf_HT_bounds (HT:heap_t) : Prop :=
  max_HT HT + ftyp_max < Word.max_unsigned WORDSIZE_BITS /\
  max_HT HT + ftyp_max > 0.

(* ---------------------------------------------------------------------- *)
(* Value Typing *)

Definition check_fun (fs:functions) (l:lab) (prgn:list rgn) (sig:list typ) (r:option typ) : bool :=
  if lab_dec l Word.zero then true
    else
      match lookup_fun l fs with
        | Some f =>
          if list_eq_dec typ_eq_dec (f_sig f) sig then
            if list_eq_dec rgn_dec (domain (f_prgn f)) prgn then
              match r, (f_ret f) with
                | Some t1, Some t2 => if typ_eq_dec t1 t2 then true else false
                | None, None => true
                | _, _ => false
              end
              else false
            else false
        | None => false
      end.

Section VALUE_SEC.

  Variable fs : functions.
  Variable lo : layout.
  Variable tenv : tenv_t.

  Inductive wf_value' : list rgn -> heap_t -> rt_tag -> ftyp -> Prop :=
  | wf_val_float : forall live HT f,
    wf_value' live HT (RT_float f) Ftyp_float
  | wf_val_double : forall live HT d,
    wf_value' live HT (RT_double d) Ftyp_double
  | wf_val_int : forall live HT sz pf (i:Word.int sz),
    wf_value' live HT (RT_int sz pf i) (Ftyp_int sz pf)
  | wf_val_ptr : forall live HT n t r t',
    t' = flatten_typ lo tenv t ->
    (if zeq (Word.unsigned n) 0 then True else In r live) ->
    check_HT lo HT (Word.unsigned n) r t' = true ->
    wf_value' live HT (RT_ptr n) (Ftyp_ptr t r)
  | wf_val_fun : forall live HT prgn sig ret l,
    check_fun fs l prgn sig ret = true ->
    wf_value' live HT (RT_fun l) (Ftyp_fun prgn sig ret)
  | wf_val_ptrU : forall live HT n sz r t',
    t' = list_repeat sz Ftyp_int8 ->
    (if zeq (Word.unsigned n) 0 then True else In r live) ->
    check_HT lo HT (Word.unsigned n) r t' = true ->
    wf_value' live HT (RT_ptr n) (Ftyp_ptrU sz r).
  Hint Constructors wf_value'.

  Inductive wf_value : list rgn -> heap_t -> rt_val -> ftyps -> Prop :=
  | wf_val_nil : forall live HT,
    wf_value live HT nil nil
  | wf_val_cons : forall live HT v t vs ts,
    wf_value' live HT v t ->
    wf_value live HT vs ts ->
    wf_value live HT (v::vs) (t::ts).
  Hint Constructors wf_value.

End VALUE_SEC.

(* ---------------------------------------------------------------------- *)
(* Value Typing Properties *)

Lemma wf_val_live_ext2 : forall fs lo tenv t v live HT r,
  wf_value' fs lo tenv live HT v t ->
  wf_value' fs lo tenv (r :: live) HT v t.
Proof.
  induction 1; econstructor; eauto; destruct_c zeq; intuition.
Qed.

Lemma wf_val_live_ext' : forall fs lo tenv t HT live v rgns,
  wf_value' fs lo tenv live HT v t ->
  wf_value' fs lo tenv (rgns++live) HT v t.
Proof.
  induction 1; econstructor; eauto; destruct_c zeq; intuition.
Qed.

Lemma wf_val_live_ext : forall fs lo tenv t HT live v rgns,
  wf_value fs lo tenv live HT v t ->
  wf_value fs lo tenv (rgns++live) HT v t.
Proof.
  induction 1; econstructor; eauto. eapply wf_val_live_ext'; eauto.
Qed.

Lemma check_HT_HT_ext' : forall lo t HT HT' n r,
  heapt_ext HT HT' ->
  check_HT' lo HT n r t = true ->
  check_HT' lo HT' n r t = true.
Proof.
  induction t; simpl; intros; auto. t_simpl_check_HT.
  unfold heapt_ext in H. apply H in H0. rewrite H0.
  destruct_c rgn_dec. destruct_c ftyp_eq_dec. eauto.
Qed.

Lemma check_HT_HT_ext : forall lo t HT HT' n r,
  heapt_ext HT HT' ->
  check_HT lo HT n r t = true ->
  check_HT lo HT' n r t = true.
Proof.
  unfold check_HT; intros. destruct_c zeq. eapply check_HT_HT_ext'; eauto.
Qed.

Lemma wf_val_HT_ext' : forall fs lo tenv t HT HT' live v,
  heapt_ext HT HT' ->
  wf_value' fs lo tenv live HT v t ->
  wf_value' fs lo tenv live HT' v t.
Proof.
  induction 2; econstructor; eauto; eapply check_HT_HT_ext; eauto.
Qed.

Lemma wf_val_HT_ext : forall fs lo tenv t HT HT' live v,
  heapt_ext HT HT' ->
  wf_value fs lo tenv live HT v t ->
  wf_value fs lo tenv live HT' v t.
Proof.
  induction 2; econstructor; eauto. eapply wf_val_HT_ext'; eauto.
Qed.

(* ---------------------------------------------------------------------- *)
(* Encoding and Decoding bytes *)

(* ---------------------------------------------------------------------- *)
(* From Compcert with minor changes *)
Fixpoint bytes_of_int (n : nat) (x : Z) {struct n} : list int8 :=
  match n with
  | 0%nat => nil
  | S m => Word.repr x :: bytes_of_int m (x / 256)
  end.

Fixpoint int_of_bytes (l : list int8) : Z :=
  match l with
  | nil => 0
  | b :: l' => Word.unsigned b + int_of_bytes l' * 256
  end.

Lemma int_of_bytes_of_int:
  forall n x,
  int_of_bytes (bytes_of_int n x) = x mod (two_p (Z_of_nat n * 8)).
Proof.
  induction n; intros.
  simpl. rewrite Zmod_1_r. auto.
  Opaque Word.wordsize.
  rewrite inj_S. simpl.
  replace (Zsucc (Z_of_nat n) * 8) with (Z_of_nat n * 8 + 8) by omega.
  rewrite two_p_is_exp; try omega.
  rewrite Zmod_recombine. rewrite IHn. rewrite Zplus_comm. reflexivity.
  apply two_p_gt_ZERO. omega. apply two_p_gt_ZERO. omega.
  Transparent Word.wordsize.
Qed.

Lemma length_bytes_of_int:
  forall n x, length (bytes_of_int n x) = n.
Proof.
  induction n; simpl; intros. auto. decEq. auto.
Qed.

(* ---------------------------------------------------------------------- *)
(* Decoding and encoding runtime tags / bits *)

Definition encode_rttag (lo:layout) (tag:rt_tag) : list int8 :=
  let bytes :=
  match tag with
    | RT_int n pf i => bytes_of_int (size_ftyp_nat lo (Ftyp_int n pf)) (Word.unsigned i)
    | RT_fun l => bytes_of_int (size_ftyp_nat lo (Ftyp_ptr Typ_int32 0%nat)) (Word.unsigned l)
  end in
  if endian lo then rev bytes else bytes.

Fixpoint encode_rtval (lo:layout) (ftls:ftyps) (rt:rt_val) : list int8 :=
  match rt with
    | nil => nil
    | tag :: tl' => encode_rttag lo tag ++ (encode_rtval lo ftls tl')
  end.

(* Turn a list of bytes into a run-time value as indicated by its ftyps *)
Definition decode_rttag (lo:layout) (ft:ftyp) (bytes:list int8) : rt_tag :=
  let bytes := if endian lo then rev bytes else bytes in
  match ft with
    | Ftyp_float => RT_float (Word.repr (int_of_bytes bytes))
    | Ftyp_double => RT_double (Word.repr (int_of_bytes bytes))
    | Ftyp_int n pf => RT_int n pf (Word.repr (int_of_bytes bytes))
    | Ftyp_ptr _ _ => RT_ptr (Word.repr (int_of_bytes bytes))
    | Ftyp_fun _ _ _ => RT_fun (Word.repr (int_of_bytes bytes))
    | Ftyp_ptrU _ _ => RT_ptr (Word.repr (int_of_bytes bytes))
  end.
Fixpoint decode_rtval (lo:layout) (ftls:ftyps) (bytes:list int8) : rt_val :=
  match ftls with
    | ft' :: ftls' =>
      decode_rttag lo ft' (firstn (size_ftyp_nat lo ft') bytes) ::
      decode_rtval lo ftls' (skipn (size_ftyp_nat lo ft') bytes)
    | nil => nil
  end.

Lemma decode_encode_int_same : forall sz pf (i:Word.int sz) lo,
  RT_int sz pf
  (Word.repr
    (int_of_bytes
      (bytes_of_int (size_ftyp_nat lo (Ftyp_int sz pf))
        (Word.unsigned i)))) = RT_int sz pf i.
Proof.
  intros. f_equal; auto. rewrite int_of_bytes_of_int. unfold size_ftyp_nat. unfold size_ftyp.
  rewrite nat_of_Z_eq. rewrite Z.mul_add_distr_r. destruct i. apply Word.mkint_eq. simpl.
  unfold Word.modulus in *. unfold Word.wordsize in *. rewrite two_power_nat_two_p in *.

  assert (8 > 0). omega.

  assert (Z.of_nat (S sz) <= Z.of_nat sz / 8 * 8 + 8).
  specialize (Z_div_mod_eq (Z.of_nat sz) 8 H); intros.
  assert (Z.of_nat sz - Z.of_nat sz mod 8 = 8 * (Z.of_nat sz / 8)). omega.
  rewrite Zmult_comm. rewrite <- H1.
  rewrite inj_S. rewrite <- Z.add_1_l.
  specialize (Z_mod_lt (Z.of_nat sz) 8 H); intros. omega.

  assert (two_p (Z.of_nat (S sz)) > 0). apply two_p_gt_ZERO. omega.
  specialize (Z_mod_lt intval (two_p (Z.of_nat (S sz))) H1); intros.

  assert (0 <= Z.of_nat (S sz) <= Z.of_nat sz / 8 * 8 + 8). omega.
  apply two_p_monotone in H3.
  assert (0 <= intval mod two_p (Z.of_nat (S sz)) < two_p (Z.of_nat sz / 8 * 8 + 8)). omega.

  assert (intval mod (two_p (Z.of_nat (S sz))) = intval).
  rewrite Zmod_small; auto.
  rewrite H5 in *.

  rewrite Zmod_small in *; auto. rewrite Zmod_small; auto.
  rewrite Zmod_small; auto.

  assert (0 <= Z.of_nat sz / 8). apply Z_div_pos; omega. omega.
Qed.

Lemma decode_encode_fun_same : forall n lo,
  RT_fun
  (Word.repr
    (int_of_bytes
      (bytes_of_int (size_ftyp_nat lo (Ftyp_ptr Typ_int32 0%nat))
        (Word.unsigned n)))) = RT_fun n.
Proof.
  intros. f_equal. rewrite int_of_bytes_of_int. simpl. destruct n.
  apply Word.mkint_eq. simpl. unfold Word.modulus in *.
  unfold Word.wordsize in *. rewrite two_power_nat_two_p.
  unfold two_p. simpl. rewrite Zmod_mod. rewrite Zmod_small; auto.
Qed.

Lemma decode_encode_same : forall t v fs lo tenv HT live,
  wf_value' fs lo tenv HT live v t ->
  decode_rttag lo t (encode_rttag lo v) = v.
Proof.
  intros. inv H; unfold decode_rttag; unfold encode_rttag.
  { unfold RT_float. destruct (endian lo). rewrite rev_involutive.
    rewrite Word.repr_unsigned. apply decode_encode_int_same.
    rewrite Word.repr_unsigned. apply decode_encode_int_same. }
  { unfold RT_double. destruct (endian lo). rewrite rev_involutive.
    rewrite Word.repr_unsigned. apply decode_encode_int_same.
    rewrite Word.repr_unsigned. apply decode_encode_int_same. }
  { destruct (endian lo). rewrite rev_involutive.
    apply decode_encode_int_same. apply decode_encode_int_same. }
  { destruct (endian lo). rewrite rev_involutive.
    apply decode_encode_int_same. apply decode_encode_int_same. }
  { destruct (endian lo). rewrite rev_involutive.
    apply decode_encode_fun_same. apply decode_encode_fun_same. }
  { destruct (endian lo). rewrite rev_involutive.
    apply decode_encode_int_same. apply decode_encode_int_same. }
Qed.

(* ---------------------------------------------------------------------- *)

Fixpoint bytestoint' (rt:rt_val) : list int8 :=
  match rt with
    | nil => nil
    | v::rt' => match v with
                  | RT_int 7 _ b => b :: bytestoint' rt'
                  | _ => Word.zero :: bytestoint' rt'
                end
  end.
Definition bytestoint16 (lo:layout) (rt:rt_val) : rt_val :=
  RT_int 15 lt_15_MAX_I_BITS (Word.repr (int_of_bytes (bytestoint' rt))) :: nil.
Definition bytestoint (lo:layout) (rt:rt_val) : rt_val :=
  RT_int 31 lt_31_MAX_I_BITS (Word.repr (int_of_bytes (bytestoint' rt))) :: nil.
Definition bytestoint64 (lo:layout) (rt:rt_val) : rt_val :=
  RT_int 63 lt_63_MAX_I_BITS (Word.repr (int_of_bytes (bytestoint' rt))) :: nil.

(* ---------------------------------------------------------------------- *)

Fixpoint anytobytes' (lo:layout) (rt:rt_val) : list int8 :=
  match rt with
    | nil => nil
    | v::rt' => match v with
                  | RT_int n pf i => bytes_of_int (size_ftyp_nat lo (Ftyp_int n pf)) (Word.unsigned i) ++ anytobytes' lo rt'
                  | RT_fun l => bytes_of_int (size_ftyp_nat lo (Ftyp_ptr Typ_int32 0%nat)) (Word.unsigned l) ++ anytobytes' lo rt'
                end
  end.

Definition anytobytes (lo:layout) (rt:rt_val) : rt_val :=
  map (fun b => RT_int 7 lt_7_MAX_I_BITS b) (anytobytes' lo rt).

Lemma wf_val_anytobytesh : forall n bs fs lo tenv live HT,
  n = length bs ->
  wf_value fs lo tenv live HT (map (fun b => RT_int 7 lt_7_MAX_I_BITS b) bs) (list_repeat n Ftyp_int8).
Proof.
  induction n; destruct bs; crush. econstructor; eauto.
  econstructor; eauto. destruct i.
  assert (Word.repr intval = Word.mkint _ intval intrange).
  apply Word.mkint_eq. rewrite Zmod_small; auto. rewrite <- H.
  econstructor; eauto.
Qed.

Lemma wf_val_anytobytes : forall b fs lo tenv live HT n,
  n = length (anytobytes lo b) ->
  wf_value fs lo tenv live HT (anytobytes lo b) (list_repeat n Ftyp_int8).
Proof.
  intros. specialize (wf_val_anytobytesh n (anytobytes' lo b) fs lo tenv live HT); intros.
  unfold anytobytes in *. rewrite map_length in H. crush.
Qed.

Lemma wf_val_any_size_nat' : forall fs lo tenv live HT t v,
  wf_value' fs lo tenv live HT v t ->
  (length (anytobytes lo (v::nil))) = size_ftyp_nat lo t.
Proof.
  induction 1; unfold anytobytes; simpl; intros; auto. rewrite map_length.
  unfold size_ftyp_nat. unfold size_ftyp. rewrite app_length.
  rewrite length_bytes_of_int. auto.
Qed.

Lemma wf_val_any_size_nat : forall fs lo tenv live HT t v,
  wf_value fs lo tenv live HT v t ->
  (length (anytobytes lo v) = size_ftyps_nat lo t)%nat.
Proof.
  induction t; simpl; intros.
  { inv H. simpl. auto. }
  { assert (forall lo t1 t2,
    size_ftyps_nat lo (t1 :: t2) = (size_ftyp_nat lo t1 + size_ftyps_nat lo t2)%nat).
    intros. unfold size_ftyps_nat. unfold size_ftyp_nat. simpl.
    rewrite nat_of_Z_plus; auto. apply size_ftyp_nonneg. apply size_ftyps_nonneg.
    rewrite H0. inv H. eapply IHt in H7.
    unfold anytobytes in *. rewrite map_length in *.
    inv H6; simpl; repeat f_equal; auto.
    unfold size_ftyp_nat. unfold size_ftyp. rewrite app_length. rewrite length_bytes_of_int.
    auto. }
Qed.

Lemma wf_val_any_size : forall fs lo tenv live HT t v,
  wf_value fs lo tenv live HT v t ->
  Z.of_nat (length (anytobytes lo v)) = size_ftyps lo t.
Proof.
  intros. apply wf_val_any_size_nat in H. unfold size_ftyps_nat in H.
  assert (Z.of_nat (length (anytobytes lo v)) = Z.of_nat (nat_of_Z (size_ftyps lo t))).
  omega. rewrite H0. rewrite nat_of_Z_eq; auto. apply size_ftyps_nonneg.
Qed.

(* ---------------------------------------------------------------------- *)

Lemma check_HT_mid' : forall t t' s addr lo HT f,
  ftyps_subset t' t = true ->
  check_HT' lo HT (addr + size_ftyp lo f) s t = true ->
  check_HT' lo HT (addr + size_ftyp lo f) s t' = true.
Proof.
  induction t; destruct t'; crush.
  (* case_eq (ftyp_subset f a); intros. rewrite H1 in H. *)
  destruct ftyp_eq_dec; try congruence.
  remember (Zenv.find (addr + size_ftyp lo f0) HT) as Hd.
  symmetry in HeqHd. destruct Hd; try congruence.
  destruct p. destruct rgn_dec; try congruence. subst.
  destruct_c ftyp_eq_dec; eauto.
Qed.

Lemma check_HT_mid : forall t n t' lo HT addr r rmap,
  addr > 0 ->
  (n < length t)%nat ->
  ftyps_subset t' (skipn n t) = true ->
  check_HT lo HT addr (alpha rmap r) (sigma rmap t) = true ->
  check_HT lo HT (addr + walk_offset lo n t) (alpha rmap r) (sigma rmap t') = true.
Proof.
  induction t; crush.
  destruct n; simpl in *.
  { unfold check_HT in *. destruct zeq; crush. destruct_c zeq.
    remember (Zenv.find addr HT) as Hd. destruct_c Hd.
    destruct p. destruct_c rgn_dec. subst.
    destruct t'.
    simpl in H1. unfold check_HT'. reflexivity.
    simpl in H1. destruct_c ftyp_eq_dec. subst.
    assert (addr + 0 = addr). omega. rewrite H3.
    simpl. rewrite <- HeqHd. destruct_c rgn_dec. destruct_c ftyp_eq_dec.
    eapply check_HT_mid'; eauto. eapply ftyps_subset_sigma; eauto. }
  { assert (addr + (walk_offset lo n t + size_ftyp lo a) =
    (addr + size_ftyp lo a) + (walk_offset lo n t)). omega.
    rewrite H3. eapply IHt; eauto. size_ftyp_prop. omega. omega.
    unfold check_HT in *. destruct zeq; crush. destruct_c zeq.
    destruct_c (Zenv.find addr HT). destruct p. destruct_c rgn_dec.
    destruct_c ftyp_eq_dec. erewrite <- size_ftyp_sigma_inv; eauto. }
Qed.

Lemma check_HT_bounds : forall t r n lo HT,
  n > 0 ->
  t <> nil ->
  wf_HT_bounds HT ->
  check_HT lo HT n r t = true ->
  n <= Word.max_unsigned WORDSIZE_BITS.
Proof.
  destruct t; intros.
  { unfold check_HT in H2. destruct zeq; crush. }
  { unfold check_HT in H2. destruct zeq; crush.
    remember (Zenv.find n HT) as Hd. destruct_c Hd.
    symmetry in HeqHd. unfold wf_HT_bounds in H1. destruct H1.
    apply max_HT_spec in HeqHd. unfold ftyp_max in *. omega. }
Qed.

Lemma check_HT_subset' : forall t2 t1 lo HT addr r rmap,
  ftyps_subset t2 t1 = true ->
  check_HT' lo HT addr r (sigma rmap t1) = true ->
  check_HT' lo HT addr r (sigma rmap t2) = true.
Proof.
  induction t2; simpl; intros; auto.
  destruct_c t1. destruct_c ftyp_eq_dec. subst. simpl in *.
  destruct_c (Zenv.find addr HT). destruct p.
  destruct_c rgn_dec. destruct_c ftyp_eq_dec.
  eapply IHt2; eauto.
Qed.

Lemma check_HT_subset : forall t2 t1 lo HT addr r rmap,
  ftyps_subset t2 t1 = true ->
  check_HT lo HT addr r (sigma rmap t1) = true ->
  check_HT lo HT addr r (sigma rmap t2) = true.
Proof.
  intros. unfold check_HT in *. destruct_c zeq.
  eapply check_HT_subset'; eauto.
Qed.

Lemma check_HT_subset_bytes : forall sz1 sz2 lo HT rmap addr r,
  check_HT lo HT addr r (sigma rmap (list_repeat sz1 Ftyp_int8)) = true ->
  Z.of_nat sz2 <= Z.of_nat sz1 ->
  check_HT lo HT addr r (sigma rmap (list_repeat sz2 Ftyp_int8)) = true.
Proof.
  intros. eapply check_HT_subset; eauto. eapply ftyps_subset_ls_repeat; eauto. omega.
Qed.

Lemma check_HT_range' : forall sz lo HT i1 i2 r,
  i1 <= Word.modulus WORDSIZE_BITS ->
  wf_HT lo HT ->
  i2 < Z.of_nat sz ->
  check_HT' lo HT i1 r (list_repeat sz Ftyp_int8) = true ->
  i1 + i2 < Word.modulus WORDSIZE_BITS.
Proof.
  induction sz; simpl; intros; auto.
  crush.
  remember (Zenv.find i1 HT) as Hd. symmetry in HeqHd.
  destruct_c Hd. destruct p. destruct_c rgn_dec. destruct_c ftyp_eq_dec. subst.
  eapply IHsz with (i2 := i2 - 1) in H2; eauto. omega.
  unfold wf_HT in H0. apply H0 in HeqHd. t_simp. simpl in H5. omega.
  rewrite Zpos_P_of_succ_nat in H1. omega.
Qed.

Lemma check_HT_range : forall sz lo HT i1 i2 r,
  i1 <= Word.modulus WORDSIZE_BITS ->
  wf_HT lo HT ->
  i2 < Z.of_nat sz <= Word.modulus WORDSIZE_BITS ->
  check_HT lo HT i1 r (list_repeat sz Ftyp_int8) = true ->
  i1 + i2 < Word.modulus WORDSIZE_BITS.
Proof.
  unfold check_HT; intros. destruct_c zeq. subst. omega.
  eapply check_HT_range'; eauto. omega.
Qed.

Lemma check_HT_mid_bytes' : forall sz i1 i2 lo HT r,
  check_HT' lo HT i1 r (list_repeat sz Ftyp_int8) = true ->
  (i2 < sz)%nat ->
  check_HT' lo HT (i1 + Z.of_nat i2) r (list_repeat (sz - i2) Ftyp_int8) = true.
Proof.
  induction sz; simpl; intros; auto.
  remember (Zenv.find i1 HT) as Hd. destruct_c Hd. symmetry in HeqHd.
  destruct p. destruct_c rgn_dec. destruct_c ftyp_eq_dec. subst.
  destruct i2. simpl.
  { assert (i1 + 0 = i1) by omega. rewrite H1. rewrite HeqHd.
    destruct_c rgn_dec. destruct_c ftyp_eq_dec. }
  rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_r.
  { assert (i1 + (Z.of_nat i2 + 1) = i1 + 1 + Z.of_nat i2) by omega.
    rewrite H1. eapply IHsz; eauto. omega. }
Qed.

Lemma check_HT_mid_bytes : forall sz i1 i2 lo HT r,
  i1 > 0 ->
  (i2 < sz)%nat ->
  check_HT lo HT i1 r (list_repeat sz Ftyp_int8) = true ->
  check_HT lo HT (i1 + Z.of_nat i2) r (list_repeat (sz - i2) Ftyp_int8) = true.
Proof.
  intros. unfold check_HT in *. destruct_c zeq. destruct zeq; auto. subst. inv H.
  destruct zeq; auto. eapply check_HT_mid_bytes'; eauto.
Qed.

(* ---------------------------------------------------------------------- *)

Lemma check_HT_disj' : forall t1 t2 lo HT addr r,
  check_HT' lo HT addr r (t1 ++ t2) = true ->
  check_HT' lo HT addr r t1 = true /\
  check_HT' lo HT (addr + size_ftyps lo t1) r t2 = true.
Proof.
  induction t1; simpl; intros; auto.
  split; auto. cutrewrite (addr + 0 = addr); [ | omega]. auto.
  case_eq (Zenv.find addr HT); intros. rewrite H0 in H. destruct p. destruct_c rgn_dec; subst.
  destruct_c ftyp_eq_dec; subst.
  apply IHt1 in H.
  assert ((addr + (size_ftyp lo f + size_ftyps lo t1)) = (addr + size_ftyp lo f + size_ftyps lo t1)). omega.
  rewrite H1. auto.
  rewrite H0 in H. crush.
Qed.

Lemma check_HT_comb : forall t1 t2 lo HT addr r,
  check_HT' lo HT addr r t1 = true ->
  check_HT' lo HT (addr + size_ftyps lo t1) r t2 = true ->
  check_HT' lo HT addr r (t1 ++ t2) = true.
Proof.
  induction t1; simpl; intros; auto.
  cutrewrite (addr + 0 = addr) in H0; [ | omega]. auto.
  case_eq (Zenv.find addr HT); intros. rewrite H1 in H. destruct p. destruct_c rgn_dec; subst.
  destruct_c ftyp_eq_dec; subst.
  apply IHt1 with (t2 := t2) in H; auto.
  cutrewrite (addr + (size_ftyp lo f + size_ftyps lo t1) = addr + size_ftyp lo f + size_ftyps lo t1) in H0; [ | omega].
  auto.
  rewrite H1 in H. crush.
Qed.

Lemma check_HT_array'' : forall sz,
  (0 < sz)%nat ->
  forall lo HT addr r rmap tenv t,
  check_HT' lo HT addr r (sigma rmap (flatten_typ lo tenv (Typ_array t sz))) = true ->
  check_HT' lo HT addr r (sigma rmap (flatten_typ lo tenv t)) = true.
Proof.
  induction 1; intros. simpl in *. rewrite app_nil_r in H. auto.
  simpl in H0. unfold sigma in H0. rewrite map_app in H0.
  eapply check_HT_disj' in H0. destruct H0; auto.
Qed.

Lemma check_HT_array : forall sz,
  (0 < sz)%nat ->
  forall lo HT addr r rmap tenv t,
  check_HT lo HT addr r (sigma rmap (flatten_typ lo tenv (Typ_array t sz))) = true ->
  check_HT lo HT addr r (sigma rmap (flatten_typ lo tenv t)) = true.
Proof.
  unfold check_HT; intros. destruct_c zeq.
  eapply check_HT_array''; eauto.
Qed.

Lemma check_HT_array_subset' : forall sz lo HT addr r tenv t rmap,
  check_HT' lo HT addr r (sigma rmap (flatten_typ lo tenv (Typ_array t sz))) = true ->
  check_HT' lo HT (addr + size_ftyps lo (flatten_typ lo tenv t)) r (sigma rmap (flatten_typ lo tenv (Typ_array t (sz - 1)))) = true.
Proof.
  destruct sz; simpl; intros; auto.
  unfold sigma in H. rewrite map_app in H. apply check_HT_disj' in H. destruct H. unfold sigma.
  replace (sz - 0)%nat with sz by omega. auto.
  erewrite <- size_ftyps_sigma_inv; eauto.
Qed.

Lemma check_HT_range_general' : forall t lo HT i1 r,
  i1 < Word.modulus WORDSIZE_BITS ->
  wf_HT lo HT ->
  check_HT' lo HT i1 r t = true ->
  i1 + size_ftyps lo t < Word.modulus WORDSIZE_BITS.
Proof.
  induction t; simpl; intros; auto. omega.
  replace (i1 + (size_ftyp lo a + size_ftyps lo t)) with (i1 + size_ftyp lo a + size_ftyps lo t) by omega.
  case_eq (Zenv.find i1 HT); intros.
  rewrite H2 in H1. destruct p. destruct_c rgn_dec; subst.
  destruct_c ftyp_eq_dec; subst.
  eapply IHt in H1; eauto.
  unfold wf_HT in H0. apply H0 in H2. destruct H2. intuition.
  rewrite H2 in H1. crush.
Qed.

Lemma check_HT_range_general : forall t lo HT i1 r,
  i1 > 0 ->
  i1 < Word.modulus WORDSIZE_BITS ->
  wf_HT lo HT ->
  check_HT lo HT i1 r t = true ->
  i1 + size_ftyps lo t < Word.modulus WORDSIZE_BITS.
Proof.
  unfold check_HT; intros. destruct_c zeq. omegaContradiction.
  eapply check_HT_range_general'; eauto.
Qed.

(* ---------------------------------------------------------------------- *)
Lemma wf_val_ftyp_sub : forall t1 t2 fs lo tenv HT live v,
  ftyp_sub t1 t2 = true ->
  wf_value' fs lo tenv HT live v t1 ->
  wf_value' fs lo tenv HT live v t2.
Proof.
  induction t1; destruct t2; simpl; intros;
    try destruct_c ftyp_eq_dec; eauto.
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (lt_31_MAX_I_BITS = l). apply proof_irr. subst. econstructor; eauto. }
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (lt_63_MAX_I_BITS = l). apply proof_irr. subst. econstructor; eauto. }
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (RT_float i0 = RT_int 31 pf0 i0). unfold RT_float. f_equal.
    apply proof_irr. rewrite Word.repr_unsigned. reflexivity.
    rewrite <- H0. econstructor; eauto. }
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (RT_double i0 = RT_int 63 pf0 i0). unfold RT_double. f_equal.
    apply proof_irr. rewrite Word.repr_unsigned. reflexivity.
    rewrite <- H0. econstructor; eauto. }
  { inv H0. unfold RT_ptr. destruct_c eq_nat_dec; subst.
    assert (lt_63_MAX_I_BITS = l). apply proof_irr. subst.
    econstructor; eauto. }
  { inv H0. unfold RT_ptr. destruct_c eq_nat_dec; subst.
    assert (lt_63_MAX_I_BITS = l). apply proof_irr. subst.
    econstructor; eauto. }
  { destruct_c rgn_dec. destruct_c zle. inv H0. econstructor; eauto.
    assert (forall n rmap, list_repeat n Ftyp_int8 = sigma rmap (list_repeat n Ftyp_int8)).
    induction n2; crush. erewrite H0. erewrite H0 in H8.
    eapply check_HT_subset_bytes; eauto.
    Grab Existential Variables.
    apply Nenv.empty.
  }
Qed.

Lemma wf_val_ftyp_sub2 : forall t1 t2 fs lo tenv HT live v rmap,
  ftyp_sub t1 t2 = true ->
  wf_value' fs lo tenv HT live v (sigma' rmap t1) ->
  wf_value' fs lo tenv HT live v (sigma' rmap t2).
Proof.
  induction t1; destruct t2; simpl; intros;
    try destruct_c ftyp_eq_dec; eauto.
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (lt_31_MAX_I_BITS = l). apply proof_irr. subst. econstructor; eauto. }
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (lt_63_MAX_I_BITS = l). apply proof_irr. subst. econstructor; eauto. }
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (RT_float i0 = RT_int 31 pf0 i0). unfold RT_float. f_equal.
    apply proof_irr. rewrite Word.repr_unsigned. reflexivity.
    rewrite <- H0. econstructor; eauto. }
  { inv H0. destruct_c eq_nat_dec; subst.
    assert (RT_double i0 = RT_int 63 pf0 i0). unfold RT_double. f_equal.
    apply proof_irr. rewrite Word.repr_unsigned. reflexivity.
    rewrite <- H0. econstructor; eauto. }
  { inv H0. unfold RT_ptr. destruct_c eq_nat_dec; subst.
    assert (lt_63_MAX_I_BITS = l). apply proof_irr. subst.
    econstructor; eauto. }
  { inv H0. unfold RT_ptr. destruct_c eq_nat_dec; subst.
    assert (lt_63_MAX_I_BITS = l). apply proof_irr. subst.
    econstructor; eauto. }
  { destruct_c rgn_dec. destruct_c zle. inv H0. econstructor; eauto.
    assert (forall n rmap, list_repeat n Ftyp_int8 = sigma rmap (list_repeat n Ftyp_int8)).
    induction n2; crush.
    rewrite H0 with (rmap := rmap) in H8.
    rewrite H0 with (rmap := rmap).
    eapply check_HT_subset_bytes; eauto. }
Qed.

Fixpoint weaken_val (v:rt_val) (t:ftyps) : rt_val :=
  match v, t with
    | v::vs, t::ts => v :: weaken_val vs ts
    | _, nil => nil
    | nil, _ => nil
  end.

Lemma wf_val_ftyps_weaken : forall t1 t2 fs lo tenv HT live v rmap,
  ftyps_weaken t1 t2 = true ->
  wf_value fs lo tenv HT live v (sigma rmap t1) ->
  wf_value fs lo tenv HT live (weaken_val v t2) (sigma rmap t2).
Proof.
  induction t1; simpl; intros.
  { destruct_c t2. simpl. destruct v; simpl; auto. constructor. }
  { destruct_c t2. simpl. destruct v; simpl; auto.
    constructor. constructor. consider (ftyp_sub a f); intros. inv H0.
    eapply IHt1 in H8; eauto. econstructor; eauto. eapply wf_val_ftyp_sub2; eauto. }
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a28_ : Universe.
Variable a27_ : Universe.
Variable a26_ : Universe.
Variable a25_ : Universe.
Variable a24_ : Universe.
Variable a23_ : Universe.
Variable a22_ : Universe.
Variable a21_ : Universe.
Variable a20_ : Universe.
Variable a2_ : Universe.
Variable a19_ : Universe.
Variable a18_ : Universe.
Variable a17_ : Universe.
Variable a16_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ (dom_ a15_ /\ (dom_ a16_ /\ (dom_ a17_ /\ (dom_ a18_ /\ (dom_ a19_ /\ (dom_ a20_ /\ (dom_ a21_ /\ (dom_ a22_ /\ (dom_ a23_ /\ (dom_ a24_ /\ (dom_ a25_ /\ (dom_ a26_ /\ (dom_ a27_ /\ dom_ a28_))))))))))))))))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ (dom_ A15 /\ (dom_ A16 /\ (dom_ A17 /\ (dom_ A18 /\ (dom_ A19 /\ (dom_ A20 /\ (dom_ A21 /\ (dom_ A22 /\ (dom_ A23 /\ (dom_ A24 /\ (dom_ A25 /\ (dom_ A26 /\ (dom_ A27 /\ dom_ A28))))))))))))))))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28)).
Variable ax3_3 : (p_ a28_ a27_ a26_ a25_ a24_ a23_ a22_ a21_ a20_ a19_ a18_ a17_ a16_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

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

End FOFProblem.


(** * Bicolano: Semantic domains *)

(* <Insert License Here>

    $Id: Domain.v 69 2006-03-06 20:16:11Z davidpichardie $ *)

(** Formalization of Java semantic domain.
 Based on The "Java (TM) Virtual Machine Specification, Second Edition,
  Tim Lindholm, Frank Yellin"

 @author David Pichardie, ...  *)
(* Hendra : - Modified to suit DEX program (removed operand stack).
            - Removed reference comparison
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_Program.
Require Export Numeric.
Require Export List.
Open Scope Z_scope.

(** All semantic domains and basic operation are encapsulated in a module signature *)

Module Type DEX_SEMANTIC_DOMAIN.

 (** We depend on the choices done for program data structures *)
 Declare Module DEX_Prog : DEX_PROGRAM. Import DEX_Prog.

 Declare Module Byte  : NUMERIC with Definition power := 7%nat.
 Declare Module Short : NUMERIC with Definition power := 15%nat.
 Declare Module Int   : NUMERIC with Definition power := 31%nat.

 (** conversion *)
 Parameter b2i : Byte.t -> Int.t.
 Parameter s2i : Short.t -> Int.t.
 Parameter i2b : Int.t -> Byte.t.
 Parameter i2s : Int.t -> Short.t.
 Parameter i2bool : Int.t -> Byte.t.

 Inductive DEX_num : Set :=
   | I : Int.t -> DEX_num
   | B : Byte.t -> DEX_num
   | Sh : Short.t -> DEX_num.

 Inductive DEX_value : Set :=
   | Num : DEX_num -> DEX_value.

 Definition init_value (t:DEX_type) : DEX_value :=
    match t with
     | DEX_PrimitiveType _ => Num (I (Int.const 0))
    end.

 (** Domain of local variables *)
 Module Type DEX_REGISTERS.
   Parameter t : Type.
   Parameter get : t-> DEX_Reg -> option DEX_value.
   Parameter update : t -> DEX_Reg -> DEX_value -> t.
   Parameter dom : t -> list DEX_Reg.
   Parameter get_update_new : forall l x v, get (update l x v) x = Some v.
   Parameter get_update_old : forall l x y v,
     x<>y -> get (update l x v) y = get l y.
 End DEX_REGISTERS.
 Declare Module DEX_Registers : DEX_REGISTERS.

 Parameter listreg2regs : DEX_Registers.t -> nat -> list DEX_Reg -> DEX_Registers.t.

(* 290415 - Some Notes
- According to verified DEX bytecode, every registers have
  to have a value before used. This means we can safely assume
  that we don't need the update to be option anymore because
  the only possible case where it updates empty value is when
  the source is empty, which has been taken care by the assumption
- The special register ret and ex are assigned the number
  65536 and 65537 respectively (in binary) because we know
  that the maximum number of registers is 65535.
*)

  Inductive DEX_ReturnVal : Set :=
   | Normal : option DEX_value -> DEX_ReturnVal.

 (** Domain of frames *)
 Module Type DEX_FRAME.
   Inductive t : Type :=
      make : DEX_Method -> DEX_PC -> DEX_Registers.t -> t.
 End DEX_FRAME.
 Declare Module DEX_Frame : DEX_FRAME.

 (** Domain of call stacks *)
 Module Type DEX_CALLSTACK.
   Definition t : Type := list DEX_Frame.t.
 End DEX_CALLSTACK.
 Declare Module DEX_CallStack : DEX_CALLSTACK.

 (** Domain of states *)
 Module Type DEX_STATE.
   Inductive t : Type :=
      normal : DEX_Frame.t -> DEX_CallStack.t -> t.
   Definition get_sf (s:t) : DEX_CallStack.t :=
     match s with
       normal _ sf => sf
     end.
   Definition get_m (s:t) : DEX_Method :=
     match s with
       normal (DEX_Frame.make m _ _)_ => m
     end.
 End DEX_STATE.
 Declare Module DEX_State : DEX_STATE.

 (** Some notations *)
 Notation St := DEX_State.normal.
 Notation Fr := DEX_Frame.make.

  (** compatibility between ValKind and value *)
  Inductive compat_ValKind_value : DEX_ValKind -> DEX_value -> Prop :=
    | compat_ValKind_value_int : forall n,
        compat_ValKind_value DEX_Ival (Num (I n)).

  (** [assign_compatible_num source target] holds if a numeric value [source] can be
    assigned to a variable of type [target]. This point is not clear in the JVM spec. *)
  Inductive assign_compatible_num : DEX_num -> DEX_primitiveType -> Prop :=
   | assign_compatible_int_int : forall i, assign_compatible_num (I i) DEX_INT
   | assign_compatible_short_int : forall sh, assign_compatible_num (Sh sh) DEX_INT
   | assign_compatible_byte_int : forall b, assign_compatible_num (B b) DEX_INT
   | assign_compatible_short_short : forall sh, assign_compatible_num (Sh sh) DEX_SHORT
   | assign_compatible_byte_byte : forall b, assign_compatible_num (B b) DEX_BYTE
   | assign_compatible_byte_boolean : forall b, assign_compatible_num (B b) DEX_BOOLEAN.

  (** [assign_compatible h source target] holds if a value [source] can be
    assigned to a variable of type [target] *)
  Inductive assign_compatible (p:DEX_Program) : DEX_value -> DEX_type -> Prop :=
   | assign_compatible_num_val : forall (n:DEX_num) (t:DEX_primitiveType),
       assign_compatible_num n t -> assign_compatible p (Num n) (DEX_PrimitiveType t).

  Definition SemCompInt (cmp:DEX_CompInt) (z1 z2: Z) : Prop :=
    match cmp with
      DEX_EqInt =>  z1=z2
    | DEX_NeInt => z1<>z2
    | DEX_LtInt => z1<z2
    | DEX_LeInt => z1<=z2
    | DEX_GtInt => z1>z2
    | DEX_GeInt => z1>=z2
    end.

  Definition SemBinopInt (op:DEX_BinopInt) (i1 i2:Int.t) : Int.t :=
    match op with
    | DEX_AddInt => Int.add i1 i2
    | DEX_AndInt => Int.and i1 i2
    | DEX_DivInt => Int.div i1 i2
    | DEX_MulInt => Int.mul i1 i2
    | DEX_OrInt => Int.or i1 i2
    | DEX_RemInt => Int.rem i1 i2
    | DEX_ShlInt => Int.shl i1 i2
    | DEX_ShrInt => Int.shr i1 i2
    | DEX_SubInt => Int.sub i1 i2
    | DEX_UshrInt => Int.ushr i1 i2
    | DEX_XorInt => Int.xor i1 i2
    end.

End DEX_SEMANTIC_DOMAIN.


Require Export MicroBFTprops2.

Section MicroBFTass_diss_if_kn.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

  Lemma ASSUMPTION_disseminate_if_knows_true :
    forall (eo : EventOrdering) d, assume_eo eo (ASSUMPTION_disseminate_if_knows d).
  Proof.
    introv diss.
    simpl in *.
    exrepnd.

    unfold disseminate_data in *.
    unfold knows_after. simpl in *.
(*    unfold MicroBFT_data_knows.
    unfold MicroBFT_data_in_log. *)
    unfold state_after. simpl.

    (* exists c. *)

    unfold M_byz_output_sys_on_event in *; simpl.
    rewrite M_byz_output_ls_on_event_as_run in diss0; simpl.
    unfold M_byz_output_ls_on_this_one_event in *.
    allrw; simpl.

    unfold MicroBFTheader.node2name in *. simpl in *; subst.
    unfold MicroBFTsys in *. simpl in *.

    SearchAbout M_byz_run_ls_before_event.

    pose proof (ex_M_byz_run_ls_before_event_MicroBFTlocalSys e (loc e)) as run.
    repndors.
    {
      exrepnd.
      rewrite run0 in *. clear run0. simpl in *.

      remember (trigger e) as trig. symmetry in Heqtrig.
      destruct trig; simpl in *; ginv; tcsp;[].
      unfold state_of_trusted in *. simpl in *.
      unfold USIG_update in *. destruct i; simpl in *; ginv; subst; tcsp;[|].
      {
        destruct diss0; simpl in *; ginv; tcsp.

        eexists; dands; eauto;[|].
        {
          eexists; dands; eauto.
          erewrite M_state_sys_on_event_unfold.
          erewrite map_option_Some.


Require Import Coq.Lists.List
        Coq.Program.Program
        Coq.Arith.Arith.
Require Import
        Fiat.ADT
        Fiat.ADT.ComputationalADT
        Fiat.ADTNotation
        Fiat.ADTRefinement
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.Fiat4Monitors.RADL_Topics
        Fiat.Fiat4Monitors.RADL_Messages
        Fiat.Fiat4Monitors.RADL_Flags
        Fiat.Fiat4Monitors.RADL_Nodes
        Fiat.Fiat4Monitors.MonitorADTs.

Require Import Bedrock.Platform.Facade.DFacade
        Bedrock.Platform.Facade.Notations
        Bedrock.Platform.Cito.ADT
        Bedrock.Platform.Cito.RepInv.

Import Adt.

(* This is a placeholder for a legitimate description of the memory layout. *)
Definition Monitors_rep_inv p (adtvalue : ADTValue) : HProp :=
  match adtvalue with
    | _ => p =?> 1
  end%Sep.

Module Ri <: RepInv Adt.

  Definition RepInv := W -> ADTValue -> HProp.

  Definition rep_inv := Monitors_rep_inv.

  Lemma rep_inv_ptr : forall p a, rep_inv p a ===> p =?> 1 * any.
    destruct a;
    unfold rep_inv, Monitors_rep_inv; simpl;
    sepLemma; apply any_easy.
  Qed.

End Ri.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for PowerPC *)

Require Import ZArith List.
(*From Flocq*)
Require Import Binary Bits.

Definition ptr64 := false.

Definition big_endian := true.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

(** Can we use the 64-bit extensions to the PowerPC architecture? *)
Parameter ppc64 : bool.

(** Should single-precision FP arguments passed on stack be passed
    as singles or use double FP format. *)
Parameter single_passed_as_single : bool.

Definition splitlong := negb ppc64.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  reflexivity.
Qed.

Definition default_nan_64 := (false, iter_nat 51 _ xO xH).
Definition default_nan_32 := (false, iter_nat 22 _ xO xH).

(* Always choose the first NaN argument, if any *)

Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_64 | n :: _ => n end.

Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_32 | n :: _ => n end.

Lemma choose_nan_64_idem: forall n,
  choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
Proof. auto. Qed.

Lemma choose_nan_32_idem: forall n,
  choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
Proof. auto. Qed.

Definition fma_order {A: Type} (x y z: A) := (x, z, y).

Definition fma_invalid_mul_is_nan := false.

Definition float_of_single_preserves_sNaN := true.

Global Opaque ptr64 big_endian splitlong
              default_nan_64 choose_nan_64
              default_nan_32 choose_nan_32
              fma_order fma_invalid_mul_is_nan
              float_of_single_preserves_sNaN.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import pb.
From Perennial.program_proof.pb Require Export ghost_proof.

(*
  Ownership/repr predicates for owning a ghost replica.

  The state of a replica is split into the core Replica state, the extra state
  that a Primary has, and the extra state that a Committer has. A committer is
  just a replica that also keeps information about what part of the log has been
  committed.
 *)
Section replica_ghost_defns.

Context `{!heapGS Σ}.
Context `{!urpcregG Σ}.
Context `{!pb_ghostG Σ}.
Implicit Type γ:pb_names.

Record Replica := mkReplica
{
  opLog : list u8;
  cn : u64;
}.

Definition own_Replica_ghost (rid:u64) γ (r:Replica) : iProp Σ :=
  "Haccepted" ∷ accepted_ptsto γ r.(cn) rid r.(opLog) ∗
  "HacceptedUnused" ∷ ([∗ set] cn_some ∈ (fin_to_set u64),
                      ⌜int.Z cn_some ≤ int.Z r.(cn)⌝ ∨ accepted_ptsto γ cn_some rid []
                      ) ∗
  "#Hproposal_lb" ∷ proposal_lb_fancy γ r.(cn) r.(opLog)
.

(* A primary is a replica with some more stuff; technically, the rid from the
   replica is not necessary to have a primary*)
Record PrimaryExtra := mkPrimaryExtra
{
  conf : list u64;
  matchIdx : list u64;
}.

Definition own_Primary_ghost γ (r:Replica) (p:PrimaryExtra) : iProp Σ :=
  "HprimaryOwnsProposal" ∷ proposal_ptsto γ r.(cn) r.(opLog) ∗
  "#HconfPtsto" ∷ config_ptsto γ r.(cn) p.(conf) ∗
  "#HmatchIdxAccepted" ∷ [∗ list] _ ↦ rid;j ∈ p.(conf); p.(matchIdx), accepted_lb γ r.(cn) rid (take (int.nat j) r.(opLog))
.

Record CommitterExtra := mkCommitterExtra
{
  commitIdx : u64;
}.

Definition own_Committer_ghost γ (r:Replica) (c:CommitterExtra) : iProp Σ :=
  "#Hcommit_lb" ∷ commit_lb_by γ r.(cn) (take (int.nat c.(commitIdx)) r.(opLog)) ∗
  "%HcommitLeLogLen" ∷ ⌜int.Z c.(commitIdx) <= length r.(opLog)⌝
.

End replica_ghost_defns.


Require Import VST.floyd.proofauto.
Require Import stdlib.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Parameter mem_mgr: globals -> mpred.
Parameter malloc_token': share -> Z -> val -> mpred.
Parameter malloc_token'_valid_pointer: forall sh sz p, malloc_token' sh sz p |-- valid_pointer p.
Axiom make_mem_mgr: forall gv, emp |-- mem_mgr gv.

Definition malloc_token {cs: compspecs} sh t v :=
   !! field_compatible t [] v &&
   malloc_token' sh (sizeof t) v.
Lemma malloc_token_valid_pointer: forall {cs: compspecs} sh t p, malloc_token sh t p |-- valid_pointer p.
Proof. intros. unfold malloc_token.
 apply andp_left2. apply malloc_token'_valid_pointer. Qed.

Hint Resolve malloc_token'_valid_pointer : valid_pointer.
Hint Resolve malloc_token_valid_pointer : valid_pointer.

Parameter malloc_token'_local_facts:  forall sh sz p, malloc_token' sh sz p |-- !! malloc_compatible sz p.
Lemma malloc_token_local_facts:  forall {cs: compspecs} sh t p, malloc_token sh t p |-- !! (field_compatible t [] p /\ malloc_compatible (sizeof t) p).
Proof. intros.
 unfold malloc_token.
 normalize. rewrite prop_and.
 apply andp_right. apply prop_right; auto.
 apply malloc_token'_local_facts.
Qed.
Hint Resolve malloc_token'_local_facts : saturate_local.
Hint Resolve malloc_token_local_facts : saturate_local.

Definition malloc_spec' :=
 DECLARE _malloc
   WITH n:Z, gv: globals
   PRE [ 1%positive OF size_t ]
       PROP (0 <= n <= Ptrofs.max_unsigned)
       LOCAL (temp 1%positive (Vptrofs (Ptrofs.repr n)); gvars gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv;
             if eq_dec p nullval then emp
            else (malloc_token' Ews n p * memory_block Ews n p)).

Definition free_spec' :=
 DECLARE _free
   WITH n:Z, p:val, gv: globals
   PRE [ 1%positive OF tptr tvoid ]
       PROP ()
       LOCAL (temp 1%positive p; gvars gv)
       SEP (mem_mgr gv;
              if eq_dec p nullval then emp
              else (malloc_token' Ews n p * memory_block Ews n p))
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr gv).

Definition exit_spec :=
 DECLARE _exit
 WITH u: unit
 PRE [1%positive OF tint]
   PROP () LOCAL() SEP()
 POST [ tvoid ]
   PROP(False) LOCAL() SEP().

Definition placeholder_spec :=
 DECLARE _placeholder
 WITH u: unit
 PRE [ ]
   PROP (False) LOCAL() SEP()
 POST [ tint ]
   PROP() LOCAL() SEP().

Definition ispecs := [placeholder_spec].
Definition specs := [malloc_spec'; free_spec'; exit_spec].

Definition malloc_spec  {cs: compspecs} (t: type) :=
 DECLARE _malloc
   WITH gv: globals
   PRE [ 1%positive OF size_t ]
       PROP (0 <= sizeof t <= Ptrofs.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       LOCAL (temp 1%positive (Vptrofs (Ptrofs.repr (sizeof t))); gvars gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv;
             if eq_dec p nullval then emp
            else (malloc_token Ews t p * data_at_ Ews t p)).

Definition free_spec  {cs: compspecs} (t: type) :=
 DECLARE _free
   WITH p: val, gv: globals
   PRE [ 1%positive OF tptr tvoid ]
       PROP ()
       LOCAL (temp 1%positive p; gvars gv)
       SEP (mem_mgr gv;
              if eq_dec p nullval then emp
              else (malloc_token Ews t p * data_at_ Ews t p))
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr gv).

Lemma malloc_spec_sub:
 forall {cs: compspecs} (t: type),
   funspec_sub (snd malloc_spec') (snd (malloc_spec t)).
Proof.
intros.
apply NDsubsume_subsume.
split; extensionality x; reflexivity.
split3; auto.
intros gv.
simpl in gv.
Exists (sizeof t, gv) emp.
change (liftx emp) with (@emp (environ->mpred) _ _).
rewrite !emp_sepcon.
apply andp_right.
entailer!.
match goal with |- _ |-- prop ?PP => set (P:=PP) end.
entailer!.
subst P.
Intros p.
Exists p.
entailer!.
if_tac; auto.
unfold malloc_token.
assert_PROP (field_compatible t [] p).
entailer!.
apply malloc_compatible_field_compatible; auto.
entailer!.
rewrite memory_block_data_at_; auto.
Qed.

Lemma free_spec_sub:
 forall {cs: compspecs} (t: type),
   funspec_sub (snd free_spec') (snd (free_spec t)).
Proof.
intros.
apply NDsubsume_subsume.
split; extensionality x; reflexivity.
split3; auto.
intros (p,gv).
simpl in gv.
Exists (sizeof t, p, gv) emp.
change (liftx emp) with (@emp (environ->mpred) _ _).
rewrite !emp_sepcon.
apply andp_right.
if_tac.
entailer!.
entailer!. simpl in H0.
unfold malloc_token. entailer!.
apply data_at__memory_block_cancel.
apply prop_right.
entailer!.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        KeyProperties
        SubtypingInversion
        Disjointness
        Deterministic
        Progress.

Require Import Arith Lia.

#[export]
Hint Extern 0 => match goal with
                   | [ H1: ~topLike ?A, H2: topLike (t_rcd _ ?A) |- _ ] => (exfalso; apply H1; inverts H2)
                 end : falseHd.

Theorem consistent_sound: forall v1 v2 A B,
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    consistent v1 v2 -> consistencySpec v1 v2.
Proof.
  intros v1 v2 A B Val1 Val2 Typ1 Typ2 Cons.
  unfolds. intros C v1' v2' Ord R1 R2.
  forwards*: TypedReduce_unique Cons.
Qed.

Lemma consistent_mergel: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistent (e_merge v1 v2) v -> consistent v1 v /\ consistent v2 v.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  inductions H.
  -
    inverts H.
    lets* (?&?): disjoint_splitl H1.
  - split; eauto.
  - forwards (?&?): IHconsistent1; try reflexivity; auto.
    forwards (?&?): IHconsistent2; try reflexivity; auto.
Qed.

Lemma consistent_merger: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistent v (e_merge v1 v2) -> consistent v v1 /\ consistent v v2.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  inductions H.
  -
    inverts H0.
    lets* (?&?): disjoint_splitr H1.
  - forwards (?&?): IHconsistent1; try reflexivity; auto.
    forwards (?&?): IHconsistent2; try reflexivity; auto.
  - split; eauto.
Qed.

Lemma consistencySpec_mergel: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistencySpec (e_merge v1 v2) v -> consistencySpec v1 v /\ consistencySpec v2 v.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  split; unfolds; intros.
  - forwards*: H A.
  - forwards*: H A.
Qed.

Lemma consistencySpec_merger: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistencySpec v (e_merge v1 v2) -> consistencySpec v v1 /\ consistencySpec v v2.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  split; unfolds; intros.
  - forwards*: H A.
  - forwards*: H A.
Qed.

Lemma topLike_disjoint: forall A B,
    topLike A -> disjointSpec A B.
Proof.
  intros A B H.
  unfolds. intros C H0 H1.
  apply topLike_super_top in H.
  apply topLike_super_top.
  auto_sub.
Qed.

Lemma disjoint_or_exists: forall A B,
    disjoint A B \/ exists C, ord C /\ algo_sub A C /\ algo_sub B C /\ ~ topLike C.
Proof with solve_false.
  intros A B. gen B.
  induction A; intros; auto.
  - induction B; auto.
    + right. exists t_int.
      repeat split~...
    + lets [?|(?&?&?&?&?)]: IHB1.
      * lets [?|(?&?&?&?&?)]: IHB2.
        ** left*.
        ** right. exists* x.
      * right. exists* x.
  - clear IHA1.
    induction B; auto.
    + clear IHB1 IHB2.
      lets [?|(?&?&?&?&?)]: (IHA2 B2); jauto.
      * right. exists* (t_arrow (t_and A1 B1) x).
    + lets [?|(?&?&?&?&?)]: IHB1.
      * lets [?|(?&?&?&?&?)]: IHB2; auto.
        ** right. exists* x.
      * right. exists* x.
  - lets [?|(?&?&?&?&?)]: IHA1.
    lets [?|(?&?&?&?&?)]: IHA2.
    * left*.
    * right. exists* x.
    * right. exists* x.
  - (* rcd *)
    induction~ B.
    + lets [?|(?&?&?&?&?)]: IHB1.
      * lets [?|(?&?&?&?&?)]: IHB2; auto.
        ** right. exists* x.
      * right. exists* x.
    + destruct* (l == l0). subst.
      lets~ [?|(?&?&?&?&?)]: (IHA B).
      right. exists (t_rcd l0 x). splits*.
      intros HF. apply H2. inverts~ HF.
Qed.

Lemma consistencySpec_lams_inv : forall T1 T2 e1 e2 A1 A2 B1 B2,
    Typing nil (e_abs A1 e1 B1) Inf T1 -> Typing nil (e_abs A2 e2 B2) Inf T2 ->
    consistencySpec (e_abs A1 e1 B1) (e_abs A2 e2 B2) -> disjoint B1 B2 \/ (e1=e2) /\ (A1=A2).
Proof.
  introv Typ1 Typ2 Cons.
  inverts keep Typ1. inverts keep Typ2.
  lets~ [?|(?&?&?&?&?)]: disjoint_or_exists B1 B2.
  right.
  assert (S1: algo_sub (t_arrow A1 B1) (t_arrow (t_and A1 A2) x)) by auto_sub.
  assert (S2: algo_sub (t_arrow A2 B2) (t_arrow (t_and A1 A2) x)) by auto_sub.
  forwards~ T1: Typ_sub Typ1 S1.
  forwards~ T2: Typ_sub Typ2 S2.
  forwards* (?&R1) : TypedReduce_progress T1.
  forwards* (?&R2) : TypedReduce_progress T2.
  forwards~ : Cons R1 R2.
  inverts keep R1; inverts keep R2; solve_false.
  (* TEMP0 : e_abs A0 e0 x = e_abs A e x *)
  inverts~ TEMP0.
Qed.

Lemma consistencySpec_rcd_inv : forall T1 T2 l v1 v2,
    value v1 -> value v2 -> nil ⊢ v1 ⇒ T1 -> nil ⊢ v2 ⇒ T2 ->
    consistencySpec (e_rcd l v1) (e_rcd l v2) -> consistencySpec v1 v2.
Proof.
  intros T1 T2 l v1 v2 Val1 Val2 Typ1 Typ2 Cons.
  unfolds. introv Ord R1 R2.
  destruct (toplike_decidable A).
  - forwards~: TypedReduce_toplike R1 R2.
  - forwards*: Cons (t_rcd l A).
    inversion~ H0.
Qed.

Ltac indExpSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : exp |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
    | intros ].

Theorem consistent_complete: forall v1 v2 A B,
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    consistencySpec v1 v2 -> consistent v1 v2.
Proof with (simpl; try lia; auto).
  intros v1 v2 A B Val1 Val2 Typ1 Typ2 Cons. gen Val1 Val2 Cons A B.
  indExpSize (size_exp v1 + size_exp v2);
  inverts Val1 as V1_1 V1_2; inverts Val2 as V2_1 V2_2; simpl in SizeInd;
    try solve [
          inverts Typ1 as T1_1 T1_2; inverts Typ2 as T2_1 T2_2;
            match goal with
            | |- consistent (e_merge _ _) _ =>
              ( lets~ (C1&C2): consistencySpec_mergel Cons;
                forwards*: IH C1; simpl; try lia; auto;
                try forwards*: IH C2; simpl; try lia; auto
              )
            | |- consistent _ (e_merge _ _) =>
              ( lets~ (C1&C2): consistencySpec_merger Cons;
                forwards*: IH C1; simpl; try lia; auto;
                try forwards*: IH C2; simpl; try lia; auto
              )
            | _ =>
              ( applys C_disjoint; constructor* )
            end].
  - (* lit *)
    inverts keep Typ1; inverts keep Typ2.
    enough (i5=i0).
    subst~.
    forwards* (?&R1) : TypedReduce_progress (e_lit i0).
    forwards* (?&R2) : TypedReduce_progress (e_lit i5).
    forwards*: Cons. subst*.
    forwards R1': TReduce_refl i0. forwards R2': TReduce_refl i5.
    forwards*: TypedReduce_unique R1 R1'.
    forwards*: TypedReduce_unique R2 R2'.
    congruence.
  - (* abs *)
    forwards* [?|(?&?)]: consistencySpec_lams_inv Cons.
    + applys* C_disjoint.
    + subst*.
  - (* rcd *)
    inverts keep Typ1; inverts keep Typ2.
    destruct (l0==l1).
    + subst*.
      forwards~ Con': consistencySpec_rcd_inv H1 H2 Cons.
      forwards*: IH Con'...
    + applys C_disjoint; constructor*.
Qed.

Lemma consistent_lams_inv : forall T1 T2 e1 e2 A1 A2 B1 B2,
    Typing nil (e_abs A1 e1 B1) Inf T1 -> Typing nil (e_abs A2 e2 B2) Inf T2 ->
    consistent (e_abs A1 e1 B1) (e_abs A2 e2 B2) -> disjoint B1 B2 \/ (e1=e2) /\ (A1=A2).
Proof.
  introv Typ1 Typ2 Cons.
  eapply consistent_sound in Cons; eauto.
  forwards* : consistencySpec_lams_inv Cons.
Qed.

Lemma consistent_rcd_inv : forall l v1 v2,
    consistent (e_rcd l v1) (e_rcd l v2) -> consistent v1 v2.
Proof.
  intros l v1 v2 H.
  inverts~ H.
  - inverts H0. inverts H1.
    enough (Dis: disjoint A0 A).
    applys* C_disjoint Dis. eauto.
Qed.

#[export]
Hint Immediate consistent_rcd_inv : core.