(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export Quorum.
Require Export CorrectTrace.
Require Export Process.

Section LearnAndKnow.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pm  : @Msg }.
  Context { qc  : @Quorum_context pn}.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : @ContainedAuthData pd pat pm }.

  Local Open Scope eo.
  Local Open Scope proc.

  Class LearnAndKnow (n : nat) :=
    MkLearnAndKnow {
        (* known raw data *)
        lak_data : Type;

        (* some distinguished information embedded in the data *)
        lak_info : Type;

        (* to compute the info from the data *)
        lak_data2info : lak_data -> lak_info;

        (* where we store data *)
        lak_memory : Type;

        (* explains what it means to know the data *)
        lak_knows : lak_data -> lak_memory -> Prop;

        (* "owner" of the data *)
        lak_data2owner : lak_data -> node_type;

        (* to verify the authenticity of the data *)
        lak_data2auth : lak_data -> AuthenticatedData;
        lak_verify : forall {eo : EventOrdering} (e : Event) (d : lak_data), bool;

        (* the system *)
        lak_output : Type;
        lak_system : node_type -> StateMachine lak_memory msg lak_output;
        lak_no_initial_memory : forall n d, ~ lak_knows d (sm_state (lak_system n));
      }.

  Context { p : nat }.
  Context { lak : LearnAndKnow p }.

  Definition lak_data2node (d : lak_data) : name :=
    node2name (lak_data2owner d).

  Definition knows
             {eo : EventOrdering}
             (e  : Event)
             (d  : lak_data) :=
    exists mem n,
      loc e = node2name n
      /\ lak_knows d mem
      /\ state_sm_on_event (lak_system n) e = Some mem.

  Definition knew
             {eo : EventOrdering}
             (e  : Event)
             (d  : lak_data) :=
    exists mem n,
      loc e = node2name n
      /\ lak_knows d mem
      /\ state_sm_before_event (lak_system n) e = Some mem.

  (* We know a list of length [n] of [lak_info] stuff that we got from various owners *)
  Definition knows_certificate
             {eo : EventOrdering}
             (e : Event)
             (n : nat)
             (i : lak_info)
             (P : list lak_data -> Prop) :=
    exists (l : list lak_data),
      n <= length l
      /\ no_repeats (map lak_data2owner l)
      /\ P l
      /\ forall d, In d l -> (knows e d /\ i = lak_data2info d).

  Definition learns {eo : EventOrdering} (e : Event) (d : lak_data) :=
    exists n,
      loc e = node2name n
      /\ In (lak_data2auth d) (bind_op_list get_contained_authenticated_data (trigger e))
      (*/\ verify_authenticated_data (loc e) (lak_data2auth d) (keys e) = true.*)
      /\ lak_verify e d = true.

  Definition learned {eo : EventOrdering} (e : Event) (d : lak_data) :=
    exists e', e' ⊑ e /\ learns e' d.

  Definition learns_or_knows (eo : EventOrdering) : Prop :=
    forall (d  : lak_data) (e : Event),
      knows e d
      -> learned e d \/ lak_data2node d = loc e.

  Definition learns_if_knows (eo : EventOrdering) :=
    forall (d  : lak_data) (e : Event),
      learns e d
      -> has_correct_trace_before e (lak_data2node d)
      ->
      exists e',
        e' ≺ e
        /\ loc e' = lak_data2node d
        /\ knows e' d.

  Lemma knows_implies_correct :
    forall {eo : EventOrdering} (e : Event) (d : lak_data),
      knows e d
      -> has_correct_trace_before e (loc e).
  Proof.
    introv kn.
    unfold knows in kn; exrepnd.
    eapply state_sm_on_event_some_implies_has_correct_trace_before;eauto.
  Qed.
  Hint Resolve knows_implies_correct : eo.

  Lemma knows_propagates :
    forall {eo : EventOrdering} (e : Event) (d : lak_data),
      learns_or_knows eo
      -> learns_if_knows eo
      -> knows e d
      -> has_correct_trace_before e (lak_data2node d)
      ->
      exists e',
        e' ≼ e
        /\ loc e' = lak_data2node d
        /\ knows e' d.
  Proof.
    introv lok lik knows ctrace.
    pose proof (lok d e) as sent.
    repeat (autodimp sent hyp);[].
    repndors; repnd;[|exists e; dands; eauto 2 with eo];[].

    unfold learned in *; exrepnd.

    pose proof (lik d e') as h.
    repeat (autodimp h hyp); eauto 3 with eo;[].
    exrepnd.
    exists e'0; dands; auto; eauto 4 with eo.
  Qed.

  Lemma knows_in_intersection :
    forall {eo : EventOrdering}
           (e1 e2 : Event)
           (n : nat)
           (i1 i2 : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      learns_or_knows eo
      -> learns_if_knows eo
      -> n <= num_nodes
      -> num_nodes + F < 2 * n
      -> knows_certificate e1 n i1 P
      -> knows_certificate e2 n i2 P
      -> exists_at_most_f_faulty E F
      -> In e1 E
      -> In e2 E
      ->
      exists e1' e2' d1 d2,
        loc e1' = loc e2'
        /\ e1' ≼ e1
        /\ e2' ≼ e2
        /\ loc e1' = lak_data2node d1
        /\ loc e2' = lak_data2node d2
        /\ knows e1' d1
        /\ knows e2' d2
        /\ i1 = lak_data2info d1
        /\ i2 = lak_data2info d2.
  Proof.
    introv lok lik cond1 cond2 kna knb; introv atmost e1in e2in.
    unfold knows_certificate in *.
    destruct kna as [l1 [lena [norepa [conda impa]]]]; repnd.
    destruct knb as [l2 [lenb [norepb [condb impb]]]]; repnd.

    pose proof (overlapping_quorums_same_size
                  (MkNRlist _ (map lak_data2owner l1) norepa)
                  (MkNRlist _ (map lak_data2owner l2) norepb)
                  n) as q.
    simpl in q; autorewrite with list in *.
    repeat (autodimp q hyp); try omega;[].
    exrepnd.

    pose proof (there_is_one_correct_before eo l E F) as h.
    repeat (autodimp h hyp); try omega;[].
    exrepnd.

    pose proof (h0 e1) as ctrace1; simpl in ctrace1; autodimp ctrace1 hyp.
    pose proof (h0 e2) as ctrace2; simpl in ctrace2; autodimp ctrace2 hyp.

    applydup q3 in h1.
    applydup q0 in h1.
    allrw in_map_iff; exrepnd.

    applydup impa in h5.
    applydup impb in h4.
    repnd.

    pose proof (knows_propagates e1 x0) as w.
    repeat (autodimp w hyp); try (complete (unfold lak_data2node; allrw; auto));[].

    pose proof (knows_propagates e2 x) as z.
    repeat (autodimp z hyp); try (complete (unfold lak_data2node; allrw; auto));[].

    destruct w as [e1' w]; repnd.
    destruct z as [e2' z]; repnd.
    assert (loc e1' = loc e2') as eqloc' by (allrw; unfold lak_data2node; allrw; auto).

    exists e1' e2' x0 x; dands; auto.
  Qed.

  Lemma local_knows_in_intersection :
    forall {eo : EventOrdering}
           (e : Event)
           (n : nat)
           (i1 i2 : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      n <= num_nodes
      -> num_nodes + F < 2 * n
      -> knows_certificate e n i1 P
      -> knows_certificate e n i2 P
      -> exists_at_most_f_faulty E F
      -> In e E
      ->
      exists correct d1 d2,
        has_correct_trace_before e (node2name correct)
        /\ lak_data2node d1 = lak_data2node d2
        /\ knows e d1
        /\ knows e d2
        /\ i1 = lak_data2info d1
        /\ i2 = lak_data2info d2
        /\ lak_data2owner d1 = correct
        /\ lak_data2owner d2 = correct.
  Proof.
    introv cond1 cond2 kna knb atmost ein.
    unfold knows_certificate in *.
    destruct kna as [l1 [lena [norepa [conda impa]]]]; repnd.
    destruct knb as [l2 [lenb [norepb [condb impb]]]]; repnd.

    pose proof (overlapping_quorums_same_size
                  (MkNRlist _ (map lak_data2owner l1) norepa)
                  (MkNRlist _ (map lak_data2owner l2) norepb)
                  n) as q.
    simpl in q; autorewrite with list in *.
    repeat (autodimp q hyp); try omega;[].
    exrepnd.

    pose proof (there_is_one_correct_before eo l E F) as h.
    repeat (autodimp h hyp); try omega;[].
    exrepnd.

    exists correct.

    pose proof (h0 e) as ctrace1; simpl in ctrace1; autodimp ctrace1 hyp.

    applydup q3 in h1.
    applydup q0 in h1.
    allrw in_map_iff; exrepnd.

    applydup impa in h5.
    applydup impb in h4.
    repnd.

    exists x0 x; dands; auto;[].
    unfold lak_data2node; allrw; auto.
  Qed.

  Definition learns_or_knows_if_knew (eo : EventOrdering) : Prop :=
    forall (d  : lak_data) (e : Event),
      knew e d
      -> learned e d \/ lak_data2node d = loc e.

  Lemma knew_implies_knows :
    forall (eo : EventOrdering) (e : Event) (d : lak_data),
      knew e d
      -> knows (local_pred e) d.
  Proof.
    introv k.
    unfold knew in *; exrepnd.
    rewrite <- ite_first_state_sm_on_event_as_before in k1.
    unfold ite_first in k1; destruct (dec_isFirst e) as [de|de];
      [|exists mem n; autorewrite with eo; dands; auto];[].
    ginv.
    apply lak_no_initial_memory in k2; tcsp.
  Qed.

  Lemma learns_or_knows_implies_learns_or_knows_if_new :
    forall (eo : EventOrdering),
      learns_or_knows eo
      -> learns_or_knows_if_knew eo.
  Proof.
    introv lok k.
    apply knew_implies_knows in k.
    apply lok in k; autorewrite with eo in *.
    repeat (autodimp k hyp); eauto 3 with eo;[].
    repndors; tcsp; left;[].
    unfold learned in *; exrepnd.
    exists e'; dands; auto; eauto 3 with eo.
  Qed.

  Lemma knows_implies :
    forall {eo : EventOrdering} (e : Event) d,
      knows e d
      ->
      exists mem mem' n,
        loc e = node2name n
        /\ op_state (lak_system n) mem (trigger e) = Some mem'
        /\ lak_knows d mem'
        /\ state_sm_before_event (lak_system n) e = Some mem.
  Proof.
    introv kn.
    unfold knows in kn; exrepnd.
    rewrite state_sm_on_event_unroll2 in kn1.

    match goal with
    | [ H : context[map_option _ ?s] |- _ ] =>
      remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv]
    end.

    exists l mem n; dands; auto.
  Qed.

  Lemma knows_implies_before_after :
    forall {eo : EventOrdering} (e : Event) d,
      knows e d
      ->
      exists mem mem' n,
        loc e = node2name n
        /\ op_state (lak_system n) mem (trigger e) = Some mem'
        /\ lak_knows d mem'
        /\ state_sm_before_event (lak_system n) e = Some mem
        /\ state_sm_on_event (lak_system n) e = Some mem'.
  Proof.
    introv kn.
    unfold knows in kn; exrepnd.
    dup kn1 as ston.
    rewrite state_sm_on_event_unroll2 in kn1.

    match goal with
    | [ H : context[map_option _ ?s] |- _ ] =>
      remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv]
    end.

    exists l mem n; dands; auto.
  Qed.

  Lemma implies_knows :
    forall {eo : EventOrdering} (e : Event) d n mem,
      loc e = node2name n
      -> lak_knows d mem
      -> state_sm_on_event (lak_system n) e = Some mem
      -> knows e d.
  Proof.
    introv eqloc k eqst.
    eexists; eexists; dands; eauto.
  Qed.
  Hint Resolve implies_knows : eo.

  Lemma learned_local_pred_implies :
    forall (eo : EventOrdering) (e : Event) d,
      learned (local_pred e) d
      -> learned e d.
  Proof.
    introv h.
    unfold learned in *; exrepnd.
    eexists; dands; eauto; eauto 3 with eo.
  Qed.
  Hint Resolve learned_local_pred_implies : eo.

  Lemma learned_local_le_implies :
    forall (eo : EventOrdering) (e1 e2 : Event) d,
      e1 ⊑ e2
      -> learned e1 d
      -> learned e2 d.
  Proof.
    introv lee h.
    unfold learned in *; exrepnd.
    eexists; dands;[|eauto]; eauto 3 with eo.
  Qed.
  Hint Resolve learned_local_le_implies : eo.

  Definition learned_if_knows (eo : EventOrdering) :=
    forall (d  : lak_data) (e : Event),
      learned e d
      -> has_correct_trace_before e (lak_data2node d)
      ->
      exists e',
        e' ≺ e
        /\ loc e' = lak_data2node d
        /\ knows e' d.

  Lemma learns_if_knows_implies_learned_if_knows :
    forall (eo : EventOrdering),
      learns_if_knows eo
      -> learned_if_knows eo.
  Proof.
    introv lik l hc.
    unfold learned in l; exrepnd.
    apply lik in l0; autodimp l0 hyp; eauto 3 with eo.
    exrepnd.
    exists e'0; dands; eauto 3 with eo.
  Qed.
  Hint Resolve learns_if_knows_implies_learned_if_knows : eo.

  Lemma knows_weak_certificate :
    forall {eo : EventOrdering}
           (e : Event)
           (n : nat)
           (i : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      F < n
      -> knows_certificate e n i P
      -> exists_at_most_f_faulty E F
      -> In e E
      ->
      exists d,
        has_correct_trace_before e (lak_data2node d)
        /\ knows e d
        /\ i = lak_data2info d.
  Proof.
    introv cond kn atmost ein.
    unfold knows_certificate in *.
    destruct kn as [l [len [norep [condp imp]]]]; repnd.
    pose proof (there_is_one_correct_before eo (map lak_data2owner l) E F) as q.
    repeat (autodimp q hyp); autorewrite with list in *; try omega.
    exrepnd.
    allrw in_map_iff; exrepnd; subst.
    applydup imp in q2; repnd; simpl in *.
    exists x; dands; auto.
  Qed.

  Lemma knows_weak_certificate_propagates :
    forall {eo : EventOrdering}
           (e : Event)
           (n : nat)
           (i : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      learns_or_knows eo
      -> learns_if_knows eo
      -> F < n
      -> knows_certificate e n i P
      -> exists_at_most_f_faulty E F
      -> In e E
      ->
      exists e' d,
        e' ≼ e
        /\ loc e' = lak_data2node d
        /\ knows e' d
        /\ i = lak_data2info d.
  Proof.
    introv lok lik cond kn atmost ein.
    eapply knows_weak_certificate in kn; eauto; exrepnd; subst.
    apply knows_propagates in kn2; auto.
    exrepnd.
    exists e' d; dands; auto.
  Qed.

End LearnAndKnow.

Ltac prove_knows :=
  match goal with
  | [ |- knows _ _ ] =>
    eapply implies_knows; simpl;[| |eassumption];auto;
    autorewrite with eo; auto
  end.

Hint Resolve implies_knows : eo.
Hint Resolve learned_local_pred_implies : eo.
Hint Resolve learned_local_le_implies : eo.
Hint Resolve learns_if_knows_implies_learned_if_knows : eo.
Hint Resolve knows_implies_correct : eo.


Set Warnings "-notation-overridden".

Require Import LinearScan.Lib.
Require Import LinearScan.Context.
Require Import LinearScan.Interval.
Require Import LinearScan.ScanState.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Trace.

(* These T-suffixed types and constructors are for data that is meant to be
   exported from Coq, and so must dwell in [Set]. *)

Definition IntervalIdT : Set := nat.
Definition PhysRegT : Set := nat.

Inductive SpillConditionT : Set :=
  | NewToHandledT       of IntervalIdT
  | UnhandledToHandledT of IntervalIdT
  | ActiveToHandledT    of IntervalIdT & PhysRegT
  | InactiveToHandledT  of IntervalIdT & PhysRegT.

Inductive SplitPositionT : Set :=
  | BeforePosT of nat
  | EndOfLifetimeHoleT of nat.

Definition TrueIfActiveT : Set := bool.

Inductive SSTrace : Set :=
  | EIntersectsWithFixedInterval of nat & PhysRegT
  | ESplitAssignedIntervalForReg of IntervalIdT & PhysRegT & SplitPositionT
  | ESplitActiveOrInactiveInterval
      of IntervalIdT & TrueIfActiveT & SplitPositionT
  | EIntervalHasUsePosReqReg of nat
  | EIntervalBeginsAtSplitPosition
  | EMoveUnhandledToActive of IntervalIdT & PhysRegT
  | ESplitActiveIntervalForReg of PhysRegT & SplitPositionT
  | ESplitAnyInactiveIntervalForReg of PhysRegT & SplitPositionT
  | ESpillInterval of SpillConditionT
  | ESpillCurrentInterval
  | ESplitUnhandledInterval of IntervalIdT & SplitPositionT
  | ESplitCurrentInterval of IntervalIdT & SplitPositionT
  | ETryAllocateFreeReg of PhysRegT & option nat & IntervalIdT
  | EAllocateBlockedReg of PhysRegT & option nat & IntervalIdT
  | ERemoveUnhandledInterval of IntervalIdT
  | ECannotInsertUnhandled of nat & nat & nat & nat
  | EIntervalBeginsBeforeUnhandled of IntervalIdT
  | ENoValidSplitPosition of IntervalIdT
  | ECannotSplitSingleton of IntervalIdT
  | ERegisterAlreadyAssigned of PhysRegT
  | ERegisterAssignmentsOverlap of PhysRegT & IntervalIdT & nat
  | ECannotModifyHandledInterval of IntervalIdT
  | EUnexpectedNoMoreUnhandled
  | ECannotSpillIfRegisterRequired of IntervalIdT
  | ECannotSpillIfRegisterRequiredBefore of IntervalIdT & nat
  | EFuelExhausted
  | EUnhandledIntervalsRemain
  | EActiveIntervalsRemain
  | EInactiveIntervalsRemain
  | ENotYetImplemented of nat.

End Trace.


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.