Require Import mimperative mlattice language types mmemory id_and_loc Arith LibTactics tactics decision Coq.Program.Equality augmented low_equivalence List Coq.Program.Tactics.

Module Preservation (L : Lattice) (M : Memory L).
  Module LowEq := LowEquivalence L M.
  Import LowEq B Aug Imp TDefs M T MemProp LatProp Lang L.

  Ltac invert_var_typing :=
    match goal with
      [H: expr_has_type _ (Var _) _ |- _] =>
      inverts H
    end.

Lemma array_type_is_not_recursive:
  forall t l ℓ,
    SecType (Array t ℓ) l = t -> False.
Proof.
  apply (sectype_mut (fun t => forall l ℓ, Array (SecType t l) ℓ = t -> False)
                     (fun sect => forall l ℓ, SecType (Array sect ℓ) l = sect -> False)).
  - intros.
    discriminate.
  - intros.
    injects.
    eauto.
  - intros.
    injects.
    eauto.
Qed.

Lemma lookup_in_bounds_extend:
  forall x m h loc l n v H1 H2,
    (forall loc', v = ValLoc loc' -> reach m h loc') ->
    ~ reach m h loc ->
    dangling_pointer_free m h ->
    lookup_in_bounds m h ->
    lookup_in_bounds (extend_memory x (ValLoc loc) m) (h [loc → (n × v, l), H1, H2]).
Proof.
  intros.
  unfolds.
  intros.
  destruct (decide (loc0 = loc)); subst.
  - rewrite -> length_of_extend_eq in *.
    rewrite_inj.
    apply_heap_lookup_extend_eq.
    rewrite_inj.
    eauto.
  - rewrite -> length_of_extend_neq in * by solve[eauto].
    rewrite -> heap_lookup_extend_neq in * by solve[eauto 2].
    rewrite_inj.
    assert (reach m h loc0) by eauto 2 using reach_extend_implies_reach_if.
    eauto.
Qed.

Lemma wf_stenv_subset:
  forall Σ h1 h2 H,
    wf_stenv Σ ([h1 ⊎ h2, H]) -> wf_stenv Σ h1.
Proof.
  intros.
  unfold wf_stenv in *.
  intros.
  super_destruct'.
  splits*.
Qed.
Hint Resolve wf_stenv_subset.

Lemma reach_supset:
  forall m h1 h2 loc H,
    reach m h1 loc ->
    reach m ([h1 ⊎ h2, H]) loc.
Proof.
  intros.
  induction H0; eauto.

  Unshelve.
  - repeat constructor.
Qed.
Hint Resolve reach_supset.

Lemma reach_supset':
  forall m h1 h2 loc H,
    reach m h2 loc ->
    reach m ([h1 ⊎ h2, H]) loc.
Proof.
  intros.
  induction H0; eauto.

  specialize (IHreach H).
  assert (heap_lookup loc ([h1 ⊎ h, H]) = Some (ℓ, μ)).
  {
    rewrite -> disjoint_union_sym.
    eauto.
  }
  eauto.
  Unshelve.
  - repeat constructor.
Qed.
Hint Resolve reach_supset'.

Lemma consistent_subset_helper:
  forall m h1 h2 Γ Σ H,
    consistent m ([h1 ⊎ h2, H]) Γ Σ ->
    consistent m h1 Γ Σ /\ consistent m h2 Γ Σ.
Proof.
  intros.
  destruct_consistent.
  splits*.
  - unfolds.
    splits*.
  - unfolds.
    splits*.
    intros.
    eapply H1.
    + eauto.
    + eauto.
    + rewrite -> disjoint_union_sym by eauto.
      eauto.
    + eauto.

Qed.
Hint Resolve consistent_subset_helper.

Lemma consistent_subset:
  forall m h1 h2 Γ Σ H,
    consistent m ([h1 ⊎ h2, H]) Γ Σ ->
    consistent m h1 Γ Σ.
Proof.
  intros.
  edestruct consistent_subset_helper; eauto.
Qed.
Hint Resolve consistent_subset.

Lemma dangling_pointer_free_subset:
  forall m h1 h2 H,
    dangling_pointer_free m ([h1 ⊎ h2, H]) ->
    (forall loc ℓ μ,
        heap_lookup loc h2 = Some (ℓ, μ) -> ~ reach m ([h1 ⊎ h2, H]) loc) ->
    dangling_pointer_free m h1.
Proof.
  intros.
  unfolds.
  intros.
  assert (exists ℓ μ, heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ)) by eauto.
  super_destruct.
  exists ℓ μ.
  destruct (disjoint_union_heap_lookup2 h1 h2 loc ℓ μ _ H3).
  - eauto.
  - assert (~ reach m ([h1 ⊎ h2, H]) loc) by eauto.
    assert (reach m ([h1 ⊎ h2, H]) loc) by eauto using reach_supset.
    contradiction.
Qed.
Hint Resolve dangling_pointer_free_subset.

Lemma lookup_in_bounds_subset:
  forall m h1 h2 H,
    dangling_pointer_free m h1 ->
    lookup_in_bounds m ([h1 ⊎ h2, H]) ->
    (forall loc ℓ μ,
        heap_lookup loc h2 = Some (ℓ, μ) -> ~ reach m ([h1 ⊎ h2, H]) loc) ->
    lookup_in_bounds m h1.
Proof.
  intros.
  unfold lookup_in_bounds in *.
  intros.
  assert (exists ν, heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, ν)) by eauto.
  super_destruct.
  assert (exists v, lookup ν n = Some v) by eauto.
  super_destruct.
  exists v.
  super_destruct.
  destruct_disjoint_heap_lookup.
  + congruence.
  + assert (heap_lookup loc h1 = None).
    {
      eapply disjoint_union_heap_lookup3.
      - rewrite -> disjoint_union_sym.
        erewrite -> disjoint_union_proof_irrelevance.
        eauto.
        Unshelve.
        eauto.
      - eauto.
    }
    match goal with
      [H: dangling_pointer_free _ _,
          H2: reach _ _ _ |- _] =>
      unfolds in H;
        specialize (H loc H2)
    end.
    destruct_exists.
    rewrite_inj.
    discriminate.
Qed.
Hint Resolve lookup_in_bounds_subset.

Lemma heap_level_bound_subset:
  forall m h1 h2 Γ Σ H,
    heap_level_bound Γ m ([h1 ⊎ h2, H]) Σ ->
    heap_level_bound Γ m h1 Σ.
Proof.
  intros.
  splits*.
Qed.
Hint Resolve heap_level_bound_subset.

Lemma reach_from_supset:
  forall x m h1 h2 loc H,
    reach_from x m h1 loc ->
    reach_from x m ([h1 ⊎ h2, H]) loc.
Proof.
  intros.
  unfold reach_from in *.
  super_destruct.
  eexists.
  dependent induction H0; eauto.
Qed.
Hint Resolve reach_from_supset.

Lemma gc_preserves_wf:
  forall c pc pc' m h1 h2 h3 t Γ Σ δ H1 H2 H3,
    ([h1 ⊎ h3, H1]) ⇝ (m, δ) h1 ->
    disjoint ([h1 ⊎ h2, H2]) h3 ->
    (forall loc ℓ μ, heap_lookup loc h3 = Some (ℓ, μ) -> ~ reach m ([([h1 ⊎ h2, H2]) ⊎ h3, H3]) loc) ->
    wellformed_aux Γ Σ ⟨ c, pc, m, [([h1 ⊎ h2, H2]) ⊎ h3, H3], t ⟩ pc' ->
    wellformed_aux Γ Σ ⟨ c, pc, m, [h1 ⊎ h2, H2], t + δ ⟩ pc'.
Proof.
  intros.
  induction c; constructor; invert_wf_aux; eauto.
Qed.
Hint Resolve gc_preserves_wf.

Lemma location_is_from_lookup_simple:
  forall Γ level m e loc,
    wf_tenv Γ m ->
    {{Γ ⊢ e : level}} ->
    eval m e = Some (ValLoc loc) ->
    exists x,
      memory_lookup m x = Some (ValLoc loc) /\ e = Var x.
Proof.
  intros.
  assert (exists x, e = Var x) by eauto using location_is_from_lookup.
  super_destruct; subst.
  exists x.
  splits*.
Qed.
Hint Resolve location_is_from_lookup_simple.

Lemma var_exp_has_type_is_env_lookup:
  forall Γ x t,
    {{Γ ⊢ Var x : t}} ->
    Γ x = Some t.
Proof.
  intros.
  inverts H; eauto.
Qed.
Hint Resolve var_exp_has_type_is_env_lookup.

Lemma reach_update_with_num:
  forall m h loc1 loc2 n k,
    reach m (update_heap loc1 n (ValNum k) h) loc2 ->
    reach m h loc2.
Proof.
  intros.
  dependent induction H.
  - eauto.
  - destruct (decide (loc1 = loc)); subst.
    + assert (exists ν, heap_lookup loc h = Some (ℓ, ν) /\ μ = update_lookup ν n (ValNum k)) by eauto.
      super_destruct; subst.
      destruct (decide (n = n0)); subst.
      * rewrite -> lookup_update_eq in *.
        discriminate.
      * rewrite -> lookup_update_neq in * by solve[eauto].
        eauto.
    + rewrite -> heap_lookup_update_neq in * by solve[eauto].
      eauto.
      Unshelve.
      * constructor; eauto.
      * repeat constructor; eauto.
Qed.

Lemma reach_by_update_implies_reach_if:
  forall m h l n loc1 loc2,
    reach m (update_heap l n (ValLoc loc1) h) loc2 ->
    reach m h loc1 ->
    reach m h loc2.
Proof.
  intros.
  dependent induction H.
  - eauto.
  - specialize_gen.
    destruct (decide (loc = l)); subst.
    + assert (exists ν, heap_lookup l h = Some (ℓ, ν) /\ μ = update_lookup ν n (ValLoc loc1))
        by eauto.
      super_destruct; subst.
      destruct (decide (n = n0)); subst.
      * rewrite -> lookup_update_eq in *.
        rewrite_inj.
        eauto.
      * rewrite -> lookup_update_neq in * by solve[eauto].
        eauto.
    + rewrite -> heap_lookup_update_neq in * by solve[eauto].
      eauto.
      Unshelve.
      * constructor; eauto.
      * repeat constructor; eauto.
Qed.

Lemma reach_extend2:
  forall m h x loc1 loc2 loc3 n ℓ μ,
    heap_lookup loc1 h = Some (ℓ, μ) ->
    lookup μ n = Some (ValLoc loc2) ->
    reach m h loc1 ->
    reach (extend_memory x (ValLoc loc2) m) h loc3 -> reach m h loc3.
Proof.
  intros.
  dependent induction H2.
  - destruct (decide (x = x0)); subst.
    * rewrite -> extend_memory_lookup_eq in *.
      rewrite_inj.
      eauto.
    * rewrite -> extend_memory_lookup_neq in * by solve[eauto].
      eauto.
  - assert (reach m h loc) by eauto.
    eauto.

    Unshelve.
    + constructor; eauto.
    + repeat constructor; eauto.
    + constructor; eauto.
Qed.

Lemma reach_from_implies_array_type:
  forall Γ x t l m h loc,
    wf_tenv Γ m ->
    Γ x = Some (SecType t l) ->
    reach_from x m h loc ->
    exists s ℓ, t = Array s ℓ.
Proof.
  intros.
  unfold reach_from in *.
  super_destruct.
  revert loc H1.
  induction k; intros; subst.
  - inverts H0.
    inverts H1.
    destruct t; eauto.
    assert (exists n, ValLoc loc = ValNum n) by eauto.
    super_destruct; discriminate.
  - inverts H1.
    eauto.
Qed.
Hint Resolve reach_from_implies_array_type.

Lemma no_backat_implies_wt_aux_mono:
  forall Γ pc c pc',
    ~ contains_backat c ->
    wt_aux Γ pc c pc' ->
    pc = pc'.
Proof.
  intros.
  dependent induction H0; eauto 2.
  - firstorder.
    congruence.
  - exfalso; eauto 2.
Qed.
Hint Resolve no_backat_implies_wt_aux_mono.

Lemma preservation:
  forall tenv stenv stenv' c1 pc1 m1 h1 t1 c2 pc2 m2 h2 t2 pc',
    wellformed_aux tenv stenv (Config c1 pc1 m1 h1 t1) pc' ->
    step (Config c1 pc1 m1 h1 t1) (Config c2 pc2 m2 h2 t2) tenv stenv stenv' ->
    wellformed_aux tenv stenv' (Config c2 pc2 m2 h2 t2) pc'.
Proof.
  intros tenv stenv stenv' c1 pc1 m1 h1 t1.
  intros c2 pc2 m2 h2 t2 pc' H_wf H_step.
  revert pc' c2 pc2 m2 h2 t2 H_wf H_step.
  induction c1; intros; invert_step; subst; invert_wf_aux; subst.
  (* Skip *)
  - apply WellformedAux; intros; auto || (exfalso; eauto).
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  - eauto.
  (* Assign *)
  - assert ((i ::= e) <> Stop) by (intro H_absurd; discriminate H_absurd).
    do 2 specialize_gen.
    invert_wt_cmd.
    apply WellformedAux; eauto.
    + invert_lifted.
      rewrite_inj.
      eapply wf_tenv_extend with (t := σ); intros; (repeat subst); eauto.
    + unfolds.
      splits*.
      { intros.
        destruct (decide (i = x)); subst.
        - rewrite -> extend_memory_lookup_eq in *.
          rewrite_inj.
          assert (exists x, memory_lookup m1 x = Some (ValLoc loc) /\ e = Var x) by eauto 2.
          super_destruct'; subst.
          invert_var_typing.
          invert_lifted.
          eauto.
        - rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          eauto 2.
      }
      {
        intros.
        destruct_consistent.
        destruct v.
        {
          assert (reach m1 h2 loc1) by eauto 2 using reach_extend_with_num.
          eauto.
        }
        {
          destruct (decide (l0 = loc1)); subst.
          - assert (exists x, memory_lookup m1 x = Some (ValLoc loc1) /\ e = Var x) by eauto.
            super_destruct; subst.
            eauto.
          - assert (exists x, memory_lookup m1 x = Some (ValLoc l0) /\ e = Var x) by eauto.
            super_destruct; subst.
            eauto.
        }
      }
    + intros; exfalso; eauto.
    + (* Show: New memory is free of dangling pointers *)
      unfolds.
      intros.
      invert_lifted.
      rewrite_inj.
      invert_reach.
      * destruct (decide (i = x)); subst.
        {
          rewrite -> extend_memory_lookup_eq in *.
          rewrite_inj.
          match goal with
            [H: eval _ ?e = Some (ValLoc _) |- _] => destruct e
          end.
          - discriminate.
          - eauto.
          - assert (exists n, ValLoc loc = ValNum n)
              by eauto using eval_binop_is_num.
            destruct_exists.
            discriminate.
        }
        {
          rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          eauto.
        }
      * unfold dangling_pointer_free in *.
        inverts H1.
        {
          destruct (decide (i = x)); subst.
          - rewrite -> extend_memory_lookup_eq in *.
            rewrite_inj.
            assert (exists x, memory_lookup m1 x = Some (ValLoc loc0) /\ e = Var x) by eauto.
            super_destruct; subst.
            eauto.
          - rewrite -> extend_memory_lookup_neq in * by solve[eauto].
            eauto.
        }
        {
          destruct v.
          - assert (reach m1 h2 loc) by eauto using reach_extend_with_num.
            eauto.
          - assert (exists x, memory_lookup m1 x = Some (ValLoc l) /\ e = Var x) by eauto.
            super_destruct; subst.
            destruct (decide (loc1 = l)); subst.
            + eauto.
            + assert (reach m1 h2 l) by eauto.
              eauto using reach_extend.
        }
    + invert_lifted.
      rewrite_inj.
      unfolds.
      intros.
      destruct v.
      * assert (reach m1 h2 loc) by eauto using reach_extend_with_num.
        eauto.
      * assert (exists x, memory_lookup m1 x = Some (ValLoc l) /\ e = Var x) by eauto.
        super_destruct; subst.
        destruct (decide (loc = l)); subst; eauto using reach_extend.
    + unfolds.
      splits; eauto 2.
      intros.
      invert_lifted.
      rewrite_inj.
      destruct (decide (i = x)); subst.
      * rewrite -> extend_memory_lookup_eq in *.
        rewrite_inj.
        assert (exists x, memory_lookup m1 x = Some (ValLoc loc) /\ e = Var x) by eauto.
        super_destruct'; subst.
        invert_var_typing.
        eauto 2.
      * rewrite -> extend_memory_lookup_neq in * by solve[eauto].
        eauto 2.
      * intros.
        invert_lifted.
        destruct σ.
        { assert (exists n, v = ValNum n) by eauto.
          super_destruct'; subst.
          eauto using reach_extend_with_num.
        }
        { assert (exists loc, v = ValLoc loc) by eauto.
          super_destruct'; subst.
          destruct (decide (loc0 = loc)); subst.
          - assert (exists x, memory_lookup m1 x = Some (ValLoc loc) /\ e = Var x) by eauto.
            super_destruct; subst.
            eauto.
          - rewrite_inj.
            assert (reach m1 h2 loc).
            {
              eapply reach_extend.
              - eapply H0.
              - assert (exists x, memory_lookup m1 x = Some (ValLoc loc0) /\ e = Var x) by eauto.
                super_destruct; subst.
                eauto.
            }
            eauto 3.
        }
      * intros.
        invert_lifted.
        rewrite_inj.
        destruct σ.
        {
          assert (exists n, v = ValNum n) by eauto.
          super_destruct; subst.
          assert (reach m1 h2 loc1) by eauto 3 using reach_extend_with_num.
          eauto.
        }
        {
          assert (exists loc, v = ValLoc loc) by eauto.
          super_destruct; subst.
          assert (exists x, memory_lookup m1 x = Some (ValLoc loc) /\ e = Var x) by eauto.
          super_destruct; subst.
          assert (reach m1 h2 loc1).
          {
            eapply reach_extend.
            - eapply H0.
            - eauto.
          }
          eauto.
        }
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  - (* If *)
    assert ((If e c1_1 c2) <> Stop) by congruence.
    assert ((If e c1_1 c2) <> TimeOut) by congruence.
    do 2 specialize_gen.
    invert_wt_cmd.
    apply WellformedAux; intros; eauto.
  - assert ((If e c2 c1_2) <> Stop) by congruence.
    assert ((If e c2 c1_2) <> TimeOut) by congruence.
    do 2 specialize_gen.
    invert_wt_cmd.
    apply WellformedAux; intros; eauto.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto 2.
  - (* While *)
    assert ((While e c1) <> Stop) by congruence.
    assert ((While e c1) <> TimeOut) by congruence.
    do 2 specialize_gen.
    invert_wt_cmd.
    apply WellformedAux; try assumption.
    intros; exfalso; eauto.
  - assert ((While e c1) <> Stop) by congruence.
    assert ((While e c1) <> TimeOut) by congruence.
    do 2 specialize_gen.
    invert_wt_cmd.
    apply WellformedAux; intros; try assumption.
    apply (wt_aux_seq tenv pc' pc' pc'); eauto.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  (* Sequencing *)
  - assert ((c1_1;; c2) <> Stop) by congruence.
    assert ((c1_1;; c2) <> TimeOut) by congruence.
    do 2 specialize_gen.
    invert_wt_cmd.
    assert (pc2 = pc'0).
    {
      eauto 3 using wt_aux_soundness.
    }
    subst.
    assert (exists pc1', wellformed_aux tenv stenv ⟨c1_1, pc1, m1, h1, t1⟩ pc1') by eauto.
    super_destruct; subst.
    assert (wellformed_aux tenv stenv' ⟨STOP, pc'0, m2, h2, t2⟩ pc1') by eauto.
    destruct_exists.
    invert_wf_aux.
    apply WellformedAux; intros; eauto.
  - assert ((c1_1 ;; c1_2) <> Stop) by congruence.
    assert ((c1_1 ;; c1_2) <> TimeOut) by congruence.
    do 2 specialize_gen.
    clear H.
    invert_wt_cmd.
    assert (wellformed_aux tenv stenv ⟨c1_1, pc1, m1, h1, t1⟩ pc'0) by eauto.
    assert (wellformed_aux tenv stenv' ⟨c1', pc2, m2, h2, t2⟩ pc'0) by eauto.
    destruct_exists.
    invert_wf_aux.
    apply WellformedAux; intros; try assumption.
    + repeat specialize_gen.
      eapply wt_aux_seq; eauto.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  (* At *)
  - apply WellformedAux; intros; try assumption.
    assert (At pc2 e c1 <> Stop) by congruence.
    assert (At pc2 e c1 <> TimeOut) by congruence.
    do 2 specialize_gen.
    invert_wt_cmd.
    eapply wt_aux_seq.
    + eauto.
    + assert (pc2 = ℓ'') by eauto 2 using no_backat_implies_wt_aux_mono.
      subst.
      constructors; eauto 2 using flowsto_refl.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  (* Backat with wait *)
  - apply WellformedAux; eauto.
  (* Backat with progress *)
  - assert (BackAt pc2 t1 <> Stop) by congruence.
    assert (BackAt pc2 t1 <> TimeOut) by congruence.
    do 2 specialize_gen.
    clear H.
    invert_wt_cmd.
    apply WellformedAux; eauto.
    intro; exfalso; eauto.
  - assert (BackAt pc2 t1 <> Stop) by congruence.
    assert (BackAt pc2 t1 <> TimeOut) by congruence.
    do 2 specialize_gen.
    constructor; eauto 2.
    intros.
    exfalso; eauto 2.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  (* new *)
  - let H1 := fresh in let H2 := fresh in
    assert (NewArr i l e e0 <> Stop) as H1 by congruence;
      assert (NewArr i l e e0 <> TimeOut) as H2 by congruence;
      do 2 specialize_gen;
      clear H1; clear H2.
    invert_wt_cmd.
    rewrite_inj.
    apply WellformedAux; eauto.
    + destruct τ0 as [σ ℓ].
      eapply wf_tenv_extend; eauto.
      intro; discriminate.
    + destruct τ0 as [σ ℓ].
      eapply wf_stenv_extend; intros; subst; eauto.
    + unfolds.
      splits.
      * intros.
        destruct (decide (i = x)); subst.
        {
          rewrite -> extend_memory_lookup_eq in *.
          rewrite_inj.
          unfold extend_stenv.
          rewrite -> eq_loc.
          rewrite_inj.
          reflexivity.
        }
        {
          rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          destruct (decide (l1 = loc)); subst.
          - invert_dang_free; eauto.
            assert (exists ℓ μ, heap_lookup loc h1 = Some (ℓ, μ)) by eauto.
            destruct_exists.
            rewrite_inj.
            discriminate.
          - unfold extend_stenv.
            rewrite -> neq_loc by eauto.
            destruct_consistent.
            eauto.
        }
      * intros.
        destruct (decide (loc1 = l1)); subst.
        {
          rewrite -> extend_stenv_lookup_eq in *.
          apply_heap_lookup_extend_eq.
          assert (v = ValLoc loc2).
          {
            match goal with
              [H1: forall _, lookup _ _ = Some _,
               H2: lookup _ ?n = Some _ |- _] =>
              specialize (H1 n)
            end.
            rewrite_inj.
            reflexivity.
          }
          subst.
          rewrite_inj.
          assert (exists y, memory_lookup m1 y = Some (ValLoc loc2) /\ e0 = Var y) by eauto.
          super_destruct; subst.
          assert (exists ℓ μ, heap_lookup loc2 h1 = Some (ℓ, μ)) by eauto.
          super_destruct.
          rewrite_inj.
          assert (l1 <> loc2).
          {
            intro.
            subst.
            rewrite_inj.
            discriminate.
          }
          rewrite -> extend_stenv_lookup_neq by solve[eauto].
          eauto.
        }
        {
          rewrite -> extend_stenv_lookup_neq in * by solve[eauto].
          rewrite -> heap_lookup_extend_neq in * by solve[eauto 2].
          destruct (decide (l1 = loc2)); subst.
          - assert (~ reach m1 h1 loc2).
            {
              intro.
              assert (exists ℓ μ, heap_lookup loc2 h1 = Some (ℓ, μ)) by eauto.
              super_destruct.
              rewrite_inj.
              discriminate.
            }
            assert (~ reach m1 h1 loc1).
            {
              intro.
              eauto.
            }
            assert (forall loc' : loc, v = ValLoc loc' -> reach m1 h1 loc').
            {
              intros; subst.
              assert (exists x, memory_lookup m1 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
              super_destruct; subst.
              eauto.
            }
            match goal with
              [H: ~ reach _ _ loc1 |- _] =>
              contradict H
            end.
            eauto 2 using reach_extend_implies_reach_if.
          - rewrite -> extend_stenv_lookup_neq by solve[eauto].
            destruct_consistent.
            assert (forall loc' : loc, v = ValLoc loc' -> reach m1 h1 loc').
            {
              intros; subst.
              assert (exists x, memory_lookup m1 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
              super_destruct; subst.
              eauto.
            }
            assert (~ reach m1 h1 l1).
            {
              intro.
              assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
              super_destruct; subst.
              rewrite_inj.
              discriminate.
            }
            assert (reach m1 h1 loc1) by eauto 2 using reach_extend_implies_reach_if.
            eauto.
        }
    + (* Show: Stop is Welltyped *)
      intro.
      exfalso; eauto.

    + (* Show: Dangling free memory and heap *)
      unfolds.
      intros.
      destruct (decide (l1 = loc)); subst.
      * assert (exists μ,
                   heap_lookup loc (h1 [loc → (n × v, l), H1, H2]) = Some (l, μ) /\
                   (forall n0 : nat, lookup μ n0 = Some v)) by eauto.
        super_destruct; subst.
        eauto.
      * assert (forall loc' : id_and_loc.loc, v = ValLoc loc' -> reach m1 h1 loc').
        {
          intros; subst.
          assert (exists x, memory_lookup m1 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
          super_destruct; subst.
          eauto.
        }
        assert (loc <> l1) by eauto.
        assert (~ reach m1 h1 l1).
        {
          intro.
          assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
          super_destruct; subst.
          rewrite_inj.
          discriminate.
        }
        assert (reach m1 h1 loc) by eauto 2 using reach_extend_implies_reach_if.
        destruct_consistent.
        rewrite -> heap_lookup_extend_neq by solve[eauto].
        eauto.
    + eapply lookup_in_bounds_extend; eauto 2.
      * intros; subst.
        assert (exists x, memory_lookup m1 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
        super_destruct; subst.
        eauto.
      * intro.
        assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
        super_destruct; subst.
        rewrite_inj.
        discriminate.
    + unfolds.
      splits.
      * intros.
        destruct (decide (i = x)); subst.
        {
          rewrite -> extend_memory_lookup_eq in *.
          rewrite_inj.
          apply_heap_lookup_extend_eq.
          rewrite_inj.
          reflexivity.
        }
        {
          rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          destruct (decide (loc = l1)); subst.
          - edestruct (heap_lookup_extend_eq l1 l n v h1); eauto 2.
            super_destruct.
            rewrite_inj.
            invert_dang_free.
            assert (exists ℓ μ, heap_lookup l1 h1 = Some (ℓ, μ)) by eauto.
            destruct_exists.
            rewrite_inj.
            discriminate.
          - rewrite -> heap_lookup_extend_neq in * by solve[eauto].
            eauto 2.
        }
      * intros.
        destruct (decide (loc = l1)); subst.
        {
          rewrite -> extend_stenv_lookup_eq in *.
          rewrite_inj.
          apply_heap_lookup_extend_eq.
          rewrite_inj.
          destruct (decide (loc' = l1)); subst.
          - rewrite_inj.
            assert (v = ValLoc l1) by congruence.
            subst.
            assert (exists x, memory_lookup m1 x = Some (ValLoc l1) /\ e0 = Var x) by eauto.
            super_destruct'; subst.
            assert (reach m1 h1 l1) by eauto.
            assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
            super_destruct; subst.
            congruence.
          - rewrite -> heap_lookup_extend_neq in * by solve[eauto].
            assert (exists loc, v = ValLoc loc) by eauto.
            super_destruct'; subst.
            assert (exists x, memory_lookup m1 x = Some (ValLoc loc) /\ e0 = Var x) by eauto.
            super_destruct; subst.
            invert_var_typing.
            assert (loc = loc') by congruence; subst.
            symmetry.
            eauto 2.
        }
        {
          rewrite -> heap_lookup_extend_neq in * by solve[eauto].
          rewrite -> extend_stenv_lookup_neq in * by solve[eauto].
          destruct (decide (loc' = l1)); subst.
          - apply_heap_lookup_extend_eq.
            rewrite_inj.
            assert (~ reach m1 h1 l1).
            {
              intro.
              assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
              super_destruct; congruence.
            }
            assert (reach m1 h1 loc).
            {
              assert (forall loc', v = ValLoc loc' -> reach m1 h1 loc').
              {
                intros; subst.
                assert (exists x, memory_lookup m1 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
                super_destruct; subst.
                eauto.
              }
              eapply reach_extend_implies_reach_if; eauto.
            }
            assert (reach m1 h1 l1) by eauto 2.
            contradiction.
          - rewrite -> heap_lookup_extend_neq in * by solve[eauto].
            assert (~ reach m1 h1 l1).
            {
              intro.
              assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
              super_destruct; congruence.
            }
            assert (reach m1 h1 loc).
            {
              assert (forall loc', v = ValLoc loc' -> reach m1 h1 loc').
              {
                intros; subst.
                assert (exists x, memory_lookup m1 x = Some (ValLoc loc'0) /\ e0 = Var x) by eauto.
                super_destruct; subst.
                eauto.
              }
              eapply reach_extend_implies_reach_if; eauto.
            }
            eauto 2.
        }
      * intros.
        destruct (decide (loc1 = l1)); subst.
        {
          apply_heap_lookup_extend_eq.
          rewrite_inj.
          destruct (decide (loc2 = l1)); subst.
          - rewrite_inj.
            eapply flowsto_refl.
          - rewrite -> heap_lookup_extend_neq in * by solve[eauto].
            assert (wf_type bot (SecType (Array τ0 l) (ℓ_x, ∘))) by eauto.
            invert_wf_type.
            assert (v = ValLoc loc2) by congruence; subst.
            assert (exists x, memory_lookup m1 x = Some (ValLoc loc2) /\ e0 = Var x) by eauto.
            super_destruct; subst.
            invert_var_typing.
            destruct τ0 as [τ ε].
            assert (exists t, τ = Array t ℓ2).
            {
              destruct τ.
              - assert (exists n, ValLoc loc2 = ValNum n) by eauto.
                super_destruct; congruence.
              - exists s.
                eapply f_equal2; eauto 2.
            }
            super_destruct'; subst.
            invert_wf_type.
            eauto.
        }
        {
          rewrite -> heap_lookup_extend_neq in * by solve[eauto].
          assert (reach m1 h1 loc1).
          {
            assert (~ reach m1 h1 l1).
            {
              intro.
              assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
              super_destruct; congruence.
            }
            assert (forall loc' : loc, v = ValLoc loc' -> reach m1 h1 loc').
            {
              intros; subst.
              assert (exists x, memory_lookup m1 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
              super_destruct; subst.
              eauto.
            }
            eapply reach_extend_implies_reach_if; eauto.
          }
          destruct (decide (loc2 = l1)); subst.
          - apply_heap_lookup_extend_eq.
            rewrite_inj.
            assert (reach m1 h1 l1) by eauto 2.
            assert (exists l μ, heap_lookup l1 h1 = Some (l, μ)) by eauto.
            super_destruct; subst.
            congruence.
          - rewrite -> heap_lookup_extend_neq in * by solve[eauto].
            eauto 2.
        }
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  (* Set array *)
  - let H1 := fresh in let H2 := fresh in
      assert (SetArr i e e0 <> Stop) as H1 by congruence;
        assert (SetArr i e e0 <> TimeOut) as H2 by congruence;
      do 2 specialize_gen;
      clear H1; clear H2.
    apply WellformedAux; eauto.
    + unfolds.
      intros.
      splits~.
      * intros.
        destruct (decide (loc = l0)); subst.
        {
          _apply heap_lookup_update_eq2 in *.
          super_destruct; subst.

          destruct (decide (n0 = n)); subst.
          - rewrite -> lookup_update_eq in *.
            rewrite_inj.
            invert_wt_cmd.
            invert_lifted.
            assert (σ = Int).
            {
              match goal with
                [H: consistent _ _ _ _,
                    H2: stenv' _ = Some _ |- _] =>
                destruct H as [H _];
                  erewrite -> H in H2; eauto
              end.
              rewrite_inj.
              reflexivity.
            }
            subst.
            eauto.
          - rewrite -> lookup_update_neq in * by solve[eauto].
            eauto.
        }
        {
          assert (heap_lookup loc (update_heap l0 n v h1) = heap_lookup loc h1) by (apply heap_lookup_update_neq; assumption).
          rewrite -> heap_lookup_update_neq in * by solve[eauto].
          rewrite_inj.
          eauto.
        }
      * intros.
        destruct (decide (loc = l0)); subst.
        {
          _apply heap_lookup_update_eq2 in *; eauto 2.
          destruct_exists.
          super_destruct; subst.
          destruct (decide (n0 = n)); subst.
          - assert (heap_lookup l0 h1 <> None).
            {
              intro.
              assert (exists ℓ μ, heap_lookup l0 h1 = Some (ℓ, μ)) by eauto.
              super_destruct; congruence.
            }
            rewrite -> lookup_update_eq in *.
            rewrite_inj.
            assert (SetArr i e e0 <> Stop) by (intro H_absurd; discriminate H_absurd).
            invert_wt_cmd.
            invert_lifted.
            assert (exists ℓ, σ = Array t ℓ).
            {
              match goal with
                [H: consistent _ _ _ _,
                    H2: stenv' _ = Some _ |- _] =>
                destruct H as [H _];
                  erewrite -> H in H2; eauto
              end.
              rewrite_inj.
              eauto.
            }
            super_destruct; subst.
            eauto using wt_array_e_is_loc.
          - rewrite -> lookup_update_neq in *; eauto 2.
        }
        {
          rewrite -> heap_lookup_update_neq in * by solve[eauto].
          eauto.
        }
      * eauto.
      * intros.
        destruct (decide (loc = l0)); subst.
        {
          _apply heap_lookup_update_eq2 in *.
          super_destruct; eauto 2.
        }
        {
          rewrite -> heap_lookup_update_neq in * by solve[eauto 2].
          eauto 2.
        }
    + unfolds.
      splits~; eauto 2.
      intros.
      destruct (decide (loc1 = l0)); subst.
      * destruct (decide (n0 = n)); subst.
        {
          _apply heap_lookup_update_eq2 in *.
          destruct_exists.
          super_destruct; subst.
          rewrite -> lookup_update_eq in *.
          rewrite_inj.
          invert_wt_cmd.
          invert_lifted.
          edestruct location_is_from_lookup; eauto; subst.
          repeat match goal with
                   [H: expr_has_type _ (Var _) _ |- _] =>
                   inverts H
                 | [H: eval _ (Var _) = _ |- _] =>
                   inverts H
                 end.
          invert_dang_free.
          assert (exists ℓ μ, heap_lookup loc2 h1 = Some (ℓ, μ)) by eauto.
          match goal with
            [H: consistent _ _ _ _ |- _] =>
            destruct H as [H _]; erewrite -> H in * by eauto
          end.
          rewrite_inj.
          eauto.
        }
        {
          _apply heap_lookup_update_eq2 in *.
          super_destruct.
          subst.
          rewrite -> lookup_update_neq in * by solve[eauto 2].
          destruct_consistent; eauto.
        }
      * invert_wt_cmd.
        invert_lifted.
        rewrite -> heap_lookup_update_neq in * by solve[eauto 2].
        destruct_consistent.
        destruct v.
        {
          eauto using reach_update_with_num.
        }
        {
          assert (exists x, memory_lookup m2 x = Some (ValLoc l1) /\ e0 = Var x) by eauto.
          super_destruct; subst.
          destruct (decide (l0 = loc1)); subst.
          - eauto.
          - invert_var_typing.
            assert (reach m2 h1 loc1).
            {
              eapply reach_by_update_implies_reach_if; eauto.
            }
            assert (reach m2 h1 l0) by eauto.
            eauto.
        }
    + intro; exfalso; eauto.
    + unfolds.
      intros.
      inverts H.
      * assert (exists ℓ μ, heap_lookup loc h1 = Some (ℓ, μ)) by (invert_dang_free; eauto).
        destruct_exists.
        destruct (decide (loc = l0)); subst.
        {
          eauto.
        }
        {
          rewrite -> heap_lookup_update_neq by solve[eauto].
          eauto.
        }
      * destruct (decide (loc0 = l0)); subst.
        {
          destruct (decide (n0 = n)); subst.
          - _apply heap_lookup_update_eq2 in *; eauto 2.
            destruct_exists.
            super_destruct; subst.
            rewrite -> lookup_update_eq in *.
            rewrite_inj.
            invert_wt_cmd.
            + assert (exists x, memory_lookup m2 x = Some (ValLoc loc) /\ e0 = Var x) by eauto.
              super_destruct; subst.
              invert_var_typing.
              destruct (decide (loc = l0)); subst.
              * eauto.
              * rewrite -> heap_lookup_update_neq by solve[eauto].
                eauto.
          - assert (exists ν, heap_lookup l0 h1 = Some (ℓ, ν) /\ μ = update_lookup ν n v) by eauto.
            super_destruct; subst.
            rewrite -> lookup_update_neq in * by solve[eauto].
            destruct (decide (loc = l0)); subst.
            {
              eauto.
            }
            {
              rewrite -> heap_lookup_update_neq by eauto 2.
              eauto.
            }
        }
        {
          rewrite -> heap_lookup_update_neq in * by solve[eauto].
          assert (reach m2 h1 l0) by eauto.
          destruct (decide (loc = l0)); subst.
          - assert (exists ℓ μ, heap_lookup l0 h1 = Some (ℓ, μ)) by eauto.
            super_destruct; subst.
            eauto.
          - rewrite -> heap_lookup_update_neq by solve[eauto].
            assert (reach m2 h1 loc0).
            {
              destruct v.
              - eauto using reach_update_with_num.
              - invert_wt_cmd;
                  assert (exists x, memory_lookup m2 x = Some (ValLoc l) /\ e0 = Var x)
                    by eauto;
                  super_destruct; subst;
                    eauto 3 using reach_by_update_implies_reach_if.
            }
            eauto.
        }
    + unfolds.
      intros.
      destruct (decide (loc = l0)); subst.
      * rewrite -> length_of_update in *.
        destruct (decide (n0 = n)); subst.
        {
          exists v.
          assert (reach m2 h1 l0) by eauto.
          assert (exists ℓ μ, heap_lookup l0 h1 = Some (ℓ, μ)) by eauto.
          super_destruct; subst.
          rewrite_inj.
          _apply heap_lookup_update_eq2 in *.
          super_destruct; subst.
          eauto.
        }
        {
          _apply heap_lookup_update_eq2 in *.
          super_destruct; subst.
          rewrite -> lookup_update_neq by solve[eauto 2].
          eauto.
        }
      * rewrite -> heap_lookup_update_neq in * by solve[eauto 2].
        rewrite -> length_of_update in *.
        unfold lookup_in_bounds in *.
        assert (reach m2 h1 l0) by eauto.
        destruct v.
        {
          eauto using reach_update_with_num.
        }
        {
          invert_wt_cmd.
          assert (exists x, memory_lookup m2 x = Some (ValLoc l) /\ e0 = Var x)
            by eauto.
          super_destruct; subst.
          invert_var_typing.
          assert (reach m2 h1 l) by eauto.
          assert (reach m2 h1 loc) by eauto 2 using reach_by_update_implies_reach_if.
          eauto.
        }
    + unfolds.
      splits~.
      * intros.
        destruct (decide (loc = l0)); subst.
        {
          assert (exists ν, heap_lookup l0 h1 = Some (l2, ν) /\ μ = update_lookup ν n v)
            by eauto.
          super_destruct; subst.
          eauto 2.
        }
        {
          rewrite -> heap_lookup_update_neq in * by solve[eauto].
          eauto 2.
        }
      * intros.
        assert (exists μ, heap_lookup loc' h1 = Some (ℓ', μ)).
        {
          destruct (decide (loc' = l0)); subst.
          - assert (exists ν0, heap_lookup l0 h1 = Some (ℓ', ν0) /\ ν = update_lookup ν0 n v) by eauto.
            super_destruct; subst.
            eauto.
          - rewrite -> heap_lookup_update_neq in * by solve[eauto].
            eauto.
        }
        assert (reach m2 h1 loc).
        {
          destruct v.
          - eauto using reach_update_with_num.
          - assert (reach m2 h1 l0) by eauto.
            invert_wt_cmd.
            assert (exists x, memory_lookup m2 x = Some (ValLoc l1) /\ e0 = Var x) by eauto.
            super_destruct; subst.
            eapply reach_by_update_implies_reach_if; eauto 2.
        }

        destruct (decide (loc = l0)); subst.
        {
          assert (exists ν, heap_lookup l0 h1 = Some (ℓ, ν) /\ μ = update_lookup ν n v)
            by eauto.
          super_destruct; subst.
          destruct (decide (n = n0)); subst.
          - rewrite -> lookup_update_eq in *.
            rewrite_inj.
            invert_wt_cmd.
            assert (exists x, memory_lookup m2 x = Some (ValLoc loc') /\ e0 = Var x) by eauto.
            super_destruct; subst.
            invert_var_typing.
            invert_lifted.
            assert (exists τ, σ = Array τ ℓ').
            {
              destruct σ.
              - assert (exists n, ValLoc loc' = ValNum n) by eauto.
                super_destruct; discriminate.
              - exists s0.
                eapply f_equal2; eauto 2.
            }
            super_destruct; subst.
            assert (stenv' loc' = Some τ) by eauto.
            rename l3 into ε_arr.
            assert (ℓ0 = ℓ) by eauto 2; subst.
            assert (stenv' l0 = Some (SecType (Array τ ℓ') ε_arr)) by eauto.
            rewrite_inj.
            reflexivity.
          - rewrite -> lookup_update_neq in * by solve[eauto].
            eauto 2.
        }
        {
          rewrite -> heap_lookup_update_neq in * by solve[eauto].
          super_destruct; subst.
          eauto 2.
        }
      * intros.

        assert (exists μ, heap_lookup loc2 h1 = Some (ℓ2, μ)).
        {
          destruct (decide (loc2 = l0)); subst.
          - assert (exists ν0, heap_lookup l0 h1 = Some (ℓ2, ν0) /\ ν = update_lookup ν0 n v) by eauto.
            super_destruct; subst.
            eauto.
          - rewrite -> heap_lookup_update_neq in * by solve[eauto].
            eauto.
        }
        destruct (decide (loc1 = l0)); subst.
        {
          assert (exists ν, heap_lookup l0 h1 = Some (ℓ1, ν) /\ μ = update_lookup ν n v) by eauto.
          super_destruct; subst.
          destruct (decide (n = n0)); subst.
          - rewrite -> lookup_update_eq in *.
            rewrite_inj.
            invert_wt_cmd.
            assert (exists x, memory_lookup m2 x = Some (ValLoc loc2) /\ e0 = Var x) by eauto.
            super_destruct; subst.
            invert_var_typing.
            invert_lifted.
            assert (exists τ, σ = Array τ ℓ2).
            {
              destruct σ.
              - assert (exists n, ValLoc loc2 = ValNum n) by eauto.
                super_destruct; discriminate.
              - exists s.
                eapply f_equal2; eauto 2.
            }
            super_destruct; subst.
            assert (ℓ = ℓ1) by eauto 2; subst.
            assert (stenv' l0 = Some (SecType (Array τ ℓ2) l2)) by eauto.
            assert (wf_type bot (SecType (Array (SecType (Array τ ℓ2) l2) ℓ1) ε_x)) by eauto.
            do 2 invert_wf_type.
            eauto.
          - rewrite -> lookup_update_neq in * by solve[eauto].
            eauto 3.
        }
        {
          rewrite -> heap_lookup_update_neq in * by solve[eauto].
          super_destruct; subst.
          assert (reach m2 h1 loc1).
          {
            destruct v; eauto 3 using reach_update_with_num.
            assert (reach m2 h1 l).
            {
              invert_wt_cmd.
              assert (exists x, memory_lookup m2 x = Some (ValLoc l) /\ e0 = Var x) by eauto.
              super_destruct; subst.
              eauto.
            }
            eapply reach_by_update_implies_reach_if; eauto 3.
          }
          eauto 2.
        }
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  - do 2 specialize_gen.
    apply WellformedAux; eauto.
    + invert_wt_cmd.
      invert_lifted.
      rewrite_inj.
      eapply wf_tenv_extend; eauto.
      * intros; subst.
        eauto.
      * intros; subst.
        eauto.
    + invert_wt_cmd.
      invert_lifted.
      unfold consistent.
      splits.
      * intros.
        destruct (decide (i = x)); subst.
        {
          rewrite -> extend_memory_lookup_eq in *.
          rewrite_inj.
          destruct_consistent.
          eauto.
        }
        {
          rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          eauto.
        }
      * intros.
        assert (reach m1 h2 loc1).
        {
          destruct v.
          - eauto 2 using reach_extend_with_num.
          - assert (reach m1 h2 l0) by eauto.
            assert (reach m1 h2 l0) by eauto 3.
            eapply reach_extend2 with (loc1 := l0).
            + eauto
            + match goal with
                [H: lookup _ _ = Some (ValLoc l1) |- _] =>
                eapply H
              end.
            + eauto.
            + eauto.
            + eauto.
        }
        destruct_consistent.
        eauto.
    + intro; exfalso; eauto.
    + unfolds.
      intros.
      destruct v.
      * eauto using reach_extend_with_num.
      * assert (reach m1 h2 l0) by eauto 3.
        eauto using reach_extend2.
    + unfolds.
      intros.
      destruct v.
      * eauto using reach_extend_with_num.
      * assert (reach m1 h2 l) by eauto 3.
        assert (reach m1 h2 loc) by eauto 2 using reach_extend2.
        eauto.
    + unfolds.
      splits~.
      * intros.
        destruct (decide (i = x)); subst.
        {
          rewrite -> extend_memory_lookup_eq in *.
          rewrite_inj.
          invert_wt_cmd.
          invert_lifted.
          rewrite_inj.
          assert (ℓ0 = ℓ) by eauto 2.
          rewrite_inj.
          subst.
          rewrite_inj.
          assert (reach m1 h2 l0) by eauto.
          assert (stenv' l0 = Some (SecType (Array s l1) ε0)) by eauto.
          destruct ε0 as [l3 ι].
          symmetry.
          eauto 3.
        }
        {
          rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          eauto 2.
        }
      * intros.
        assert (reach m1 h2 loc).
        {
          destruct v; eauto 2 using reach_extend_with_num.
          assert (reach m1 h2 l0) by eauto.
          assert (reach m1 h2 l1).
          {
            eauto 2.
          }
          eauto 3.
        }
        eauto 3.
      * intros.
        assert (reach m1 h2 loc1).
        {
          destruct v; eauto 2 using reach_extend_with_num.
          assert (reach m1 h2 l0) by eauto.
          assert (reach m1 h2 l) by eauto 2.
          eauto 3.
        }
        eauto 3.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  - let H1 := fresh in let H2 := fresh in
    assert (Time i <> Stop) as H1 by congruence;
      assert (Time i <> TimeOut) as H2 by congruence;
      do 2 specialize_gen;
      clear H1; clear H2.
    apply WellformedAux; try eauto 2.
    + invert_wt_cmd.
      rewrite_inj.
      eapply wf_tenv_extend; eauto.
      * intros; subst.
        discriminate.
    + invert_wt_cmd.
      unfolds.
      splits.
      * intros.
        destruct (decide (i = x)); subst.
        {
          rewrite -> extend_memory_lookup_eq in *.
          discriminate.
        }
        {
          rewrite -> extend_memory_lookup_neq in * by solve[eauto].
          eauto.
        }
      * intros.
        destruct_consistent.
        eauto using reach_extend_with_num.
    + intro; exfalso; eauto.
    + unfolds.
      intros.
      assert (reach m1 h2 loc) by eauto 2 using reach_extend_with_num.
      eauto.
    + unfolds.
      intros.
      assert (reach m1 h2 loc) by eauto 2 using reach_extend_with_num.
      eauto.
    + unfolds.
      splits; eauto 3 using reach_extend_with_num.
      intros.
      destruct (decide (i = x)); subst.
      * rewrite -> extend_memory_lookup_eq in *.
        discriminate.
      * rewrite -> extend_memory_lookup_neq in * by solve[eauto].
        eauto 2 using reach_extend_with_num.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.
  - eapply gc_preserves_wf.
    + eauto.
    + eauto.
    + eauto.
    + erewrite -> disjoint_union_proof_irrelevance; eauto.

      Unshelve.
      * repeat constructor; eauto.
      * repeat constructor; eauto.
      * eauto.
      * eauto.
Qed.

End Preservation.


From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat seq eqtype fintype path fingraph.
From extructures Require Import ord fset fmap fperm.
From CoqUtils Require Import word nominal.
Require Import Coq.Strings.String.

Require Import lib.utils lib.fmap_utils common.types.
Require Import memory_safety.property memory_safety.abstract.
Require Import memory_safety.classes memory_safety.executable.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section MemorySafety.

Local Open Scope string_scope.

Local Open Scope fset_scope.

Import Abstract.

Variable mt : machine_types.
Variable ops : machine_ops mt.
Variable sr : syscall_regs mt.
Variable addrs : memory_syscall_addrs mt.

Local Notation state := (state mt).
Local Notation pointer := [eqType of pointer mt].
Local Notation value := (value mt).
Local Notation astepf := (AbstractE.step ops sr addrs).

Implicit Type m : memory mt.
Implicit Type rs : registers mt.
Implicit Type s : state.
Implicit Type b : name.
Implicit Type p : pointer.
Implicit Type bs : {fset name}.
Implicit Type v : value.
Implicit Type pm : {fperm name}.

Definition references m b b' :=
  [exists offs : mword mt * mword mt,
    getv m (b, offs.1) == Some (VPtr (b', offs.2))].

Inductive reachable pc rs m b : Prop :=
| ReachBasePc p of pc = VPtr p & p.1 = b
| ReachBaseReg r p of rs r = Some (VPtr p) & p.1 = b
| ReachHop b' of reachable pc rs m b' & references m b' b.
Hint Constructors reachable.

Definition reachable_blocks pc rs m bs :=
  forall b, b \in bs <-> reachable pc rs m b.

Definition live_blocks s bs :=
  reachable_blocks (pc s) (regs s) (mem s) bs.

Lemma live_blocks_blocks s bs :
  live_blocks s bs -> {subset bs <= blocks s}.
Proof.
move=> live b /live in_bs; apply/in_blocks.
elim: b / in_bs
      => [b ptr ? ?|b r ptr|b b' _ IH /existsP [[/= off off'] /eqP hget]].
- by eapply BlocksPc; eauto.
- by eapply BlocksReg; eauto.
move: hget; rewrite /getv /=.
case mem_b': (mem s b') => [fr|] //=.
have [in_bounds [hnth]|] //= := boolP (off < size fr).
have ?: VPtr (b, off') \in fr.
  by rewrite -hnth; apply mem_nth.
by eapply BlocksMem; eauto.
Qed.

(* FIXME: Right now, this doesn't say anything about memory reads. *)
CoInductive valid_step s bs s' bs' : Prop :=
| ValidNop of mem s = mem s' & {subset bs' <= bs}
| ValidWrite p v of updv (mem s) p v = Some (mem s')
                  & {subset bs' <= bs} & p.1 \in bs
| ValidAlloc b sz of malloc_fun (mem s) (blocks s) sz = (mem s', b)
                   & {subset bs' <= b |: bs}
| ValidFree b of Abstract.free_fun (Abstract.mem s) b = Some (Abstract.mem s')
               & {subset bs' <= bs} & b \in bs.

CoInductive value_ok pc rs m : value -> Prop :=
| VOkData x : value_ok pc rs m (VData x)
| VOkPtr p of reachable pc rs m p.1 : value_ok pc rs m (VPtr p).
Hint Constructors value_ok.

CoInductive valid_pc_upd (pc pc' : value) rs m : Prop :=
| ValidPcUpd of value_ok pc rs m pc'.
Hint Constructors valid_pc_upd.

CoInductive valid_reg_upd pc rs rs' m : Prop :=
| ValidRegSame of rs = rs'
| ValidRegUpd v r of updm rs r v = Some rs' & value_ok pc rs m v.
Hint Constructors valid_reg_upd.

Lemma upd_reachable pc pc' rs rs' m bs bs' :
  reachable_blocks pc rs m bs ->
  reachable_blocks pc' rs' m bs' ->
  valid_pc_upd pc pc' rs m ->
  valid_reg_upd pc rs rs' m ->
  {subset bs' <= bs}.
Proof.
move=> hbs hbs' v_pc v_rs b /hbs' reach_b; apply/hbs.
elim: b / reach_b {hbs hbs'} => [b [b' off] /= hpc' hb'|b r [b' off]/=|b b' _].
- rewrite {}hb' {b'} in hpc'.
  case: v_pc => v_pc.
  by case: pc' / v_pc hpc' => [//|[b' off'] /= ? [<- _]].
- move=> hr hb'; move: hr; rewrite {}hb' {b'}.
  case: v_rs => [-> hr|v r' upd_rs]; first by eapply ReachBaseReg; eauto.
  move: {upd_rs} (updm_set upd_rs)=> upd_rs v_ok.
  rewrite {}upd_rs {rs'} setmE.
  have [_{r}[vE]|_ hr] := altP eqP.
    by case: v / v_ok vE => // - [b' off'] /= ? [<- _].
  by eapply ReachBaseReg; eauto.
by eapply ReachHop.
Qed.

Lemma get_reg_ok pc rs r m v bs :
  rs r = Some v -> value_ok pc rs m v.
Proof.
case: v => [?|[b off get_rs]]; constructor.
by eapply ReachBaseReg; eauto.
Qed.

Lemma get_mem_ok pc rs m p v :
  value_ok pc rs m (VPtr p) ->
  getv m p = Some v ->
  value_ok pc rs m v.
Proof.
move=> p_ok; move: {1 2}(VPtr p) p_ok (erefl (VPtr p))=> v'.
case: v' / => // - [b off] b_reach [<-].
case: v => [?|[b' off' get_p]]; constructor.
eapply ReachHop; eauto; apply/existsP; exists (off,off')=> /=.
by apply/eqP.
Qed.

Lemma lift_binop_ok pc rs m o v1 v2 v3 :
  value_ok pc rs m v1 ->
  value_ok pc rs m v2 ->
  lift_binop o v1 v2 = Some v3 ->
  value_ok pc rs m v3.
Proof.
rewrite /lift_binop.
case: v1 / => [v1|[b1 off1] hb1]; case: v2 / => [v2|[b2 off2] hb2];
case: o=> //;
try match goal with
| |- context[?b1 == ?b2] =>
  have [b1_eq_b2|b1_neq_b2] // := altP (b1 =P b2)
end;
move=> [<-]; constructor; done.
Qed.

Ltac simple_intros :=
  move=> /= *;
  repeat match goal with
  | H : live_blocks ?s ?bs |- _ =>
    match goal with
    | _ : {subset bs <= blocks s} |- _ => fail 1
    | |- _ => idtac
    end;
    let live := fresh "live" in
    let sub := fresh "sub" in
    move: H => live;
    have sub := live_blocks_blocks live;
    simpl in live, sub; simpl
  end;
  apply: ValidNop; first done.

Lemma getv_upd m m' p v :
  updv m p v = Some m' ->
  forall p', getv m' p' = if p' == p then Some v else getv m p'.
Proof.
rewrite /updv/getv/= => get_p p'; move: get_p.
case get_m: (m p.1) => [fr|] //.
have [leq_size_fr [<-]|//] := boolP (p.2 < size fr)%N.
rewrite setmE -pair_eqE /=.
have [eq_p1|neq_p1 //] := altP (p'.1 =P p.1).
rewrite size_cat size_take /= size_drop leq_size_fr.
rewrite addnS -addSn addnC subnK //.
have [eq_p2|neq_p2] := altP (p'.2 =P p.2).
  by rewrite eq_p2 leq_size_fr nth_cat size_take leq_size_fr ltnn subnn.
rewrite eq_p1 get_m.
case: ifP => // leq_size_fr'.
rewrite nth_cat size_take /= leq_size_fr; move: neq_p2; rewrite -!val_eqE /=.
case: (ltngtP p'.2 p.2) => [leq_p2|leq_p2'|eq_p2 //].
  by rewrite nth_take //.
move: (leq_p2'); rewrite -{1}(addn0 p.2) -ltn_subRL => leq_subn.
by rewrite -(@prednK (p'.2 - p.2))//= -subnS nth_drop addnC subnK // subnn.
Qed.

Ltac safe_step_simple_cases :=
  simple_intros;
  first [ solve [ eapply upd_reachable; try eassumption;
                  unfold pc, regs, mem;
                  eauto using get_reg_ok, get_mem_ok, lift_binop_ok;
                  done ]
        | failwith "solve_simple_cases" ].

Lemma safe_step s bs s' bs' :
  step s s' ->
  live_blocks s bs ->
  live_blocks s' bs' ->
  valid_step s bs s' bs'.
Proof.
case: s s' / => /=; try safe_step_simple_cases.
- move=> m m' rs pc ptr i r1 r2 v _ _ get_ptr get_v upd_m /= hbs hbs'.
  eapply ValidWrite; eauto.
    move=> b' /hbs' b'_in_bs'; apply/hbs => {hbs hbs'}.
    elim: b' / b'_in_bs'
          => [b' p [<-] {p} <-|b' r p get_p <-
             |b' b'' _ IH /existsP /= [off /eqP get_b'']] /=.
    + by eapply ReachBasePc; eauto.
    + by eapply ReachBaseReg; eauto.
    move: get_b''; rewrite (getv_upd upd_m).
    have [ptr_eq [v_eq]|ptr_neq get_b''] := altP (_ =P ptr).
      by rewrite v_eq {get_ptr} in get_v; eapply ReachBaseReg; eauto.
    by eapply ReachHop; eauto; apply/existsP; exists off; apply/eqP.
  by apply/hbs; apply/(@ReachBaseReg _ _ _ ptr.1 r1 ptr); simpl; eauto.
- move=> m m' rs rs' sz b pc' _ hm' hrs' get_pc' hbs hbs'.
  have hsub := live_blocks_blocks hbs.
  have hsub' := live_blocks_blocks hbs'.
  eapply ValidAlloc; simpl; eauto=> b' /hbs' b'_in_bs' {hbs'}.
  elim: b' / b'_in_bs'
        => [b' p [<-] {p} <-|b' r p get_p <-
           |b' b'' _ IH /existsP /= [off /eqP get_b']] /=.
  + rewrite in_fsetU1; apply/orP; right; apply/hbs.
    by eapply ReachBaseReg; eauto.
  + move: get_p; rewrite (getm_upd hrs') in_fsetU1.
    have [_{r} [<-]|r_neq get_p] := altP eqP; first by rewrite eqxx.
    by apply/orP; right; apply/hbs; eapply ReachBaseReg; eauto.
  rewrite !in_fsetU1 in IH *; have [//|neq_b' /=] := eqP.
  case/orP: IH => [/eqP eq_b''|/hbs b''_in_bs].
    move: get_b'; rewrite {}eq_b'' {b''}.
    have [in_bounds|off_bounds] := boolP (off.1 < sz)%ord.
      by rewrite (malloc_get hm' in_bounds).
    rewrite -Ord.leqNgt in off_bounds.
    by rewrite (malloc_get_out_of_bounds hm' off_bounds).
  apply/hbs; eapply ReachHop; eauto; apply/existsP; exists off; apply/eqP.
  move: get_b'; rewrite /getv/=.
  have [eq_b''|neq_b''] := b'' =P b.
    rewrite {}eq_b'' {b''} in b''_in_bs *.
    by generalize (malloc_fresh hm'); move/hbs/hsub: b''_in_bs => ->.
  by rewrite (malloc_get_neq hm' neq_b'').
move=> m m' rs ptr pc' harg hm' get_pc' /= hbs hbs'.
eapply ValidFree; simpl; first by eauto.
  move=> b' /hbs' b'_in_bs'; apply/hbs.
  elim: b' / b'_in_bs'
        => [b' p [<-] {p} <-|b' r p get_p <-
           |b' b'' _ IH /existsP /= [off /eqP get_b']] /=.
  - by eapply ReachBaseReg; eauto.
  - by eapply ReachBaseReg; eauto.
  eapply ReachHop; eauto; apply/existsP; exists off; apply/eqP.
  move: get_b'; rewrite /getv/=.
  rewrite (get_free _ hm').
  by have [eq_b''|neq_b''] := altP (b'' =P ptr.1).
by apply/hbs => {get_pc'}; eapply ReachBaseReg; eauto.
Qed.

Lemma rename_valueE pm v :
  rename pm v = match v with
                | VData w => VData w
                | VPtr ptr => VPtr (rename pm ptr.1, ptr.2)
                end.
Proof. by case: v. Qed.

Lemma rename_dataE pm (w : mword mt) :
  rename pm (VData w) = VData w.
Proof. by []. Qed.

Lemma rename_ptrE pm (ptr : pointer) :
  rename pm (VPtr ptr) = VPtr (pm ptr.1, ptr.2).
Proof. by []. Qed.

Lemma rename_stateE pm s :
  rename pm s = State (rename pm (mem s))
                      (rename pm (regs s))
                      (rename pm (pc s)).
Proof. by case: s. Qed.

Lemma renamewE k pm (w : word k) : rename pm w = w.
Proof. by []. Qed.

Local Open Scope fperm_scope.

Lemma rename_getv pm m ptr :
  getv (rename pm m) ptr =
  rename pm (getv m (rename pm^-1 ptr)).
Proof.
rewrite /getv !renamemE fst_eqvar /= !renameoE.
case e: (m (rename _ _)) => [fr|] //=.
rewrite [in RHS]fun_if /= !renamewE size_map.
case: ifP=> // in_bounds.
by rewrite (nth_map (VData 0%w) _ _ in_bounds).
Qed.

Lemma rename_updv pm m m' ptr v :
  updv m ptr v = Some m' ->
  updv (rename pm m) (rename pm ptr) (rename pm v) =
  Some (rename pm m').
Proof.
rewrite /updv -[(rename pm ptr).1]fst_eqvar -[(rename pm m) _]getm_eqvar.
case m_ptr: (m ptr.1)=> [fr|] //=.
rewrite renamewE size_map.
case: ifP=> //= h_off [<-].
by rewrite setm_eqvar [in RHS]renamesE map_cat /= map_take map_drop.
Qed.

Lemma rename_updr pm rs rs' r v :
  updm rs r v = Some rs' ->
  updm (rename pm rs) r (rename pm v) = Some (rename pm rs').
Proof.
rewrite /updm renamemE renamewE.
case rs_r: (rs r) => [v'|] //= [<-{rs'}].
by rewrite setm_eqvar renamewE.
Qed.

Global Instance lift_binop_eqvar f : {eqvar (@lift_binop mt f)}.
Proof.
case: f=> [] pm [w1|[p1 o1]] _ <- [w2|[p2 o2]] _ <- //=;
rewrite ?renamewE ?(can_eq (renameK pm));
try match goal with
| p1 : name, p2 : name |- context [?p1 == ?p2] =>
  case: (altP (p1 =P p2)) => ? //; subst
end;
solve [move=> [<-]; rewrite rename_valueE //=].
Qed.

Lemma rename_lift_binop pm f v1 v2 v3 :
  lift_binop f v1 v2 = Some v3 ->
  lift_binop f (rename pm v1) (rename pm v2) = Some (rename pm v3).
Proof. by move=> h; rewrite -[LHS]lift_binop_eqvar; rewrite h. Qed.

(* Redeclaring instances to make type-class inference work *)
Canonical memory_nominalType := Eval hnf in [nominalType of memory mt].
Canonical frame_nominalType := Eval hnf in [nominalType of frame mt].

Lemma free_fun_eqvar : {eqvar @free_fun mt}.
Proof. by rewrite /free_fun /=; finsupp. Qed.

Lemma rename_free pm m m' b :
  free_fun m b = Some m' ->
  free_fun (rename pm m) (pm b) = Some (rename pm m').
Proof. by move=> h; rewrite -renamenE -[LHS]free_fun_eqvar h. Qed.
Hint Resolve rename_free : rename_step_db.

Ltac rename_getv :=
  match goal with
  | pm : {fperm name},
    get : getv ?m ?ptr = Some ?v |- _ =>
    match m with
    | rename pm ?m' => fail 1
    | _ => idtac
    end;
    match goal with
    | _ : getv (rename pm m) (rename pm ptr) = _ |- _ => fail 1
    | |- _ => idtac
    end;
    let aget := fresh "aget" in
    first [
        have aget: getv (rename pm m) (rename pm ptr) = Some (rename pm v);
        [ by rewrite rename_getv renameK get
        | rewrite ?rename_dataE ?rename_ptrE in aget ]
      | failwith "rename_getv" ]
  end.

Ltac rename_updv :=
  match goal with
  | pm : {fperm name},
    upd : updv ?m ?ptr ?v = Some ?m' |- _ =>
    match m with
    | rename pm ?m'' => fail 1
    | _ => idtac
    end;
    match goal with
    | _ : updv (rename pm m) (rename pm ptr) _ = _ |- _ => fail 1
    | |- _ => idtac
    end;
    let aupdm := fresh "aupdm" in
    first [
        have aupdm := rename_updv pm upd;
        rewrite ?rename_dataE ?rename_ptrE in aupdm
      | failwith "rename_updv" ]
  end.

Ltac rename_getr :=
  match goal with
  | pm : {fperm name},
    get : getm ?rs ?r = Some ?v |- _ =>
    match rs with
    | rename pm ?rs' => fail 1
    | _ => idtac
    end;
    match goal with
    | _ : getm (rename pm rs) r = _ |- _ => fail 1
    | |- _ => idtac
    end;
    let agetr := fresh "agetr" in
    first [
        have agetr: getm (rename pm rs) r = Some (rename pm v);
        [ by rewrite renamemE renameK get
        | rewrite ?rename_dataE ?rename_ptrE in agetr ]
      | failwith "rename_getr" ]
  end.

Ltac rename_updr :=
  match goal with
  | pm : {fperm name},
    upd : updm ?rs ?r ?v = Some ?rs' |- _ =>
    match rs with
    | rename pm ?rs'' => fail 1
    | _ => idtac
    end;
    match goal with
    | _ : updm (rename pm rs) r _ = _ |- _ => fail 1
    | |- _ => idtac
    end;
    let aupdr := fresh "aupdr" in
    first [
        have aupdr := rename_updr pm upd;
        rewrite ?rename_dataE ?rename_ptrE in aupdr
      | failwith "rename_updr" ]
  end.

Ltac rename_lift_binop :=
  match goal with
  | pm : {fperm name},
    bo : lift_binop ?f ?v1 ?v2 = Some ?v3 |- _ =>
    match v1 with
    | rename pm _ => fail 1
    | _ => idtac
    end;
    match goal with
    | _ : lift_binop f (rename pm v1) (rename pm v2) = _ |- _ => fail 1
    | |- _ => idtac
    end;
    let abinop := fresh "abinop" in
    first [
        have abinop := rename_lift_binop pm bo;
        rewrite ?rename_dataE ?rename_ptrE in abinop
      | failwith "rename_lift_binop" ]
  end.

Ltac apply_rename_everywhere :=
  first [ rename_getv | rename_updv | rename_getr | rename_updr
        | rename_lift_binop ].

Ltac solve_rename_step_simpl :=
  solve [ eauto
        | eauto; simpl; eauto with rename_step_db
        | eauto; try rewrite !(can_eq (renameK _)); eauto ].

Ltac rename_step_simple pm :=
  intros; exists pm; rewrite !rename_stateE /=;
  repeat apply_rename_everywhere;
  rewrite ?rename_dataE /=;
  s_econstructor solve_rename_step_simpl.

Lemma rename_step s s' pm :
  step s s' ->
  exists pm', step (rename pm s) (rename pm' s').
Proof.
case: s s' /; try rename_step_simple pm.
- (* Bnz *)
  move=> m rs p *; exists pm; rewrite !rename_stateE /=.
  repeat apply_rename_everywhere.
  rewrite !rename_ptrE /=.
  (* No idea why unification can't solve this... *)
  by eapply (@step_bnz _ _ _ _ _ _ (pm p.1, p.2)); eauto.
- (* Malloc *)
  move=> m m' rs rs' sz b pc' rs_arg.
  set s := State _ _ _; set s' := rename pm s; set bs := blocks s.
  pose b' := fresh (blocks s').
  pose bs' := supp pm :|: blocks s :|: blocks s'.
  pose b'' := fresh bs'.
  pose pm' := fperm2 b' b'' * pm * fperm2 b b''.
  rewrite /malloc_fun=> - [? ?]; subst b m'.
  have pm'_s' : s' = rename pm' s.
    apply/eq_in_rename=> x x_in; rewrite /pm' fpermM /= fpermM /=.
    rewrite (@fperm2D _ _ _ x); first last.
    + apply: contraTN x_in=> /eqP -> {x}; rewrite /b''.
      apply: contra (freshP bs'); rewrite /bs'=> h; rewrite 2!in_fsetU -orbA.
      by apply/or3P/Or32.
    + apply: contraTN x_in=> /eqP -> {x}; exact/freshP.
    rewrite fperm2D //.
      rewrite /b' /s' /blocks names_rename.
      by apply/eqP=> e; move: (freshP (pm @: names s)); rewrite -e mem_imfset.
    rewrite /b''; apply/eqP=> e; move: (freshP bs'); rewrite -e /bs'.
    by rewrite in_fsetU !negb_or /s' /blocks names_rename mem_imfset // andbF.
  have pm'_b': pm' (fresh bs) = b'.
    rewrite /pm' fpermM /= fperm2L fpermM /= (_ : pm b'' = b'') ?fperm2R.
      done.
    apply/suppPn/negP=> b''_in; move: (freshP bs').
    by rewrite /bs' 2!in_fsetU !negb_or b''_in.
  move=> h1 h2.
  exists pm'; rewrite pm'_s'; eapply step_malloc; eauto.
  + by rewrite /s /= renamemE renamewE rs_arg /= renameoE /= rename_valueE.
  + rewrite /s /= /malloc_fun.
    rewrite /b' pm'_s' /s /= in pm'_b'; rewrite -pm'_b' -renamenE.
    rewrite setm_eqvar renamesE (eq_in_map _ id _).1 1?map_id; first by eauto.
    by move=> x /nseqP [-> _].
  + exact: (rename_updr _ h1).
  by rewrite /s /= renamemE renamewE h2.
Qed.

Lemma names_state s :
  names s = names (mem s) :|: names (regs s) :|: names (pc s).
Proof. by []. Qed.

Lemma getv_union m m' p v :
  fdisjoint (names m) (domm m') ->
  getv m p = Some v ->
  getv (unionm m' m) p = Some v.
Proof.
move=> /(fdisjointP _ _)/(_ p.1) hdis; rewrite /getv unionmE.
case e: (m p.1)=> [fr|] //=; case: ifP=> inb // [<-].
have hin: p.1 \in names m.
  by apply/namesmP/(@PMFreeNamesKey _ _ _ _ p.1 fr)=> //; apply/namesnP.
by rewrite -mem_domm (negbTE (hdis hin)) inb.
Qed.
Hint Resolve getv_union : separation.

Lemma getv_union' m m' p :
  fdisjoint (names m) (domm m') ->
  p.1 \notin domm m' ->
  getv (unionm m' m) p = getv m p.
Proof.
by rewrite /getv !unionmE; move=> dis1 /dommPn -> /=.
Qed.

Lemma updv_union m m' m'' p v :
  fdisjoint (names m) (domm m') ->
  updv m p v = Some m'' ->
  updv (unionm m' m) p v = Some (unionm m' m'').
Proof.
move=> /(fdisjointP _ _)/(_ p.1) hdis; rewrite /updv unionmE.
case e: (m p.1)=> [fr|] //=; case: ifP=> inb // [<-].
have hin: p.1 \in names m.
  by apply/namesmP/(@PMFreeNamesKey _ _ _ _ p.1 fr)=> //; apply/namesnP.
rewrite -mem_domm (negbTE (hdis hin)) inb; congr some; apply/eq_fmap=> b.
rewrite !(setmE, unionmE); have [-> {b}|//] := altP (b =P _).
by rewrite -mem_domm (negbTE (hdis hin)).
Qed.
Hint Resolve updv_union : separation.

Lemma updv_union' m m' p v :
  fdisjoint (names m) (domm m') ->
  p.1 \notin domm m' ->
  updv (unionm m' m) p v =
  if updv m p v is Some m'' then Some (unionm m' m'')
  else None.
Proof.
rewrite /updv unionmE => dis p_m' /=.
rewrite (dommPn p_m'); case: getm => [fr|] //=.
case: ifP=> //= _; congr Some; apply/eq_fmap=> b.
rewrite !(setmE, unionmE).
have [-> {b}|//] := altP (b =P p.1).
by rewrite (dommPn p_m').
Qed.

Lemma free_union' m m' rs r p :
  fdisjoint (names m) (domm m') ->
  fdisjoint (names rs) (domm m') ->
  rs r = Some (VPtr p) ->
  free_fun (unionm m' m) p.1 =
  if free_fun m p.1 is Some m'' then Some (unionm m' m'')
  else None.
Proof.
rewrite /free_fun !unionmE => dis1 dis2 get_r.
have m'_p : p.1 \notin domm m'.
  move/fdisjointP: dis2; apply.
  apply/namesmP/@PMFreeNamesVal; try eassumption.
  by rewrite names_valueE in_fset1.
rewrite (dommPn m'_p) /=; case: (m p.1)=> [fr|] //=.
congr Some; apply/eq_fmap=> b.
rewrite !(remmE, unionmE); have [-> {b}|//] := altP (b =P _).
by rewrite (dommPn m'_p) /=.
Qed.

Lemma free_union m m' m'' b :
  fdisjoint (names m) (domm m') ->
  free_fun m b = Some m'' ->
  free_fun (unionm m' m) b = Some (unionm m' m'').
Proof.
move=> /(fdisjointP _ _)/(_ b) hdis; rewrite /free_fun unionmE.
case e: (m b)=> [fr|] //= [<-].
have hin: b \in names m.
  by apply/namesmP/(@PMFreeNamesKey _ _ _ _ b fr)=> //; apply/namesnP.
rewrite -mem_domm (negbTE (hdis hin)); congr some; apply/eq_fmap=> b'.
rewrite !(remmE, unionmE); have [-> {b'}|//] := altP (b' =P _).
by rewrite -mem_domm (negbTE (hdis hin)).
Qed.
Hint Resolve free_union : separation.

Definition add_mem m s :=
  State (unionm m (mem s)) (regs s) (pc s).

Lemma get_reg_disjoint rs r v bs :
  fdisjoint (names rs) bs ->
  rs r = Some v ->
  fdisjoint (names v) bs.
Proof.
move=> dis_rs get_rs; apply: fdisjoint_trans; try eassumption.
apply/fsubsetP=> /= n n_in; apply/namesmP.
by apply: PMFreeNamesVal; eauto.
Qed.

Lemma get_mem_disjoint m x v bs :
  fdisjoint (names m) bs ->
  getv m x = Some v ->
  fdisjoint (names v) bs.
Proof.
rewrite /getv; case e: getm=> [fr|] //=.
case: ifP=> // x_fr dis [<-].
have {dis} dis : fdisjoint (names fr) bs.
  apply: fdisjoint_trans; try eassumption.
  apply/fsubsetP=> /= n n_in; apply/namesmP.
  by apply: PMFreeNamesVal; eauto.
apply: fdisjoint_trans; try eassumption.
by eapply nom_finsuppP; finsupp.
Qed.

Lemma lift_binop_disjoint f v1 v2 v3 bs :
  lift_binop f v1 v2 = Some v3 ->
  fdisjoint (names v1) bs ->
  fdisjoint (names v2) bs ->
  fdisjoint (names v3) bs.
Proof.
move=> op dis1 dis2.
suffices h: fsubset (names (Some v3)) (names v1 :|: names v2).
  by apply: (fdisjoint_trans h); rewrite fdisjointUl dis1.
by rewrite -op; eapply nom_finsuppP; finsupp.
Qed.

(* FIXME: These declarations shouldn't be needed *)
Canonical registers_nominalType := Eval hnf in [nominalType of registers mt].
Canonical reg_nominalType := Eval hnf in [nominalType of reg mt].

Lemma upd_reg_disjoint rs rs' r bs v :
  updm rs r v = Some rs' ->
  fdisjoint (names rs) bs ->
  fdisjoint (names v) bs ->
  fdisjoint (names rs') bs.
Proof.
move=> h; rewrite (updm_set h) {h rs'} => dis_rs dis_v.
suffices: fdisjoint (names rs :|: names r :|: names v) bs.
  apply: fdisjoint_trans; eapply nom_finsuppP.
  (* FIXME: finsupp used to work here, but it does not anymore... *)
  move=> s sP.
  simple eapply nomR_app.
  simple eapply nomR_app.
  simple eapply nomR_app.
  (* Weird: the typeclasses debugger claims that it is using [simple apply
     setm_eqvar] to solve this goal.  However, adding [simple] below causes the
     goal to fail.  *)
  apply setm_eqvar.
  (* finsupp. (* Does not work... *) *)
  eapply nomR_nominalJ.
  finsupp. (* Now it does work *)
  finsupp.
  by finsupp.
by rewrite 2!fdisjointUl dis_rs dis_v namesT fdisjoint0s.
Qed.

Lemma upd_mem_disjoint m m' x bs v :
  updv m x v = Some m' ->
  fdisjoint (names m) bs ->
  fdisjoint (names v) bs ->
  fdisjoint (names m') bs.
Proof.
rewrite /updv; case e: getm => [fr|] //=.
case: ifP=> // x_fr [<-] dis_m dis_v.
have dis_x : fdisjoint (names x.1) bs.
  apply: fdisjoint_trans; try exact: dis_m.
  apply/fsubsetP=> n n_x.
  apply/namesmP.
  by apply:PMFreeNamesKey; eauto.
have dis_fr : fdisjoint (names fr) bs.
  apply: fdisjoint_trans; try exact: dis_m.
  apply/fsubsetP=> /= n n_in; apply/namesmP.
  by apply: PMFreeNamesVal; eauto.
suffices: fdisjoint (names m :|: names v :|: names x :|: names fr) bs.
  apply: fdisjoint_trans.
  eapply nom_finsuppP.
  (* FIXME: finsupp cannot solve this by itself *)
  move=> ??; eapply setm_eqvar.
  eapply nomR_nominalJ. finsupp. finsupp. finsupp.
rewrite fdisjointUl dis_fr fdisjointUl namespE namesT fsetU0 dis_x.
by rewrite fdisjointUl dis_v dis_m.
Qed.

Lemma free_fun_disjoint m b m' bs :
  fdisjoint (names m) bs ->
  fdisjoint (names b) bs ->
  free_fun m b = Some m' ->
  fdisjoint (names m') bs.
Proof.
move=> dis_m dis_b e; rewrite -[names m']/(names (Some m')) -e.
have ?: fsubset (names (free_fun m b)) (names m :|: names b).
  (* FIXME: finsupp used to solve this until 8.7, but it can't now... *)
  eapply nom_finsuppP=> ??; eapply free_fun_eqvar; finsupp.
apply: fdisjoint_trans; first by eauto.
by rewrite fdisjointUl /= dis_m.
Qed.

Ltac solve_frame_ok_disjoint :=
  match goal with
  | UPD : updm ?rs ?r ?v = Some ?rs',
    DIS : is_true (fdisjoint (names ?rs) ?bs) |-
    is_true (fdisjoint (names ?rs') ?bs) =>
    apply: (upd_reg_disjoint UPD DIS)
  | DIS : is_true (fdisjoint (names ?rs) ?bs),
    GET : getm ?rs ?r = Some ?v |-
    is_true (fdisjoint (names ?v) ?bs) =>
    apply: (get_reg_disjoint DIS GET)
  | _ : lift_binop _ _ _ = Some ?v |-
    is_true (fdisjoint (names ?v) _) =>
    apply: lift_binop_disjoint; eauto
  | _ : getv _ _ = Some ?v |-
    is_true (fdisjoint (names ?v) _) =>
    apply: get_mem_disjoint; eauto
  | _ : updv _ _ _ = Some ?m' |-
    is_true (fdisjoint (names ?m') _) =>
    apply: upd_mem_disjoint; eauto
  | _ : free_fun _ _ = Some ?m |-
    is_true (fdisjoint (names ?m) _) =>
    apply: free_fun_disjoint; try eassumption
  | |- is_true (fdisjoint _ _) => exact: fdisjoint0s
  | _ => done
  end.

Ltac solve_frame_ok_simpl :=
  intros;
  match goal with
  | H : is_true [&& fdisjoint _ _, fdisjoint _ _ & fdisjoint _ _] |- _ =>
    let dism := fresh "dism" in
    let disrs := fresh "disrs" in
    let disp := fresh "disp" in
    case/and3P: H => [dism disrs disp];
    exists fperm_one; rewrite rename1; split;
    [rewrite /add_mem /=; s_econstructor solve [eauto with separation]|
     rewrite 2!fdisjointUl /= -andbA; apply/and3P;
     split; repeat solve_frame_ok_disjoint]
  end.

Lemma frame_ok m s s' :
  fdisjoint (names s) (domm m) ->
  step s s' ->
  exists pm,
    step (add_mem m s) (add_mem m (rename pm s')) /\
    fdisjoint (names (rename pm s')) (domm m).
Proof.
rewrite names_state 2!fdisjointUl -andbA.
move=> dis hstep; case: s s' / hstep dis=> /=; try solve_frame_ok_simpl.
(* Malloc *)
move=> m' m'' rs rs' sz b [bpc opc].
rewrite /blocks /add_mem /=; set s := State _ _ _; set s' := State _ _ _.
set old := names s; set new := names s'.
rewrite /malloc_fun=> get_sz [eb em''] upd get_ra; subst b m''.
case/and3P=> [dism disr disp]; exists (fperm2 (fresh old) (fresh new)).
rewrite rename_valueE /= renamenE fperm2D; first last.
- apply/eqP=> e; move: (freshP new); rewrite -e; move/negP; apply.
  by rewrite /new; apply/in_blocks; econstructor; eauto.
- apply/eqP=> e; move: (freshP old); rewrite -e; move/negP; apply.
  by rewrite /new; apply/in_blocks; econstructor; eauto.
rewrite setm_eqvar renamenE fperm2L renamesE.
rewrite (@eq_in_map _ _ _ id _).1; last by move=> x /nseqP [-> ?] //.
rewrite map_id namesNNE; first last.
- apply: contra (freshP new); move: (fresh _)=> b.
  rewrite /new /s' names_state /= => hin.
  rewrite 2!in_fsetU -orbA; apply/orP; left; apply/namesmP.
  move: (fdisjointP _ _ dism _ hin)=> nin.
  case/namesmP: hin=> [b' fr hb' /namesnP e|b' fr hb' hb].
    subst b'; apply/(@PMFreeNamesKey _ _ _ _ b fr); try by apply/namesnP.
    by rewrite unionmE -mem_domm (negbTE nin).
  have b'_in: b' \in names m'.
    by apply/namesmP/(@PMFreeNamesKey _ _ _ _ b' fr)=> //; apply/namesnP.
  apply/(@PMFreeNamesVal _ _ _ _ b' fr)=> //.
  move: (fdisjointP _ _ dism b' b'_in)=> nin'.
  by rewrite unionmE -mem_domm (negbTE nin').
- apply: contra (freshP old); move: (fresh _)=> bs.
  by rewrite /old /s names_state /= => hin; rewrite 2!in_fsetU hin.
have := (rename_updr (fperm2 (fresh old) (fresh new)) upd).
rewrite rename_valueE /= renamenE fperm2L namesNNE; first last.
- apply: contra (freshP new); move: (fresh _)=> bs.
  by rewrite /new /s' names_state /= => hin; rewrite 2!in_fsetU hin orbT.
- apply: contra (freshP old); move: (fresh _)=> bs.
  by rewrite /old /s names_state /= => hin; rewrite 2!in_fsetU hin orbT.
move=> upd'; split.
  eapply step_malloc; eauto; rewrite /malloc_fun; congr pair.
  apply/eq_fmap=> x; rewrite !(setmE, unionmE) -[blocks _]/new.
  have [->{x}|hneq //] := altP (x =P _).
  rewrite -mem_domm; suff -> : fresh new \in domm m = false by [].
  apply: contraNF (freshP new); move: (fresh _)=> b /dommP [fr Hfr].
  rewrite /new /s' names_state /= 2!in_fsetU -orbA; apply/orP; left.
  apply/namesmP/(@PMFreeNamesKey _ _ _ _ b fr); first by rewrite unionmE Hfr.
  by apply/namesnP.
rewrite rename_stateE /= (updm_set upd) !setm_eqvar renamenE fperm2L.
rewrite renameT renamesE map_nseq /= 2!rename_valueE /= renamenE fperm2L.
set pm := fperm2 _ _.
have sub_m'_m: fsubset (domm m') (names m').
  by apply: fsubsetU; apply/orP; left; rewrite namesfsnE fsubsetxx.
have dis_pm : fdisjoint (names s) (supp pm).
  rewrite names_state fdisjointC /pm /old /s /s' /=.
  apply: fdisjoint_trans.
  apply: fsubset_supp_fperm2.
  rewrite !fdisjointUl fdisjointC fdisjoints1; apply/andP; split.
    exact: freshP.
  rewrite fdisjointC fdisjoints1 fdisjoint0s andbT.
  apply: contra (freshP new); move: (fresh new); apply/fsubsetP.
  rewrite /new /s' names_state /= 2!fsetU0; apply: fsetSU.
  rewrite namesm_union_disjoint; first exact: fsubsetUr.
  rewrite fdisjointC; apply: fdisjoint_trans; eauto.
have dis_new : fdisjoint (names (fresh new)) (domm m).
  rewrite namesnE fdisjointC fdisjoints1.
  apply: contra (freshP new); move: (fresh new); apply/fsubsetP.
  rewrite /new /s' names_state /= fsetU0 namesm_union_disjoint.
    apply: fsubsetU; apply/orP; left.
    apply: fsubsetU; apply/orP; left.
    by apply: fsubsetU; apply/orP; left; rewrite namesfsnE fsubsetxx.
  rewrite fdisjointC; apply: fdisjoint_trans; eauto.
have -> : rename pm m' = m'.
  apply: renameJ.
  rewrite fdisjointC.
  apply: fdisjoint_trans; try eassumption.
  by rewrite /s names_state /= fsetU0 fsubsetUl.
have dis_rs: fdisjoint (names rs) (supp pm).
  apply: fdisjoint_trans; try eassumption.
  by rewrite /s names_state /= fsetU0 fsubsetUr.
have -> : rename pm rs = rs.
  apply: renameJ.
  by rewrite fdisjointC.
have -> : rename pm (VPtr (bpc, opc)) = VPtr (bpc, opc).
  apply: renameJ.
  rewrite fdisjointC.
  by solve_frame_ok_disjoint.
rewrite names_state /= 2!fdisjointUl -andbA; apply/and3P; split.
(* FIXME: The generalizations below should not be needed to prove the set inclusions *)
- have ?: fsubset (names (setm m' (fresh new) (nseq sz (VData 0%w))))
                  (names m' :|: names (fresh new) :|: names (@VData mt 0%w)).
    move: (fresh _) (VData _)=> ??.
    eapply nom_finsuppP=> ??; eapply setm_eqvar; finsupp.
  apply: fdisjoint_trans; first by eauto.
  by rewrite 2!fdisjointUl dism dis_new /= fdisjoint0s.
- have ?: fsubset (names (setm rs syscall_ret (@VPtr mt (fresh new, 0%w))))
                  (names rs :|: names syscall_ret :|: names (@VPtr mt (fresh new, 0%w))).
    move: syscall_ret (VPtr _) => ??.
    eapply nom_finsuppP=> ??; eapply setm_eqvar; finsupp.
  apply: fdisjoint_trans; first by eauto.
  by rewrite 2!fdisjointUl disr fdisjoint0s /= fdisjointUl fdisjoint0s dis_new.
by solve_frame_ok_disjoint.
(* Free *)
apply: (@fdisjoint_trans _ _ (names (VPtr ptr))).
  exact: fsubsetUl.
solve_frame_ok_disjoint.
(* Last *)
exact: (get_reg_disjoint disrs PTR).
Qed.

Lemma not_domm_rs rs r p m' :
  fdisjoint (names rs) (domm m') ->
  rs r = Some (VPtr p) ->
  p.1 \notin domm m'.
Proof.
move/fdisjointP=> dis get_r; apply: dis.
apply/namesmP/@PMFreeNamesVal; try eassumption.
by rewrite names_valueE in_fset1.
Qed.

Lemma not_domm_pc p m' :
  fdisjoint (names (VPtr p)) (domm m') ->
  p.1 \notin domm m'.
Proof. by rewrite names_valueE fdisjointC fdisjoints1. Qed.

Ltac solve_frame_error_step :=
  match goal with
  | e : (if ?pc == ?rhs then _ else _) = _ |- _ =>
    move: e; have [->|?] := altP (pc =P rhs); move=> e //=
  | |- context[addr _ == addr _] =>
    rewrite (inj_eq (@uniq_addr _ addrs)) //=
  | e : match ?x with _ => _ end = None |- _ => destruct x
  | e : obind _ ?x = _ |- obind _ ?y = _ =>
    match y with
    | context[x] => destruct x eqn:?; simpl in * => //
    end
  | e : context[if isSome (getm ?rs ?r) then _ else _] |- _ =>
    let E := fresh "E" in
    case E: (getm rs r) e => [?|] //= e
  | e : ?x = _ |- context[?x] => rewrite e //=
  | |- context[free_fun (unionm _ _) _] =>
    erewrite free_union'; try eassumption; simpl in *
  | |- context[getv (unionm _ _) _] =>
    erewrite getv_union'; try eassumption; simpl in *
  | |- context[updv (unionm _ _) _ _] =>
    erewrite updv_union'; try eassumption; simpl in *
  | dis : is_true (fdisjoint (names ?rs) (domm ?m')),
    get_r : getm ?rs _ = Some (VPtr ?p) |-
    is_true (?p.1 \notin domm ?m') =>
    apply: not_domm_rs dis get_r
  | dis : is_true (fdisjoint (names (VPtr ?p)) (domm ?m')) |-
    is_true (?p.1 \notin domm ?m') =>
    exact: not_domm_pc dis
  | |- _ => single_match_inv; subst=> //
  end.

Ltac solve_frame_error :=
  unfold updm in *; repeat solve_frame_error_step.

Lemma frame_error m s :
  fdisjoint (names s) (domm m) ->
  astepf s = None ->
  astepf (add_mem m s) = None.
Proof.
case: s m => m rs pc m'.
rewrite names_state /= 2!fdisjointUl -andbA /AbstractE.step /add_mem.
by case/and3P=> dis_m dis_rs dis_pc *; solve_frame_error.
Qed.

Lemma noninterference s pm m1 m2 n :
  fdisjoint (names s) (domm m1) ->
  fdisjoint (names (rename pm s)) (domm m2) ->
  match stepn astepf n (add_mem m1 s),
        stepn astepf n (add_mem m2 (rename pm s)) with
  | Some s1, Some s2 =>
    exists pm' s',
      [/\ s1 = add_mem m1 s',
          fdisjoint (names s') (domm m1),
          s2 = add_mem m2 (rename pm' s') &
          fdisjoint (names (rename pm' s')) (domm m2)]
  | None, None => True
  | _, _ => False
  end.
Proof.
elim: n pm s => [|n IH] pm s.
  by move=> ?? /=; exists pm, s; split.
move=> dis1 dis2; rewrite (lock astepf) /= -lock.
case step0: (astepf s)=> [s'|].
  move/AbstractE.stepP in step0.
  have [pm1 [/AbstractE.stepP step1 dis1']] := frame_ok dis1 step0.
  have [pm' step2] := rename_step pm step0.
  have [pm2 [/AbstractE.stepP step2' dis2']] := frame_ok dis2 step2.
  rewrite step1 step2'.
  move/(_ (pm2 * pm' * pm1^-1) _ dis1'): IH.
  rewrite renameA fperm_mulsKV -renameA.
  by move/(_ dis2').
rewrite frame_error //.
case step0': (astepf (rename pm s))=> [s'|].
  move/AbstractE.stepP in step0'.
  have [pm' {step0'} /AbstractE.stepP] := rename_step pm^-1 step0'.
  by rewrite renameK step0.
by rewrite frame_error.
Qed.

End MemorySafety.


(* Assume insertion Delay: inserting Assume instruction *)
(* This versions tries to insert an Assume after a Condition Instruction *)
(* This showcases the possible separation of Framestate and Assume *)
(* This is a pass of the dynamic optimizer *)

Require Export List.
Require Export Coqlib.
Require Export Maps.
Require Export specIR.
Require Export assume_insertion.

(* Checks that a label is not in a list *)
Fixpoint not_in_list (l:list label) (lbl:label): bool :=
  match l with
  | nil => true
  | lbl'::l' =>
    match (Pos.eqb lbl' lbl) with
    | true => false
    | false => not_in_list l' lbl
    end
  end.

(* Check that an instruction has for only predecessor some label *)
Definition only_pred (c:code) (next:label) (pred:label): bool :=
  PTree.fold
    (fun b lbl i =>
       andb b
            (match (Pos.eqb lbl pred) with
             | true => true (* at the predecessor, we can point to next *)
             | false => not_in_list (instr_succ i) next (* elsewehere, next should not be a successor *)
             end))
    c true.

(* Verify that the assume can be inserted after a Cond Instruction *)
Definition validator (v:version) (fs_lbl: label) (guard:list expr) (params:list reg): res unit :=
  match ((ver_code v)#fs_lbl) with
  | Some (Framestate _ _ _ next) =>
    match ((ver_code v)#next) with
    | Some (Cond _ iftrue _) =>
      match (only_pred (ver_code v) next fs_lbl) with
      | true =>
        match (Pos.eqb next (ver_entry v)) with
        | false =>
          do abs <- try_op (defined_regs_analysis (ver_code v) params (ver_entry v)) "Def_regs analysis failed";
            do def_regs <- OK(def_absstate_get next abs);
            match def_regs with
            | DefFlatRegset.Inj def =>
              match (check_guard guard def) with
              | true => OK tt
              | false => Error "The guard might evaluate to an error"
              end
            | _ => Error "The analysis couldn't get the exact set of defined registers"
            end
        | true => Error "The Condition is the entry of the version"
        end
      | false => Error "The Framestate instruction does not dominate the Condition"
      end
    | _ => Error "No Condition instruction after the Framestate"
    end
  | _ => Error "Not pointing to a valid Framestate"
  end.

(* Returns the version where the Assume has been inserted *)
Definition insert_assume_version (v:version) (fid:fun_id) (guard:list expr) (fsl:label) (params:list reg): res version :=
  do code <- OK(ver_code v);
    do _ <- validator v fsl guard params; (* validating that the assume can be inserted *)
    match code # fsl with
    | Some (Framestate tgt vm sl next) =>
      match code # next with
      | Some (Cond condexpr iftrue iffalse) =>
        do freshlbl <- OK (fresh_label (Pos.succ next) code);
        do instr <- try_op (code # iftrue) "Next Label is not used in the function";
          do update_cond <- OK (code # next <- (Cond condexpr freshlbl iffalse));
          do new_code <- OK (update_cond # freshlbl <- (Assume guard tgt vm sl iftrue));
          (* in the new assume, the deopt target, the varmap and the synth list are copied from the framestate *)
          OK (mk_version new_code (ver_entry v))
      | _ => Error "The instruction after the Framestate is not a Cond Instruction"
      end
    | _ => Error "Not pointing to a valid Framestate"
    end.

(* The optimization pass *)
Definition insert_assume_delay (fid: fun_id) (guard:list expr) (fs_lbl: label) (p:program): res program :=
  do f <- try_op (find_function fid p) "Function to optimize not found";
    do v <- OK(current_version f); (* the optimized code if it exists, the base version otherwise *)
    do newv <- insert_assume_version v fid guard fs_lbl (fn_params f);
    do new_program <- OK (set_version p fid newv);
    OK (new_program).

Definition safe_insert_assume_delay (p:program) (fid:fun_id) (guard:list expr) (fs_lbl: label): program :=
  safe_res (insert_assume_delay fid guard fs_lbl) p.


Require Import Bedrock PreAutoSep.

Import DefineStructured.

Section Wrap.
  Variable imports : LabelMap.t assert.
  Hypothesis imports_global : importsGlobal imports.
  Variable modName : string.

  Variable body : cmd imports modName.
  Variable postcondition : assert -> assert.
  Variable verifCond : assert -> list Prop.

  Hypothesis postcondition_ok : forall pre specs x,
    vcs (verifCond pre)
    -> interp specs ((body pre).(Postcondition) x)
    -> interp specs (postcondition pre x).

  Hypothesis verifCond_ok : forall pre,
    vcs (verifCond pre)
    -> vcs (body pre).(VerifCond).

  Hint Extern 1 (_ < _)%N => nomega.
  Hint Extern 1 (not (@eq LabelMap.key _ _)) => lomega.
  Hint Extern 1 (@eq LabelMap.key _ _ -> False) => lomega.
  Hint Extern 1 (LabelMap.MapsTo _ _ _) => apply imps_exit.

  Transparent evalInstrs.

  Definition Wrap : cmd imports modName.
    red; refine (fun pre =>
      let cout := body pre in
      {|
        Postcondition := postcondition pre;
        VerifCond := verifCond pre;
        Generate := fun Base Exit =>
        let cg := cout.(Generate) (Nsucc Base) Base in
          {|
            Entry := Nsucc cg.(Entry);
            Blocks := (cout.(Postcondition),
              (nil, Uncond (RvLabel (modName, Local Exit))))
            :: cg.(Blocks)
          |}
      |}); abstract (struct;
        match goal with
          | [ H : forall k' : LabelMap.key, _
              |- context[Labels _ ?k]  ] =>
            edestruct (H k) as [ ? [ ] ]; eauto;
              match goal with
                | [ H : _ = _ |- _ ] => solve [ rewrite H; eauto 6 ]
              end
          | [ |- context[LabelMap.add (_, Local ?Base) _ _] ] =>
            assert (Base < N.succ Base)%N by nomega;
              match goal with
                | [ H : vcs _ |- _ ] => apply verifCond_ok in H
              end; intuition struct
        end).
  Defined.

End Wrap.

(** * A simpler combinator, for [chunk]-level programs with explicit invariants ahoy *)

Section WrapC.
  Variable body : chunk.

  Definition assertC := bool
    -> (W -> W)
    -> list string
    -> nat
    -> assert.

  Variables precondition postcondition : assertC.
  Variable verifCond : LabelMap.t assert -> list string -> nat -> list Prop.

  Hypothesis postcondition_covered : forall im mn H ns res pre specs st,
    (forall specs st, interp specs (pre st)
      -> interp specs (precondition true (fun x => x) ns res st))
    -> vcs (verifCond im ns res)
    -> interp specs ((toCmd body (im := im) mn H ns res pre).(Postcondition) st)
    -> interp specs (postcondition true (fun x => x) ns res st).

  Hypothesis verifCond_covered : forall im mn H ns res pre,
    (forall specs st, interp specs (pre st) -> interp specs (precondition true (fun x => x) ns res st))
    -> vcs (verifCond im ns res)
    -> vcs ((toCmd body (im := im) mn H ns res pre).(VerifCond)).

  Definition WrapC : chunk.
    red; refine (fun ns res => Structured nil
      (fun im mn H => Wrap im H mn (toCmd body mn H ns res)
        (fun _ => postcondition true (fun x => x) ns res)
        (fun pre => (forall specs st, interp specs (pre st) -> interp specs (precondition true (fun x => x) ns res st)) :: verifCond im ns res)
        _ _)); abstract struct.
  Defined.
End WrapC.

(** * Some tactics useful in clients of [Wrap] *)

Require Import Locals.

Lemma four_plus_variablePosition : forall x ns',
  ~In "rp" ns'
  -> In x ns'
  -> 4 + variablePosition ns' x = variablePosition ("rp" :: ns') x.
  unfold variablePosition at 2; intros.
  destruct (string_dec "rp" x); auto; subst; tauto.
Qed.

Ltac prep_locals :=
  unfold variableSlot in *; repeat rewrite four_plus_variablePosition in * by assumption;
    repeat match goal with
             | [ H : In ?X ?ls |- _ ] =>
               match ls with
                 | "rp" :: _ => fail 1
                 | _ =>
                   match goal with
                     | [ _ : In X ("rp" :: ls) |- _ ] => fail 1
                     | _ => assert (In X ("rp" :: ls)) by (simpl; tauto)
                   end
               end
           end.

Ltac clear_fancy := repeat match goal with
                             | [ H : importsGlobal _ |- _ ] => clear H
                             | [ H : vcs _ |- _ ] => clear H
                           end.

Ltac wrap0 :=
  intros;
    repeat match goal with
             | [ H : vcs nil |- _ ] => clear H
             | [ H : vcs (_ :: _) |- _ ] => inversion H; clear H; intros; subst
             | [ H : vcs (_ ++ _) |- _ ] => specialize (vcs_app_bwd1 _ _ H);
               specialize (vcs_app_bwd2 _ _ H); clear H; intros
           end; simpl;
    repeat match goal with
             | [ |- vcs nil ] => constructor
             | [ |- vcs (_ :: _) ] => constructor
             | [ |- vcs (_ ++ _) ] => apply vcs_app_fwd
           end; propxFo;
    try match goal with
          | [ H : forall stn : settings, _, H' : interp _ _ |- _ ] =>
            specialize (H _ _ _ H')
        end.

Ltac wrap1 := prep_locals; auto; clear_fancy.

Ltac app := match goal with
              | [ H : _, H' : ?P |- _ ] => apply H in H';
                try match goal with
                      | [ H' : P |- _ ] => clear H'
                    end
            end.

Ltac handle_IH :=
  try match goal with
        | [ H : importsGlobal _ |- _ ] =>
          match goal with
            | [ IH : context[H] |- _ ] => clear H IH
            | _ => clear H
          end
      end.

Ltac simp := post; unfold lvalIn, regInL, immInR in *; clear_fancy; prep_locals.

Ltac finish := descend; repeat (step auto_ext; descend); descend; step auto_ext.

(** * Useful facts about instruction sequences not changing parts of machine state *)

Fixpoint scratchOnly (is : list instr) : Prop :=
  match is with
    | nil => True
    | Assign (LvReg r) _ :: is' => r <> Sp /\ scratchOnly is'
    | Binop (LvReg r) _ _ _ :: is' => r <> Sp /\ scratchOnly is'
    | _ => False
  end.

Ltac matcher := repeat match goal with
                         | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
                           match E with
                             | context[match _ with None => _ | _ => _ end] => fail 1
                             | _ => destruct E; try discriminate
                           end
                         | [ |- context[match ?E with None => _ | _ => _ end] ] =>
                           match E with
                             | context[match _ with None => _ | _ => _ end] => fail 1
                             | _ => destruct E; try discriminate
                           end
                       end.

Transparent evalInstrs.

Theorem scratchOnlySp : forall stn st' is st,
  scratchOnly is
  -> evalInstrs stn st is = Some st'
  -> Regs st' Sp = Regs st Sp.
  induction is as [ | [ [ ] | [ ] ] ]; simpl; intuition; matcher; try congruence;
    erewrite IHis by eassumption; apply rupd_ne; auto.
Qed.

Theorem scratchOnlyMem : forall stn st' is st,
  scratchOnly is
  -> evalInstrs stn st is = Some st'
  -> Mem st' = Mem st.
  induction is as [ | [ [ ] | [ ] ] ]; simpl; intuition; matcher; try congruence;
    erewrite IHis by eassumption; reflexivity.
Qed.

Theorem sepFormula_Mem : forall specs stn st st' P,
  interp specs (![P] (stn, st))
  -> Mem st' = Mem st
  -> interp specs (![P] (stn, st')).
  rewrite sepFormula_eq; unfold sepFormula_def; simpl; intros; congruence.
Qed.

Fixpoint spless (is : list instr) : Prop :=
  match is with
    | nil => True
    | Assign (LvReg r) _ :: is' => r <> Sp /\ spless is'
    | Binop (LvReg r) _ _ _ :: is' => r <> Sp /\ spless is'
    | _ :: is' => spless is'
  end.

Theorem splessSp : forall stn st' is st,
  spless is
  -> evalInstrs stn st is = Some st'
  -> Regs st' Sp = Regs st Sp.
  induction is as [ | [ [ ] | [ ] ] ]; simpl; intuition; matcher; try congruence;
    erewrite IHis by eassumption; simpl; try rewrite rupd_ne by auto; auto.
Qed.

Theorem spless_app : forall is1 is2,
  spless is1
  -> spless is2
  -> spless (is1 ++ is2).
  induction is1 as [ | [ ] ]; simpl; intuition;
    destruct l; intuition.
Qed.

Lemma evalInstrs_app_fwd_None : forall stn is2 is1 st,
  evalInstrs stn st (is1 ++ is2) = None
  -> evalInstrs stn st is1 = None
  \/ (exists st', evalInstrs stn st is1 = Some st' /\ evalInstrs stn st' is2 = None).
  induction is1; simpl; intuition eauto.
  destruct (evalInstr stn st a); eauto.
Qed.

Lemma evalInstrs_app_fwd : forall stn is2 st' is1 st,
  evalInstrs stn st (is1 ++ is2) = Some st'
  -> exists st'', evalInstrs stn st is1 = Some st''
    /\ evalInstrs stn st'' is2 = Some st'.
  induction is1; simpl; intuition eauto.
  destruct (evalInstr stn st a); eauto; discriminate.
Qed.

Lemma evalInstr_evalInstrs : forall stn st i,
  evalInstr stn st i = evalInstrs stn st (i :: nil).
  simpl; intros; destruct (evalInstr stn st i); auto.
Qed.

Lemma evalAssign_rhs : forall stn st lv rv rv',
  evalRvalue stn st rv = evalRvalue stn st rv'
  -> evalInstr stn st (Assign lv rv) = evalInstr stn st (Assign lv rv').
  simpl; intros.
  rewrite H; reflexivity.
Qed.