Require ClassicalEpsilon.
Require Import Reals Psatz.
From stdpp Require Import tactics.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice bigop.
From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import pival_dist pival ival_dist ival ival_pair pidist_singleton idist_pidist_pair extrema irrel_equiv.
From discprob.prob Require Import prob countable finite stochastic_order.

Import Lub.

Record ival_couplingP' {A1 A2} (Is1: ivdist A1) (Is2: ivdist A2) (P: A1 → A2 → Prop) : Type :=
  mkICoupling { ic_witness :> ivdist {xy: A1 * A2 | P (fst xy) (snd xy)};
     ic_proj1: eq_ivd_prob Is1 (x ← ic_witness; mret (fst (sval x)));
     ic_proj2: eq_ivd_prob Is2 (x ← ic_witness; mret (snd (sval x)));
     }.

Record idist_pidist_couplingP' {A1 A2} (I1: ivdist A1) (I2: pidist A2) (P: A1 → A2 → Prop) : Type :=
  mkIPCoupling { elem_coupling : ivdist A2;
                 elem_member : irrel_pidist (singleton elem_coupling) I2;
                 elem_coupled :> ival_couplingP' I1 elem_coupling P }.

Lemma irrel_ivd_alt {A} (I1 I2: ivdist A):
  irrel_ivd I1 I2 ↔ (∀ f, bounded_fun f → Ex_ival f I1 = Ex_ival f I2).
Proof.
  split.
  - intros Hirrel.
    intros f Hb. apply Ex_ival_irrel_proper; eauto using ex_Ex_ivd_bounded_fun.
  - intros Hf.
    apply eq_ivd_prob_to_irrel_ivd.
    apply eq_ivd_prob_alt.
    rewrite /Ex_ival in Hf.
    rewrite /idx_eq_ind.
    intros x.
    efeed pose proof (Hf (λ y, if is_left (ClassicalEpsilon.excluded_middle_informative (y = x)) then
                                 1
                               else
                                 0)) as H'.
    {
      rewrite /bounded_fun. exists 1.  intros.
      destruct ClassicalEpsilon.excluded_middle_informative; rewrite ?Rabs_R1 ?Rabs_R0; nra.
    }
    rewrite //= in H'.
    setoid_rewrite Rmult_if_distrib in H'.
    setoid_rewrite Rmult_0_l in H'.
    setoid_rewrite Rmult_1_l in H'. eauto.
Qed.

Lemma irrel_couplingP_to_alt {A1 A2} (I1: ivdist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) :
  irrel_couplingP I1 Is2 P → idist_pidist_couplingP' I1 Is2 P.
Proof.
  intros [I1' Is2' Hirrel1 Hirrel2 Hcoup].
  destruct Hcoup as [I2 Hle Hcoup].
  exists I2.
  * setoid_rewrite <-Hirrel2.
    eapply irrel_pidist_proper; first eassumption; try reflexivity.
  * apply ic_coupling_to_id in Hcoup.
    destruct Hcoup as [Ic Hp1 Hp2].
    exists Ic; apply irrel_ivd_to_eq_ivd_prob.
    ** setoid_rewrite Hirrel1. setoid_rewrite Hp1. reflexivity.
    ** setoid_rewrite Hp2. reflexivity.
Qed.

Lemma alt_to_irrel_couplingP {A1 A2} (I1: ivdist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) :
  idist_pidist_couplingP' I1 Is2 P → irrel_couplingP I1 Is2 P.
Proof.
  intros [I2 Heq Hcoup].
  destruct Hcoup as [Ic Hp1 Hp2].
  unshelve (econstructor).
  { exact (Ic ≫= (λ x : {xy : A1 * A2 | P xy.1 xy.2}, mret (sval x).1)). }
  { exact (singleton (Ic ≫= (λ x : {xy : A1 * A2 | P xy.1 xy.2}, mret (sval x).2))). }
  { apply eq_ivd_prob_to_irrel_ivd. eassumption. }
  { etransitivity; last eapply Heq.
    eapply irrel_pidist_proper_irrel; [ | apply le_pidist_irrel_refl | reflexivity].
    { intros ? Hin. exists I2.
      inversion Hin as [Heq']; split.
      * apply eq_ivd_prob_to_irrel_ivd.  rewrite Hp2.
        cut (eq_ivd I (Ic ≫= (λ x : {xy : A1 * A2 | P xy.1 xy.2}, mret (sval x).2))).
        { intros ->. reflexivity. }
        { rewrite /eq_ivd -Heq' //=. }
      * rewrite //=.
    }
  }
  eexists; first reflexivity.
  exists Ic; reflexivity.
Qed.


Require Import stdpp.base.
Require Import stdpp.sets.
Require Import stdpp.fin_sets.

Require Import LocalTactics.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import DecEq.
Require Import IO.
Require Steps.

Require Import SyntaxParams.
Require Import HeapParams.
Module SXML (varParams: SyntaxParams) (heapParams: HeapParams).
  Export varParams.
  Export heapParams.

  (* Source language *)

  Inductive smallExp :=
  | tupleExp : list var -> smallExp
  | appExp : var -> var -> smallExp
  | projExp : var -> nat -> smallExp
  | writeExp : var -> smallExp
  | readExp : smallExp
  | constExp : bool -> smallExp
  .

  Inductive exp :=
  | letsmall : var -> smallExp -> exp -> exp
  | letabs : var -> var -> exp -> exp -> exp
  | branch : var -> exp -> exp -> exp
  | tail : var -> var -> exp
  | ret : var -> exp
  .

  (* Operational types *)

  Inductive value :=
  | vaddr : addr -> value
  | vconst : bool -> value
  .

  Definition env : Type := list (var * value).
  Definition clos := (var * exp * env)%type.

  Inductive svalue :=
  | sclos : clos -> svalue
  | stuple : list value -> svalue
  .

  Record state :=
    { icode : exp
    ; ienv : env
    ; iheap : heap svalue
    ; istack : list clos }.

  Notation "'<<' c ',' e ',' h ',' k '>>'" := (Build_state c e h k) (at level 60) : interp_scope.
  Bind Scope interp_scope with state.
  Delimit Scope interp_scope with interp.

  (* Step definitions *)

  Inductive store_path
    :=
    | clos_var (v: var) :
        store_path ->
        store_path
    | tuple_proj (i: nat) :
        store_path ->
        store_path
    | here : store_path
  .

  Record access_path :=
    { ap_stack_env : nat
    ; ap_env_var : var
    ; ap_store_path : store_path
    }
  .

  Fixpoint lookup_store_path (h: heap svalue) val spath: option value
    :=
      match spath, val with
      | clos_var v rest, vaddr a =>
        match h !! a with
        | Some (sclos (_, _, env)) =>
          match search v env with
          | Some val => lookup_store_path h val rest
          | None => None
          end
        | _ => None
        end
      | tuple_proj i rest, vaddr a =>
        match h !! a with
        | Some (stuple xs) =>
          match nth_error xs i with
          | Some val => lookup_store_path h val rest
          | None => None
          end
        | _ => None
        end
      | _, _ => Some val
      end
  .

  Definition lookup_store_value (h: heap svalue) val spath : option svalue
    :=
      match lookup_store_path h val spath with
      | Some (vaddr a) => h !! a
      | _ => None
      end.

  Definition lookup_object (e: env) (h: heap svalue) (x: var): option svalue :=
    match e !! x with
    | Some (vaddr a) => h !! a
    | _ => None
    end.

  (* TODO: read is missing *)
  Inductive step : option io_evt -> state -> state -> Prop :=
  | step_tuple x xs cr e h k vs a h' :
      forall (lkps: searches xs e = Some vs)
             (alloc_tuple: alloc h (stuple vs) = (a, h')),
      step None
        (<< letsmall x (tupleExp xs) cr , e, h, k >>)
        (<< cr , (x, vaddr a) :: e, h', k >>)
  | step_app x xf xa cr e h k xl el cl v :
      forall (lkp_clos_addr:
                lookup_object e h xf = Some (sclos (xl, cl, el)))
             (lkp_arg: e !! xa = Some v),
      step None
        (<< letsmall x (appExp xf xa) cr , e, h, k >>)
        (<< cl , (xl, v) :: el, h, (x, cr, e) :: k >>)
  | step_proj x xt i cr e h k vs v :
      forall (lkp_proj: lookup_object e h xt = Some (stuple vs))
             (proj_tuple: nth_error vs i = Some v),
      step None
        (<< letsmall x (projExp xt i) cr , e, h, k >>)
        (<< cr , (x, v) :: e, h, k >>)
  | step_write x xw cr e h k b :
      forall (lkp_write: e !! xw = Some (vconst b)),
      step (Some (write b))
        (<< letsmall x (writeExp xw) cr , e, h, k >>)
        (<< cr , (x, vconst true) :: e, h, k >>)
  | step_const x b cr e h k :
      step None
        (<< letsmall x (constExp b) cr , e, h, k >>)
        (<< cr , (x, vconst b) :: e,  h, k >>)
  | step_abs x xl cl cr e h k h' a :
      forall (alloc_abs: alloc h (sclos (xl, cl, e)) = (a, h')),
      step None
        (<< letabs x xl cl cr , e, h, k >>)
        (<< cr , (x, vaddr a) :: e, h', k >>)
  | step_branch xb ct cf e h k b :
      forall (lkp_branch: e !! xb = Some (vconst b)),
      step None
        (<< branch xb ct cf , e, h, k >>)
        (<< if b then ct else cf , e, h, k >>)
  | step_ret xr e h xl cl el k v :
      forall (lkp: e !! xr = Some v),
      step None
        (<< ret xr , e, h, (xl, cl, el) :: k >>)
        (<< cl , (xl, v) :: el, h, k >>)
  .

  Theorem step_det : forall s1 s2 s3 io,
      step io s1 s2 ->
      step io s1 s3 ->
      s2 = s3.
  Proof.
    intros.
    inversion H; inversion H0; simplify_eq;
      congruence.
  Qed.

  Definition start_state c : state := (<< c, [], empty, [] >>)%interp.

  (* This is propositional up to extensionality,
     but we need to use the information when computing
     some data that we need in Type for computing sizes *)
  CoInductive not_stuck : state -> Type
    :=
    | can_pure s1 s2 :
        step None s1 s2 ->
        not_stuck s2 ->
        not_stuck s1
    | can_read s1 s2 :
        (forall k,
            step (Some (read k)) s1 s2 *
            not_stuck s2) ->
        not_stuck s1
    | can_write s1 s2 k :
        step (Some (write k)) s1 s2 ->
        not_stuck s2 ->
        not_stuck s1
    | finished xr e h :
        not_stuck (<< ret xr , e, h, [] >>)
  .

  Theorem not_stuck_step :
    forall i s1 s2,
      not_stuck s1 ->
      step i s1 s2 ->
      not_stuck s2.
  Proof with eauto.
    intros.
    destruct X.
    - enough (i = None).
      subst.
      destruct (step_det s1 s0 s2 None s H)...
      destruct H; inversion s; reflexivity.
    - destruct i.
      + destruct i.
        (* write *)
        * exfalso. destruct (p false).
          destruct H; inversion s.
        * destruct (p b).
          destruct (step_det s1 s0 s2 (Some (read b)))...
      + exfalso. destruct (p false).
        destruct H; inversion s.
    - enough (i = Some (write k))...
      subst.
      destruct (step_det s1 s0 s2 (Some (write k)))...
      inversion s; subst; inversion H; congruence.
    - exfalso. inversion H.
  Qed.

  Global Hint Resolve not_stuck_step : steps.

  Inductive free_in_small : var -> smallExp -> Prop
    :=
    | free_tuple x vs :
        In x vs ->
        free_in_small x (tupleExp vs)
    | free_app_f x va :
        free_in_small x (appExp x va)
    | free_app_a x vf :
        free_in_small x (appExp vf x)
    | free_proj x i:
        free_in_small x (projExp x i)
    | free_write x :
        free_in_small x (writeExp x)
  .

  Inductive free_in : var -> exp -> Prop
    :=
    | free_smallExp x v se er :
        free_in_small x se ->
        free_in x (letsmall v se er)
    | free_smallExp_r x v se er :
        free_in x er ->
        x <> v ->
        free_in x (letsmall v se er)
    | free_abs x v vl el er :
        free_in x el ->
        x <> vl ->
        free_in x (letabs v vl el er)
    | free_abs_r x v vl el er :
        free_in x er ->
        x <> v ->
        free_in x (letabs v vl el er)
    | free_ret x :
        free_in x (ret x)
    | free_branch_test b et ef:
        free_in b (branch b et ef)
    | free_branch_true x b et ef:
        free_in x et ->
        free_in x (branch b et ef)
    | free_branch_false x b et ef:
        free_in x ef ->
        free_in x (branch b et ef)
    | free_tail_f x va :
        free_in x (tail x va)
    | free_tail_a vf x:
        free_in x (tail vf x)
  .
  Hint Constructors free_in free_in_small : free_in.

  Fixpoint free_vars (e: exp): vars
    :=
    match e with
    | letsmall v se er =>
      union (
      match se with
      | tupleExp vs => list_to_set vs
      | appExp vf va => union {[vf]} {[va]}
      | projExp v _ => {[v]}
      | readExp => empty
      | writeExp v => {[v]}
      | constExp c => empty
      end)
      (difference (free_vars er) {[v]})
    | letabs v vl el er =>
      union
        (difference (free_vars el) {[vl]})
        (difference (free_vars er) {[v]})
    | ret x => {[x]}
    | tail vf va => union {[vf]} {[va]}
    | branch b et ef =>
      union {[b]}
      (union (free_vars et) (free_vars ef))
    end.

  Theorem in_free_vars_iff_free_in : forall v e,
      elem_of v (free_vars e) <-> free_in v e.
  Proof with eauto.
    split. intros.
    (* -> *)
    - induction e; simpl in H |- *; set_unfold.
      (* letsmall *)
      + destruct H...
        (* in smallExp *)
        * apply free_smallExp.
          destruct s; set_unfold; subst;
            try contradiction;
            try constructor...
          { rewrite <- elem_of_list_In... }
          (* app *)
          -- destruct H; subst.
             ++ constructor...
             ++ constructor.
        (* in rest *)
        * destruct H. apply free_smallExp_r...
      (* letabs *)
      + destruct H as [[? ?] | [? ?]].
        (* v in free_vars e1 - v1 *)
        * apply free_abs...
        * apply free_abs_r...
      (* branch *)
      + destruct H as [? | [? | ?]]; subst.
        * constructor...
        * apply free_branch_true...
        * apply free_branch_false...
      (* tail *)
      + destruct H; subst; constructor...
      (* ret *)
      + destruct H...
        apply free_ret.
    - intros H. induction H; simpl; set_unfold...
      (* in small *)
      + inversion H; set_unfold; simplify_eq...
        (* tuple *)
        rewrite <- elem_of_list_In in H0...
  Qed.
  (* Blocks computation too much
  Instance set_unfold_free_vars {v e} : SetUnfold (elem_of v (free_vars e)) (free_in v e) :=
    { set_unfold := (in_free_vars_iff_free_in v e) }.
   *)

  Hint Resolve -> in_free_vars_iff_free_in : free_in addr_in.
  Hint Resolve <- in_free_vars_iff_free_in : free_in addr_in. (* useful to have these in addr_in for environments *)

  Definition clos_size (cls: clos): nat
    := match cls with
       | (xl, el, cl) => 1 + size (difference (free_vars el) {[xl]})
       end.

  Definition svalue_size (sv : svalue): nat
    :=
      match sv with
      | sclos cls => clos_size cls
      | stuple vs => 1 + length vs
      end.

  Definition value_to_addr (v: value): option addr
    :=
      match v with
      | vaddr a => Some a
      | _ => None
      end.
  (* This is weird but saves a lot of trouble *)
  Instance set_unfold_value_to_addr {v a} : SetUnfold (value_to_addr v = Some a) (v = vaddr a).
  Proof with eauto.
    intros; split; split; intros.
    - forced v. simpl in H. congruence.
    - subst. reflexivity.
  Qed.

  Definition var_points_to_addr (x: var) e := exists a, In (x, vaddr a) e.

  Definition env_addresses (xs: vars) (e: env) : addrs
    :=
      list_to_set
        (filter_map (fun v => match search v e with
                              | Some (vaddr a) => Some a
                              | _ => None
                              end)
        (elements xs)).

  Definition clos_addresses (clos: clos): addrs
    :=
      match clos with
      | (xl, cl, el) => env_addresses (difference (free_vars cl) {[xl]}) el
      end.

  Definition svalue_addresses (sv : svalue): addrs
    :=
      match sv with
      | sclos cl => clos_addresses cl
      | stuple vs =>
        list_to_set (filter_map value_to_addr vs)
      end.

  Definition address_addresses (h: heap svalue) (a: addr): addrs
    :=
      match h !! a with
      | Some sv => svalue_addresses sv
      | None => empty
      end.

  Definition sum_list := fold_right plus 0.

  Definition lookup_size (size1: svalue -> nat) (h: heap svalue) (a: addr) :=
    match h !! a with
    | Some sv => size1 sv
    | None => 0
    end.

  Definition live_roots st
    :=
      match st with
      | << c, e, h, k >>%interp =>
        let stack_roots := union_list (map clos_addresses k) in
        union
          stack_roots
          (env_addresses (free_vars c) e)
      end.

  Definition space_of (size1: svalue -> nat) (h: heap svalue) (addrs1: addrs) :=
    sum_list (map (lookup_size size1 h) (elements addrs1)).

  Instance sum_list_perm : Proper (Permutation ==> eq) sum_list.
  Proof.
    unfold Proper, respectful.
    intros.
    induction H; simpl; congruence || lia.
  Qed.

  Instance sum_list_sublist : Proper (submseteq ==> le) sum_list.
  Proof.
    unfold Proper, respectful.
    intros.
    induction H; simpl; lia.
  Qed.

  Instance map_sublist {A B} {f: A -> B} : Proper (@submseteq A ==> @submseteq B) (map f).
  Proof with auto.
    unfold Proper, respectful.
    intros.
    induction H; simpl.
    - apply submseteq_nil...
    - apply submseteq_skip...
    - apply submseteq_swap...
    - apply submseteq_cons...
    - apply submseteq_trans with (map f l2)...
  Qed.

  Instance space_of_equiv {size1 h} : Proper (equiv ==> eq) (space_of size1 h).
  Proof.
    intros. unfold space_of, Proper, respectful.
    intros.
    rewrite -> H.
    reflexivity.
  Qed.

  Instance space_of_subset {size1 h} : Proper (subseteq ==> le) (space_of size1 h).
    unfold Proper, respectful.
    intros.
    unfold space_of.
    apply sum_list_sublist.
    apply map_sublist.
    apply elements_submseteq.
    exact H.
  Qed.

  Theorem sum_list_app {l1 l2} : sum_list (l1 ++ l2) = sum_list l1 + sum_list l2.
  Proof with eauto.
    induction l1; simpl; lia.
  Qed.

  Lemma addrs_space_singleton {size1 h a1} : space_of size1 h (singleton a1) = lookup_size size1 h a1.
  Proof with eauto.
    intros. unfold space_of.
    rewrite -> elements_singleton.
    simpl...
  Qed.

  Lemma addrs_space_union {size1 h as1 as2} : as1 ## as2 -> space_of size1 h (union as1 as2) = space_of size1 h as1 + space_of size1 h as2.
  Proof with eauto.
    intros.
    unfold space_of.
    rewrite -> elements_disj_union...
    rewrite -> map_app.
    rewrite -> sum_list_app.
    done.
  Qed.

  Lemma addrs_space_extension {size1 h h' addrs} :
    heap_extension h h' ->
    (forall a s, elem_of a addrs -> h' !! a = Some s -> h !! a = Some s) ->
    space_of size1 h addrs = space_of size1 h' addrs.
  Proof with eauto.
    intros.
    induction H...
    rewrite <- IHheap_extension.
    (* one extension *)
    - unfold space_of.
      f_equal.
      apply map_ext_in.
      intros. set_unfold.

      rewrite <- elem_of_list_In in H2.
      assert (elem_of a0 addrs) by set_solver.
      unfold lookup_size.
      destruct (h2 !! a0) eqn:lkp2.
      + assert (h3 !! a0 = Some s) by (apply (found_extension _ _ H1 lkp2)).
        assert (H5: h1 !! a0 = Some s)...
        rewrite -> H5...
      + assert (h1 !! a0 = None) by eauto with heaps.
        rewrite -> H4...
    - intros.
      apply H0 in H3...
      eauto with heaps.
  Qed.

  Definition addrs_space0 :=
    space_of svalue_size.
  Definition addrs_space size1 s (addrs: addrs) :=
    match s with
    | << _, _, h, k >>%interp =>
      space_of size1 h addrs
    end.

  (*

    In order to be able to push validity and freshness statements through, we want to be able
    to talk about which addresses could possibly appear.

   *)

  Inductive addr_in_val : AddrIn value :=
  | addr_in_vaddr a :
      addr_in (vaddr a) a.
  Global Existing Instance addr_in_val.
  Global Hint Constructors addr_in_val : addr_in.
  Global Hint Extern 5 =>
    match goal with
    | [ H: addr_in_val (vconst _) _ |- _ ] =>
      solve [inversion H]
    | [ H: @addr_in value _ (vconst _) _ |- _ ] =>
      solve [inversion H]
    | [ H: addr_in_val ?v ?a |- _ ] =>
      (replace v with (vaddr a) in * by (inversion H; subst; reflexivity);
       clear H)
    | [ H: @addr_in value _ ?v ?a |- _ ] =>
      (replace v with (vaddr a) in * by (inversion H; subst; reflexivity);
       clear H)
    end : addr_in.

  Global Instance addr_in_env : AddrIn (env * vars) :=
    fun p =>
      let (e, xs) := p in
        fun a =>
        exists x v,
          e !! x = Some v /\
          elem_of x xs /\
          addr_in v a.

  Global Instance addr_in_env0 : AddrIn env :=
    fun e => fun a =>
      exists x v,
        e !! x = Some v /\
        addr_in v a.

  Global Instance addr_in_clos : AddrIn clos :=
    fun clos =>
      match clos with
      | (xl, cl, el) => addr_in (el, difference (free_vars cl) {[xl]})
      end.
  Instance clos_addresses' : Addresses clos :=
    { addresses := clos_addresses }.
  Proof with eauto.
    intros.
    unfold addr_in, addr_in_clos, addr_in, addr_in_env.
    destruct sv as [[xl cl] el].
    split; intros; deep_set_unfold.
    - forced (search x el). forced v.
      simplify_eq.
      exists x, (vaddr a).
      repeat split_and...
      constructor.
    - unfold lookup in *.
      exists x. rewrite -> H.
      inversion H1...
  Defined.

  Global Instance addr_in_list `{AddrIn X}: AddrIn (list X)
    :=
      fun l =>
        fun a =>
          exists x,
            In x l /\ addr_in x a.

  Global Instance addr_in_svalue : AddrIn svalue :=
    fun sv =>
      match sv with
      | stuple vs => addr_in vs
      | sclos clos => addr_in clos
      end.
  Instance svalue_addresses' : Addresses svalue :=
    { addresses := svalue_addresses }.
  Proof with eauto.
    intros; split; intros.
    - destruct sv; simpl in H.
      + destruct c; simpl in *. destruct p.
        unfold addr_in, addr_in_svalue, addr_in, addr_in_clos, addr_in, addr_in_env.
        unfold env_addresses in H.
        deep_set_unfold. unfold lookup.
        forced (search x e).
        forced v0. simplify_eq.
        exists x, (vaddr a). repeat split_and...
        constructor.
      + deep_set_unfold.
        unfold addr_in, addr_in_svalue, addr_in, addr_in_list.
        exists (vaddr a). split... rewrite <- elem_of_list_In...
        constructor.
    - unfold addr_in in H. destruct sv; simpl in *.
      + destruct c as [[xl cl] el].
        repeat unfold addr_in, addr_in_clos, addr_in_env in *.
        deep_set_unfold.
        inversion H1; subst.
        exists x. split...
        unfold lookup in H.
        rewrite -> H...
      + set_unfold.
        unfold addr_in, addr_in_list in *.
        deprod. exists x. rewrite -> elem_of_list_In.
        split...
        inversion H0; subst...
  Defined.

  Global Instance addr_in_heap `{AddrIn X} : AddrIn (heap X)
    :=
      fun h =>
        fun a =>
          exists a' sv,
            h !! a' = Some sv /\ addr_in sv a.

  Global Instance addr_in_state : AddrIn state
    :=
      fun s =>
        match s with
        | (<< c, e, h, k >>)%interp =>
          fun a =>
            addr_in h a \/ addr_in k a \/ addr_in (e, free_vars c) a
        end.

  Definition valid_in_heap `{AddrIn X} (x: X) (h: heap svalue): Prop
    :=
      forall a,
        addr_in x a -> h !! a <> None.

  Lemma heap_valid_in_heap h :
    valid_in_heap h h <-> heap_valid h.
  Proof with eauto.
    intros. unfold heap_valid, valid_in_heap, addr_in, addr_in_heap.
    split; intro H.
    - intros. apply H...
    - intros. deprod...
  Qed.

  Lemma valid_in_heap_alloc `{AddrIn X} (x: X) h h' a sv :
    alloc h sv = (a, h') ->
    valid_in_heap x h ->
    valid_in_heap x h'.
  Proof.
    unfold valid_in_heap.
    intros.
    eauto with heaps.
  Qed.

  Lemma const_valid_in_heap :
    forall b h,
    valid_in_heap (vconst b) h.
  Proof.
    unfold valid_in_heap. intros.
    inversion H.
  Qed.

  Global Hint Transparent valid_in_heap addr_in lookup : addr_in.
  Global Hint Unfold addr_in_list addr_in_env0 addr_in_env addr_in_heap addr_in_list addr_in_svalue addr_in_clos addr_in_state : addr_in.
  Global Hint Constructors addr_in_val.
  Global Hint Extern 1 (addr_in _ _) => unfold addr_in :  addr_in.
  Global Hint Unfold In : addr_in.
  Global Hint Resolve const_valid_in_heap : addr_in.
  Global Hint Resolve valid_in_heap_alloc : addr_in.
  Global Hint Resolve -> heap_valid_in_heap : addr_in.
  Global Hint Resolve <- heap_valid_in_heap : addr_in.

  Global Hint Resolve search_In : addr_in.

  Ltac addr_conflict h a :=
    match goal with
    | |- ¬ _ => intro
    | _ => idtac
    end;
    absurd (h !! a = None);
    solve [match goal with
    | [ |- ?h !! ?a = None ] => eauto with heaps
    | [ |- ?h !! ?a <> None ] => eauto 20 with addr_in
    end].

  Local Example ex_addr_in_cons :
    forall (h : heap svalue)  v a1 a2 vs,
      h !! a1 = Some (stuple (v :: vaddr a2 :: vs)) ->
    addr_in h a2.
  Proof.
    eauto 20 with addr_in.
  Qed.

  Lemma addr_in_cons `{AddrIn X} : forall a x (xs : list X),
      addr_in xs a ->
      addr_in (x :: xs) a.
  Proof with auto.
    intros.
    unfold addr_in, addr_in_list in *.
    destruct H0 as [x0 [? ?]].
    exists x0. split...
    right...
  Qed.

  Global Hint Resolve addr_in_cons : addr_in.

  Lemma addr_in_search : forall (e: env) (xs: vars) a x v,
      search x e = Some v ->
      elem_of x xs ->
      addr_in v a ->
      addr_in (e, xs) a.
  Proof with eauto.
    intros.
    assert (In (x, v) e) by eauto with searches.
    unfold addr_in, addr_in_env.
    exists x, v.
    repeat split_and...
  Qed.
  Lemma addr_in_search0 : forall (e: env) (xs: vars) a x v,
      search x e = Some v ->
      addr_in v a ->
      addr_in e a.
  Proof with eauto.
    intros.
    assert (In (x, v) e) by eauto with searches.
    unfold addr_in, addr_in_env.
    exists x, v.
    repeat split_and...
  Qed.
  Lemma addr_in_env_lookup : forall (e : env) (xs: vars) a x v,
      e !! x = Some v ->
      elem_of x xs ->
      addr_in v a ->
      addr_in (e, xs) a.
  Proof.
    unfold lookup. apply addr_in_search.
  Qed.
  Lemma addr_in_searches : forall (e: env) (xs0: vars) a xs vs,
      searches xs e = Some vs ->
      (forall x, In x xs -> elem_of x xs0) ->
      addr_in vs a ->
      addr_in (e, xs0) a.
  Proof with auto.
    intros. unfold searches in *.
    generalize dependent vs.
    induction xs; simpl; intros vs H in1; simplify_eq.
    - unfold addr_in, addr_in_list in in1.
      destruct in1 as [? [? ?]]; contradiction.
    - forced (search a0 e).
      forced (map_option (flip search e) xs).
      simplify_eq.
      unfold addr_in, addr_in_list in in1.
      deprod.
      destruct H; subst.
      + apply addr_in_search with a0 x...
      + apply IHxs with l...
        { intros. apply H0. right... }
        unfold addr_in, addr_in_list.
        exists x...
  Qed.
  Lemma addr_in_searches0 : forall (e: env) (xs0: vars) a xs vs,
      searches xs e = Some vs ->
      addr_in vs a ->
      addr_in e a.
  Proof with auto.
    intros. unfold searches in *.
    generalize dependent vs.
    induction xs; simpl; intros vs H in1; simplify_eq.
    - unfold addr_in, addr_in_list in in1.
      destruct in1 as [? [? ?]]; contradiction.
    - forced (search a0 e).
      forced (map_option (flip search e) xs).
      simplify_eq.
      unfold addr_in, addr_in_list in in1.
      deprod.
      destruct H; subst.
      + apply addr_in_search0 with a0 x...
      + apply IHxs with l...
        { intros. exists x... }
  Qed.
  Lemma In_env_valid : forall h e xs x v,
      valid_in_heap (e, xs) h ->
      elem_of x xs ->
      e !! x = Some v ->
      valid_in_heap v h.
  Proof with eauto.
    unfold valid_in_heap. intros.
    apply H. unfold addr_in, addr_in_env.
    exists x, v. repeat split_and...
  Qed.

  Global Hint Resolve addr_in_search addr_in_search0 addr_in_env_lookup addr_in_searches addr_in_searches0 : addr_in.

  Definition state_valid (s: state): Prop
    :=
      match s with
      | (<< _, _, h, _ >>)%interp =>
        valid_in_heap s h
      end.

  Lemma state_valid_product :
    forall c e h k,
      valid_in_heap (e, free_vars c) h /\
      valid_in_heap h h /\
      valid_in_heap k h
      <->
      valid_in_heap (<< c, e, h, k >>)%interp h.
  Proof with eauto.
    unfold valid_in_heap.
    intros; split; intros.
    - unfold addr_in, addr_in_state in H0.
      destruct H as [? [? ?]].
      destruct H0 as [? | [? | ?]]...
    - unfold addr_in, addr_in_state in H.
      repeat split...
  Qed.

  Lemma state_valid_into_heap :
    forall c e h k,
      valid_in_heap (<< c, e, h, k >>)%interp h ->
      valid_in_heap h h.
  Proof with eauto.
    intros.
    rewrite <- state_valid_product in *.
    deprod...
  Qed.

  Global Hint Extern 1 (valid_in_heap _ _) => unfold valid_in_heap :  addr_in.
  Global Hint Transparent state_valid : addr_in.
  Global Hint Transparent lookup : addr_in.
  Global Hint Resolve state_valid_into_heap : addr_in.
  Global Hint Resolve -> state_valid_product : addr_in.
  Global Hint Resolve <- state_valid_product : addr_in.

  Lemma extend_valid_env0 :
    forall (e : env) x sv a h h',
      alloc h sv = (a, h') ->
      valid_in_heap e h ->
      valid_in_heap ((x, vaddr a) :: e) h'.
  Proof with eauto.
    unfold valid_in_heap.
    intros.
    destruct H1 as [x0 [v0 [lkpx0 addrv0]]].
    unfold lookup in lkpx0. simpl in lkpx0.
    unfold addr_in in addrv0.
    inversion addrv0; subst.
    destruct (decEq x0 x); simplify_eq; deprod...
    - eauto with heaps.
    - eapply not_dangling_later...
      apply H0.
      eauto 20 with addr_in.
  Qed.
  Lemma extend_valid :
    forall (e : env) (xs : vars) x sv a h h',
      alloc h sv = (a, h') ->
      valid_in_heap (e, xs) h ->
      valid_in_heap ((x, vaddr a) :: e, xs) h'.
  Proof with eauto.
    unfold valid_in_heap.
    intros.
    destruct H1 as [x0 [v0 [lkpx0 addrv0]]].
    unfold lookup in lkpx0. simpl in lkpx0.
    unfold addr_in in addrv0.
    inversion addrv0; subst.
    destruct (decEq x0 x); simplify_eq; deprod...
    - inversion H4; subst. eauto with heaps.
    - eapply not_dangling_later...
      apply H0.
      unfold addr_in, addr_in_env.
      eauto 20 with addr_in.
  Qed.

  Global Hint Resolve extend_valid extend_valid_env0 : addr_in.

  Lemma env_cons_addr_in : forall a x v (e : env) c,
      addr_in ((x, v) :: e, c) a ->
      addr_in v a \/ addr_in (e, c) a.
  Proof with eauto.
    intros.
    unfold addr_in, addr_in_env in *.
    deprod. unfold lookup in H. simpl in H.
    destruct (decEq x0 x); simplify_eq.
    - left...
    - right...
  Qed.
  Lemma env_cons_valid : forall h (e: env) c (v: value) x,
    valid_in_heap v h ->
    valid_in_heap (e, c) h ->
    valid_in_heap ((x, v) :: e, c) h.
  Proof.
    intros.
    unfold valid_in_heap in *.
    intros.
    apply env_cons_addr_in in H1.
    destruct H1; eauto with addr_in.
  Qed.
  Lemma env0_cons_addr_in : forall a x v (e : env),
      addr_in ((x, v) :: e) a ->
      addr_in v a \/ addr_in e a.
  Proof with eauto.
    intros.
    unfold addr_in, addr_in_env0 in *.
    deprod. unfold lookup in H. simpl in H.
    destruct (decEq x0 x); simplify_eq.
    - left...
    - right...
  Qed.
  Lemma env0_cons_valid : forall h (e: env) (v: value) x,
    valid_in_heap v h ->
    valid_in_heap e h ->
    valid_in_heap ((x, v) :: e) h.
  Proof.
    intros.
    unfold valid_in_heap in *.
    intros.

    apply env0_cons_addr_in in H1.
    destruct H1; eauto with addr_in.
  Qed.
  Global Hint Resolve env_cons_addr_in env_cons_valid : addr_in.
  Global Hint Resolve env0_cons_addr_in env0_cons_valid : addr_in.

  Lemma state_valid_start :
    forall P,
      state_valid (start_state P).
  Proof with eauto.
    intros.
    unfold state_valid.
    unfold start_state.
    do 2 intro.
    unfold addr_in, addr_in_state in H.
    destruct H.
    { inversion H. deprod.
      rewrite -> lookup_empty in H0.
      discriminate. }
    { inversion H; deprod; inversion H0; deprod; inversion H1. }
  Qed.

  Lemma state_valid_step :
    forall s1 s2 i,
      state_valid s1 ->
      step i s1 s2 ->
      state_valid s2.
  Proof with eauto 10 with heaps addr_in.
    unfold state_valid.
    intros. destruct s1, s2.
    rewrite <- state_valid_product in *.
    destruct H as [oldenv [oldheap oldstack]].
    inversion H0; subst; repeat split;
      try solve [typeclasses eauto 10 with addr_in];
    unfold valid_in_heap in *; intros...
    (* tuple env *)
    - destruct (decEq a a0); subst; eauto with heaps.
      eapply not_dangling_later...
      destruct H as [x0 [sv0 [? ?]]]; subst.
      unfold addr_in in H0. simpl in H0.
      unfold lookup in H.
      simpl in H.
      deprod.
      inversion H2; subst.
      forced (decEq x0 x).
      apply oldenv.
      unfold addr_in, addr_in_env.
      unfold lookup.
      exists x0, (vaddr a0).
      repeat split_and...
      simpl. set_solver.
    - destruct (decEq a a0); subst; eauto with heaps.
      eapply not_dangling_later...
      destruct H. deprod.
      destruct (decEq x0 a); subst...
      apply oldenv.
      assert (iheap1 !! a = Some (stuple vs)) by eauto with heaps.
      simplify_eq.
      inversion H1; subst. deprod.
      destruct (In_searches _ _ _ _ lkps H2).
      deprod.
      exists x1, x0.
      repeat split_and...
      (* fv *)
      simpl. rewrite <- elem_of_list_In in H4. clear - H4. set_solver.
    (* app env *)
    - destruct H; deprod.
      unfold lookup in H.
      simpl in H.
      destruct (decEq x0 xl); simplify_eq.
      + apply oldenv. exists xa, v0.
        repeat split_and...
        simpl. set_solver.
      + apply oldheap. unfold lookup_object in *.
        forced (ienv0 !! xf).
        forced v1. simplify_eq.
        exists a0, (sclos (xl, icode1, el)).
        split_and...
        exists x0, v0.
        repeat split_and...
        set_solver.
    (* app stack *)
    - inversion H. deprod.
      destruct H1; simplify_eq...
      apply oldenv.
      unfold addr_in, addr_in_clos in H2.
      simpl.
      destruct H2. deprod.
      exists x0, v0.
      repeat split_and...
      set_solver.
    (* proj env *)
    - destruct H. deprod.
      unfold lookup in H.
      simpl in H.
      destruct (decEq x0 x); simplify_eq.
      + apply oldheap. unfold lookup_object in *.
        forced (ienv0 !! xt).
        forced v.
        simplify_eq.
        exists a0, (stuple vs).
        split...
        split with v0.
        split...
        eapply nth_error_In...
      + apply oldenv.
        exists x0, v0.
        repeat split_and...
        simpl. set_solver.
    (* write env *)
    - destruct H. deprod.
      unfold lookup in H.
      simpl in H.
      destruct (decEq x0 x); simplify_eq.
      + inversion H2.
      + apply oldenv.
        exists x0, v. repeat split_and...
        simpl. set_solver.
    (* const env *)
    - destruct H. deprod.
      unfold lookup in H.
      simpl in H.
      destruct (decEq x0 x); simplify_eq.
      + inversion H2.
      + apply oldenv.
        exists x0, v. repeat split_and...
        simpl. set_solver.
    (* abs env *)
    - destruct (decEq a a0); subst; eauto with heaps.
      eapply not_dangling_later...
      destruct H. deprod.
      unfold lookup in H. simpl in H.
      destruct (decEq x0 x); subst...
      apply oldenv.
      assert (iheap1 !! a = Some _) by eauto with heaps.
      simplify_eq.
      inversion H2; subst.
      exists x0, (vaddr a0).
      repeat split_and...
      simpl. set_solver.
    (* abs heap *)
    - destruct (decEq a a0); subst; eauto with heaps.
      eapply not_dangling_later...
      destruct H. deprod.
      destruct (decEq x0 a); subst...
      apply oldenv.
      assert (iheap1 !! a = Some (sclos (xl, cl, ienv0))) by eauto with heaps.
      simplify_eq.
      unfold addr_in, addr_in_svalue, addr_in, addr_in_clos in H1.
      simpl.
      destruct H1; deprod.
      exists x0, v. repeat split_and...
      set_solver.
    (* branch env *)
    - apply oldenv.
      destruct H; deprod.
      exists x, v. repeat split_and...
      simpl. destruct b; set_solver.
    (* ret env *)
    - destruct H. deprod.
      unfold lookup in H.
      simpl in H.
      destruct (decEq x xl); simplify_eq.
      + apply oldenv.
        exists xr, v0. repeat split_and...
        simpl. set_solver.
      + apply oldstack.
        exists (xl, icode1, el).
        split...
        exists x, v0. repeat split_and...
        simpl. set_solver.
  Qed.

  Global Hint Resolve state_valid_start state_valid_step : steps.

  Example fresh_addr_in_env c e h k sv a h' :
    state_valid (<< c, e, h, k >>) ->
    alloc h sv = (a, h') ->
    forall x,
      free_in x c ->
      e !! x <> Some (vaddr a).
  Proof.
    intros.
    intro.
    addr_conflict h a.
  Qed.

  Definition state_space st
    :=
      match st with
      | << c, e, h, k >>%interp =>
        let roots := live_roots st in
        let addrs := closure _ h roots in
        1 + space_of svalue_size h addrs + size (free_vars c) + sum_list (map clos_size k)
      end.

  Import Steps.

  Global Instance sxmlStep :
    Step state :=
    Build_Step _ SXML.step.

  Global Instance sxmlSpace :
    Space state :=
    Build_Space _ state_space.

  Bind Scope exp_scope with exp.
  Delimit Scope exp_scope with exp.
  Notation "'VAL' x ':=' e 'IN' er" := (letsmall x e er) (at level 90, right associativity,
  format "'VAL'  x  ':='  e  'IN'  '//'  er"): exp_scope.
  Notation "'FN' f x ':=' e 'IN' er" := (letabs f x e er) (at level 90, right associativity,
  format "'FN' f  x  ':=' e 'IN' '//' er"): exp_scope.

  Theorem not_stuck_steps :
    forall s1 s2,
      not_stuck s1 ->
      @steps state sxmlStep s1 s2 ->
      not_stuck s2.
  Proof with eauto.
    intros.
    induction X0...
    eapply not_stuck_step.
    { apply IHX0... }
    unfold step in s. unfold sxmlStep in s.
    apply s.
  Qed.

  Theorem state_valid_steps :
    forall s1 s2,
      state_valid s1 ->
      @steps state sxmlStep s1 s2 ->
      state_valid s2.
  Proof with eauto.
    intros.
    induction X...
    eapply state_valid_step.
    { apply IHX... }
    unfold step in s. unfold sxmlStep in s.
    apply s.
  Qed.

  Global Hint Resolve not_stuck_steps state_valid_steps : steps.

End SXML.

(*

  Require Import Coq.Strings.String.
  Definition foo := "foo"%string.
  Definition bar := "bar"%string.

Example prog1 : exp string
  :=
    VAL foo := tupleExp [] IN
    VAL bar := projExp foo 1 IN
    (ret foo).
Print prog1.
*)


Require Import Category.Types.
Require Import Category.Setoids.
Require Import Category.Types_Setoids.
Require Import Category.RComonad.
Require Import Category.RComod.
Require Import Theory.Category.
Require Import Theory.Functor.
Require Import Theory.RelativeComonad.
Require Import Theory.PushforwardComodule.
Require Import Theory.Comodule.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＣＡＴＥＧＯＲＹ  ＯＦ  ＳＴＲＥＡＭＳ
  ----------------------------------------------------------------------------*)
(** * Category of streams **)

(** ** Object and morphism definitions **)
Module Stream.

  Structure Obj : Type := mkObj
  { T         :>  𝑹𝑪𝒐𝒎𝒐𝒏𝒂𝒅 𝑬𝑸
  ; tail      :> [T] ⇒ [T] }.

  Arguments mkObj     {_ } _.
  Arguments T         _.
  Arguments tail      _.

  Notation "'Stream.make' ⦃ 'T' ≔ T ; 'tail' ≔ tail ⦄" :=
           (@mkObj T tail) (only parsing).

  Structure Morphism (T S : Obj) : Type := mkMorphism
  { τ           :> T ⇒ S
  ; τ_commutes  : ⟨τ⟩ ∘ τ⁎⋅T ≈ S ∘ ⟨τ⟩ }.

  Arguments mkMorphism  {_ _ _} _.
  Arguments τ           {_ _} _.
  Arguments τ_commutes  {_ _} _ {_ _ _ _}.

  Notation "'Stream.make' ⦃ 'τ' ≔ τ ⦄" := (@mkMorphism _ _ τ _) (only parsing).

  Program Definition Hom (T S : Obj) : Setoid :=
    Setoid.make   ⦃ Carrier  ≔ Morphism T S
                  ; Equiv    ≔ (λ g f ∙ g ≈ f) ⦄.
  (** equivalence **)
  Next Obligation.
    constructor.
    - repeat intro. now rewrite H.
    - repeat intro. symmetry; now rewrite H.
    - repeat intro; etransitivity; eauto. now apply H0.
  Qed.

End Stream.

Export Stream.

(** ** Identity and compositon definitions **)

Section Defs.

  Implicit Types (T S R U : Obj).

  Infix "⇒" := Hom.

  Program Definition id {T} : T ⇒ T :=
    Stream.make ⦃ τ ≔ id[T] ⦄.
  (** τ-cong **)
  Next Obligation.
    now rewrite H.
  Qed.

  Obligation Tactic := idtac.
  Program Definition compose {T S R} : [ S ⇒ R ⟶ T ⇒ S ⟶ T ⇒ R ] :=
    λ g f ↦₂ Stream.make ⦃ τ ≔ g ∘ f ⦄.
  (** τ-commutes **)
  Next Obligation.
    intros T S R g f.
    destruct g as [g g_commutes]. simpl in g_commutes.
    destruct f as [f f_commutes]. simpl in f_commutes. simpl.
    intros.
    rewrite H.
    etransitivity.
    eapply Setoids.cong.
    apply f_commutes.
    reflexivity.
    apply g_commutes.
    reflexivity.
  Qed.
  (** τ-proper **)
  Next Obligation.
    repeat intro.
    simpl.
    etransitivity. eapply Setoids.cong.
    eapply Setoids.cong. apply H1.
    etransitivity. eapply Setoids.cong.
    apply H0. reflexivity.
    apply H.
    reflexivity.
  Qed.

  Infix "∘" := compose.

  Lemma left_id : ∀ T S (f : T ⇒ S), id ∘ f ≈ f.
  Proof.
    intros. simpl. intros. rewrite H.
    reflexivity.
  Qed.

  Lemma right_id : ∀ T S (f : T ⇒ S), f ∘ id ≈ f.
  Proof.
    repeat intro. simpl. now rewrite H.
  Qed.

  Lemma compose_assoc T R S U (f : T ⇒ R) (g : R ⇒ S) (h : S ⇒ U) : h ∘ g ∘ f ≈ h ∘ (g ∘ f).
  Proof.
    repeat intro.
    simpl. now rewrite H.
  Qed.

  Canonical Structure 𝑺𝒕𝒓𝒆𝒂𝒎 : Category :=
    mkCategory left_id right_id compose_assoc.

End Defs.


Require Import Clight.
Require Import Ctypes.
Require Import veric.expr.
Require Import floyd.efield_lemmas.
Require Import mc_reify.clight_expr_eq.
Require Import compcert.common.AST.
Require Import ExtLib.Core.RelDec.

Definition efield_beq a b :=
  match a, b with
  | eStructField x, eStructField y => eqb_ident x y
  | eUnionField x, eUnionField y => eqb_ident x y
  | eArraySubsc x, eArraySubsc y => expr_beq x y
  | _, _ => false
  end.

Lemma efield_beq_spec: forall a b, efield_beq a b = true <-> a = b.
Proof.
  intros.
  destruct a, b; split; intros; try solve [inversion H]; simpl in H.
  + apply expr_beq_spec in H.
    subst.
    reflexivity.
  + inversion H.
    subst.
    simpl.
    apply expr_beq_spec.
    reflexivity.
  + apply eqb_ident_spec in H.
    subst.
    reflexivity.
  + inversion H.
    subst.
    simpl.
    apply eqb_ident_spec.
    reflexivity.
  + apply eqb_ident_spec in H.
    subst.
    reflexivity.
  + inversion H.
    subst.
    simpl.
    apply eqb_ident_spec.
    reflexivity.
Qed.

Instance RelDec_efield_beq: RelDec (@eq efield) := { rel_dec := efield_beq }.

Instance RelDec_Correct_efield_beq : RelDec_Correct RelDec_efield_beq.
Proof.
  constructor.
  unfold rel_dec; simpl.
  exact efield_beq_spec.
Qed.

Instance RelDec_list_efield_beq: RelDec (@eq (list efield)) := List.RelDec_eq_list RelDec_efield_beq.
Instance RelDec_Correct_list_efield_beq: RelDec_Correct RelDec_list_efield_beq :=
  List.RelDec_Correct_eq_list RelDec_Correct_efield_beq.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_rfn_top_reduce.rhs_other_reduce.
Require Export common.lhs_rfn_top_reduce.rhs_rfn_top_reduce.
Require Export common.lhs_rfn_top_reduce.rhs_sel_equ_reduce.
Require Export common.lhs_rfn_top_reduce.rhs_sel_low_reduce.

Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_top_reduce :
  forall T1 Ts1, T1 = (t_rfn_top Ts1) ->
            forall T2, subtype T1 T2 = match T2 with
                                  | t_top => true
                                  | t_sel_low x L T => subtype T1 T
                                  | t_sel_equ x L T => subtype T1 T
                                  | t_rfn_top Ts2 => subtype Ts1 Ts2
                                  | _ => false
                                  end.
Proof.
  intros; subst; destruct T2;
    try solve [eapply subtype_rfn_top_other_reduce; crush].

  apply subtype_top; crush.

  eapply subtype_rfn_top_sel_low_reduce; crush.

  eapply subtype_rfn_top_sel_equ_reduce; crush.

  eapply subtype_rfn_top_rfn_top_reduce; crush.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Bifunctor.
Require Import Category.Structure.Monoidal.
Require Import Category.Instance.Fun.

Generalizable All Variables.

#[local] Obligation Tactic := intros; simplify; simpl in *; intros; normal.

(* This reflects the fact that categories are themselves "monoidoids", or
   monoidal with respect to identity and composition.  *)

Program Definition Compose_Monoidal {C : Category} :
  @Monoidal ([C, C]) := {|
  tensor :=
    {| fobj := fun p => fst p ◯ snd p
     ; fmap := fun F G N =>
         {| transform := fun x =>
              fst N (snd G x) ∘ fmap[fst F] (snd N x) |}
     |};
  I := Id
|}.
Next Obligation.
  rewrite <- naturality.
  rewrite <- comp_assoc.
  rewrite <- naturality.
  rewrite comp_assoc.
  rewrite <- fmap_comp.
  rewrite (naturality[snd N]).
  rewrite fmap_comp.
  comp_left.
  apply naturality.
Qed.
Next Obligation.
  rewrite naturality.
  rewrite <- !comp_assoc.
  comp_left.
  rewrite <- !fmap_comp.
  apply fmap_respects.
  apply naturality_sym.
Qed.
Next Obligation. proper; rewrites; reflexivity. Qed.
Next Obligation. rewrite !fmap_id; cat. Qed.
Next Obligation.
  rewrite <- !comp_assoc.
  apply compose_respects.
  - reflexivity.
  - rewrite <- !naturality.
    rewrite fmap_comp.
    rewrite comp_assoc.
    reflexivity.
Qed.
Next Obligation.
  isomorphism; simpl.
  - transform; simpl; cat.
  - transform; simpl; cat.
  - simpl; cat.
  - simpl; cat.
Defined.
Next Obligation.
  isomorphism; simpl.
  - transform; simpl; cat.
  - transform; simpl; cat.
  - simpl; cat.
  - simpl; cat.
Defined.
Next Obligation.
  isomorphism; simpl.
  - transform; simpl; cat.
  - transform; simpl; cat.
  - simpl; cat.
  - simpl; cat.
Defined.
Next Obligation. cat. Defined.
Next Obligation. cat. Defined.
Next Obligation. cat. Defined.
Next Obligation. cat. Defined.
Next Obligation.
  rewrite !fmap_id.
  normal.
  rewrite <- !comp_assoc.
  rewrite fmap_comp.
  reflexivity.
Qed.
Next Obligation.
  rewrite !fmap_id.
  normal.
  rewrite <- !comp_assoc.
  rewrite fmap_comp.
  reflexivity.
Qed.
Next Obligation.
  normal; reflexivity.
Qed.
Next Obligation.
  normal; rewrite !fmap_id; reflexivity.
Qed.


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

Require Import Coq.Bool.Bvector.
Require Import Coq.Vectors.Vector.
Require Import Cava.Util.Vector.

Section Spec.
  (* FIPS 197, 2.1: Word A group of 32 bits that is treated either as a single
     entity or as an array of 4 bytes. *)
  Variable bits_per_word : nat.
  Definition word := (Bvector bits_per_word).

  (* FIPS 197, 2.2: Number of columns (32-bit words) comprising the State.
     For this standard, Nb = 4. *)
  Variable nb : nat.

  Definition state := Vector.t word nb.
  Definition key := Vector.t word nb.

  (* FIPS 197, 5.1.4 AddRoundKey() Transformation *)
  Definition add_round_key (input : state) (k : key) : state :=
    map2 (BVxor _) input k.

  Section Properties.
    Lemma inverse_xorb (b1 : bool) (b2 : bool) : xorb (xorb b1 b2) b2 = b1.
    Proof.
      destruct b1, b2; reflexivity.
    Qed.

    Lemma inverse_bvxor n (a : Vector.t bool n) (b : Vector.t bool n) :
                        BVxor n (BVxor n a b) b = a.
    Proof.
      induction a.
      { eapply case0 with (v:=b). reflexivity. }
      { unfold BVxor.
        do 2 rewrite map2_cons.
        simpl.
        rewrite inverse_xorb.

        unfold BVxor in IHa.
        rewrite IHa.
        reflexivity. }
    Qed.

    Theorem inverse_add_round_key (x : state) (k : key) :
      add_round_key (add_round_key x k) k = x.
    Proof.
      unfold add_round_key.
      cbv [state key] in *.
      induction x; [ apply nil_eq | ].
      { autorewrite with push_vector_map vsimpl.
        rewrite IHx.
        rewrite inverse_bvxor.
        reflexivity. }
    Qed.
  End Properties.
End Spec.


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

(** Recognition of tail calls: correctness proof *)

Require Import Coqlib Maps Integers AST Linking.
Require Import Values Memory Events Globalenvs Smallstep.
Require Import Op Registers RTL Conventions Tailcall.

(** * Syntactic properties of the code transformation *)

(** ** Measuring the number of instructions eliminated *)

(** The [return_measure c pc] function counts the number of instructions
  eliminated by the code transformation, where [pc] is the successor
  of a call turned into a tailcall.  This is the length of the
  move/nop/return sequence recognized by the [is_return] boolean function.
*)

Fixpoint return_measure_rec (n: nat) (c: code) (pc: node)
                            {struct n}: nat :=
  match n with
  | O => O
  | S n' =>
      match c!pc with
      | Some(Inop s) => S(return_measure_rec n' c s)
      | Some(Iop op args dst s) => S(return_measure_rec n' c s)
      | _ => O
      end
  end.

Definition return_measure (c: code) (pc: node) :=
  return_measure_rec niter c pc.

Lemma return_measure_bounds:
  forall f pc, (return_measure f pc <= niter)%nat.
Proof.
  intro f.
  assert (forall n pc, (return_measure_rec n f pc <= n)%nat).
    induction n; intros; simpl.
    omega.
    destruct (f!pc); try omega.
    destruct i; try omega.
    generalize (IHn n0). omega.
    generalize (IHn n0). omega.
  intros. unfold return_measure. apply H.
Qed.

Remark return_measure_rec_incr:
  forall f n1 n2 pc,
  (n1 <= n2)%nat ->
  (return_measure_rec n1 f pc <= return_measure_rec n2 f pc)%nat.
Proof.
  induction n1; intros; simpl.
  omega.
  destruct n2. omegaContradiction. assert (n1 <= n2)%nat by omega.
  simpl. destruct f!pc; try omega. destruct i; try omega.
  generalize (IHn1 n2 n H0). omega.
  generalize (IHn1 n2 n H0). omega.
Qed.

Lemma is_return_measure_rec:
  forall f n n' pc r,
  is_return n f pc r = true -> (n <= n')%nat ->
  return_measure_rec n f.(fn_code) pc = return_measure_rec n' f.(fn_code) pc.
Proof.
  induction n; simpl; intros.
  congruence.
  destruct n'. omegaContradiction. simpl.
  destruct (fn_code f)!pc; try congruence.
  destruct i; try congruence.
  decEq. apply IHn with r. auto. omega.
  destruct (is_move_operation o l); try congruence.
  destruct (Reg.eq r r1); try congruence.
  decEq. apply IHn with r0. auto. omega.
Qed.

(** ** Relational characterization of the code transformation *)

(** The [is_return_spec] characterizes the instruction sequences
  recognized by the [is_return] boolean function.  *)

Inductive is_return_spec (f:function): node -> reg -> Prop :=
  | is_return_none: forall pc r,
      f.(fn_code)!pc = Some(Ireturn None) ->
      is_return_spec f pc r
  | is_return_some: forall pc r,
      f.(fn_code)!pc = Some(Ireturn (Some r)) ->
      is_return_spec f pc r
  | is_return_nop: forall pc r s,
      f.(fn_code)!pc = Some(Inop s) ->
      is_return_spec f s r ->
      (return_measure f.(fn_code) s < return_measure f.(fn_code) pc)%nat ->
      is_return_spec f pc r
  | is_return_move: forall pc r r' s,
      f.(fn_code)!pc = Some(Iop Omove (r::nil) r' s) ->
      is_return_spec f s r' ->
      (return_measure f.(fn_code) s < return_measure f.(fn_code) pc)%nat ->
     is_return_spec f pc r.

Lemma is_return_charact:
  forall f n pc rret,
  is_return n f pc rret = true -> (n <= niter)%nat ->
  is_return_spec f pc rret.
Proof.
  induction n; intros.
  simpl in H. congruence.
  generalize H. simpl.
  caseEq ((fn_code f)!pc); try congruence.
  intro i. caseEq i; try congruence.
  intros s; intros. eapply is_return_nop; eauto. eapply IHn; eauto. omega.
  unfold return_measure.
  rewrite <- (is_return_measure_rec f (S n) niter pc rret); auto.
  rewrite <- (is_return_measure_rec f n niter s rret); auto.
  simpl. rewrite H2. omega. omega.

  intros op args dst s EQ1 EQ2.
  caseEq (is_move_operation op args); try congruence.
  intros src IMO. destruct (Reg.eq rret src); try congruence.
  subst rret. intro.
  exploit is_move_operation_correct; eauto. intros [A B]. subst.
  eapply is_return_move; eauto. eapply IHn; eauto. omega.
  unfold return_measure.
  rewrite <- (is_return_measure_rec f (S n) niter pc src); auto.
  rewrite <- (is_return_measure_rec f n niter s dst); auto.
  simpl. rewrite EQ2. omega. omega.

  intros or EQ1 EQ2. destruct or; intros.
  assert (r = rret). eapply proj_sumbool_true; eauto. subst r.
  apply is_return_some; auto.
  apply is_return_none; auto.
Qed.

(** The [transf_instr_spec] predicate relates one instruction in the
  initial code with its possible transformations in the optimized code. *)

Inductive transf_instr_spec (f: function): instruction -> instruction -> Prop :=
  | transf_instr_tailcall: forall sig ros args res s,
      f.(fn_stacksize) = 0 ->
      is_return_spec f s res ->
      transf_instr_spec f (Icall sig ros args res s) (Itailcall sig ros args)
  | transf_instr_default: forall i,
      transf_instr_spec f i i.

Lemma transf_instr_charact:
  forall f pc instr,
  f.(fn_stacksize) = 0 ->
  transf_instr_spec f instr (transf_instr f pc instr).
Proof.
  intros. unfold transf_instr. destruct instr; try constructor.
  caseEq (is_return niter f n r && tailcall_is_possible s &&
          opt_typ_eq (sig_res s) (sig_res (fn_sig f))); intros.
  destruct (andb_prop _ _ H0). destruct (andb_prop _ _ H1).
  eapply transf_instr_tailcall; eauto.
  eapply is_return_charact; eauto.
  constructor.
Qed.

Lemma transf_instr_lookup:
  forall f pc i,
  f.(fn_code)!pc = Some i ->
  exists i',  (transf_function f).(fn_code)!pc = Some i' /\ transf_instr_spec f i i'.
Proof.
  intros. unfold transf_function.
  destruct (zeq (fn_stacksize f) 0).
  simpl. rewrite PTree.gmap. rewrite H. simpl.
  exists (transf_instr f pc i); split. auto. apply transf_instr_charact; auto.
  exists i; split. auto. constructor.
Qed.

(** * Semantic properties of the code transformation *)

(** ** The ``less defined than'' relation between register states *)

(** A call followed by a return without an argument can be turned
  into a tail call.  In this case, the original function returns
  [Vundef], while the transformed function can return any value.
  We account for this situation by using the ``less defined than''
  relation between values and between memory states.  We need to
  extend it pointwise to register states. *)

Lemma regs_lessdef_init_regs:
  forall params vl vl',
  Val.lessdef_list vl vl' ->
  regs_lessdef (init_regs vl params) (init_regs vl' params).
Proof.
  induction params; intros.
  simpl. red; intros. rewrite Regmap.gi. constructor.
  simpl. inv H.   red; intros. rewrite Regmap.gi. constructor.
  apply set_reg_lessdef. auto. auto.
Qed.

(** * Proof of semantic preservation *)

Definition match_prog (p tp: RTL.program) :=
  match_program (fun cu f tf => tf = transf_fundef f) eq p tp.

Lemma transf_program_match:
  forall p, match_prog p (transf_program p).
Proof.
  intros. apply match_transform_program; auto.
Qed.

Section PRESERVATION.
Context `{external_calls_prf: ExternalCalls}.

Variable prog tprog: program.
Hypothesis TRANSL: match_prog prog tprog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma symbols_preserved:
  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof (Genv.find_symbol_transf TRANSL).

Lemma functions_translated:
  forall (v: val) (f: RTL.fundef),
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef f).
Proof (Genv.find_funct_transf TRANSL).

Lemma funct_ptr_translated:
  forall (b: block) (f: RTL.fundef),
  Genv.find_funct_ptr ge b = Some f ->
  Genv.find_funct_ptr tge b = Some (transf_fundef f).
Proof (Genv.find_funct_ptr_transf TRANSL).

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_transf TRANSL).

Lemma genv_next_preserved:
  Genv.genv_next tge = Genv.genv_next ge.
Proof.
  apply senv_preserved.
Qed.

Lemma sig_preserved:
  forall f, funsig (transf_fundef f) = funsig f.
Proof.
  destruct f; auto. simpl. unfold transf_function.
  destruct (zeq (fn_stacksize f) 0); auto.
Qed.

Lemma stacksize_preserved:
  forall f, fn_stacksize (transf_function f) = fn_stacksize f.
Proof.
  unfold transf_function. intros.
  destruct (zeq (fn_stacksize f) 0); auto.
Qed.

Lemma find_function_translated:
  forall ros rs rs' f,
  find_function ge ros rs = Some f ->
  regs_lessdef rs rs' ->
  find_function tge ros rs' = Some (transf_fundef f).
Proof.
  intros until f; destruct ros; simpl.
  intros.
  assert (rs'#r = rs#r).
    exploit Genv.find_funct_inv; eauto. intros [b EQ].
    generalize (H0 r). rewrite EQ. intro LD. inv LD. auto.
  rewrite H1. apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i); intros.
  apply funct_ptr_translated; auto.
  discriminate.
Qed.

(** Consider an execution of a call/move/nop/return sequence in the
  original code and the corresponding tailcall in the transformed code.
  The transition sequences are of the following form
  (left: original code, right: transformed code).
  [f] is the calling function and [fd] the called function.
<<
     State stk f (Icall instruction)       State stk' f' (Itailcall)

     Callstate (frame::stk) fd args        Callstate stk' fd' args'
            .                                       .
            .                                       .
            .                                       .
     Returnstate (frame::stk) res          Returnstate stk' res'

     State stk f (move/nop/return seq)
            .
            .
            .
     State stk f (return instr)

     Returnstate stk res
>>
The simulation invariant must therefore account for two kinds of
mismatches between the transition sequences:
- The call stack of the original program can contain more frames
  than that of the transformed program (e.g. [frame] in the example above).
- The regular states corresponding to executing the move/nop/return
  sequence must all correspond to the single [Returnstate stk' res']
  state of the transformed program.

We first define the simulation invariant between call stacks.
The first two cases are standard, but the third case corresponds
to a frame that was eliminated by the transformation. *)

Inductive match_stackframes: list stackframe -> list stackframe -> Prop :=
  | match_stackframes_nil:
      match_stackframes nil nil
  | match_stackframes_normal: forall stk stk' res sp pc rs rs' f,
      match_stackframes stk stk' ->
      regs_lessdef rs rs' ->
      match_stackframes
        (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: stk)
        (Stackframe res (transf_function f) (Vptr sp Ptrofs.zero) pc rs' :: stk')
  | match_stackframes_tail: forall stk stk' res sp pc rs f,
      match_stackframes stk stk' ->
      is_return_spec f pc res ->
      f.(fn_stacksize) = 0 ->
      match_stackframes
        (Stackframe res f (Vptr sp Ptrofs.zero) pc rs :: stk)
        stk'.

(** Here is the invariant relating two states.  The first three
  cases are standard.  Note the ``less defined than'' conditions
  over values and register states, and the corresponding ``extends''
  relation over memory states. *)

Inductive match_states: state -> state -> Prop :=
  | match_states_normal:
      forall s sp pc rs m s' rs' m' f
             (STACKS: match_stackframes s s')
             (RLD: regs_lessdef rs rs')
             (MLD: Mem.extends m m'),
      match_states (State s f (Vptr sp Ptrofs.zero) pc rs m)
                   (State s' (transf_function f) (Vptr sp Ptrofs.zero) pc rs' m')
  | match_states_call:
      forall s f args m s' args' m',
      match_stackframes s s' ->
      Val.lessdef_list args args' ->
      Mem.extends m m' ->
      match_states (Callstate s f args m)
                   (Callstate s' (transf_fundef f) args' m')
  | match_states_return:
      forall s v m s' v' m',
      match_stackframes s s' ->
      Val.lessdef v v' ->
      Mem.extends m m' ->
      match_states (Returnstate s v m)
                   (Returnstate s' v' m')
  | match_states_interm:
      forall s sp pc rs m s' m' f r v'
             (STACKS: match_stackframes s s')
             (MLD: Mem.extends m m'),
      is_return_spec f pc r ->
      f.(fn_stacksize) = 0 ->
      Val.lessdef (rs#r) v' ->
      match_states (State s f (Vptr sp Ptrofs.zero) pc rs m)
                   (Returnstate s' v' m').

(** The last case of [match_states] corresponds to the execution
  of a move/nop/return sequence in the original code that was
  eliminated by the transformation:
<<
     State stk f (move/nop/return seq)  ~~  Returnstate stk' res'
            .
            .
            .
     State stk f (return instr)         ~~  Returnstate stk' res'
>>
  To preserve non-terminating behaviors, we need to make sure
  that the execution of this sequence in the original code cannot
  diverge.  For this, we introduce the following complicated
  measure over states, which will decrease strictly whenever
  the original code makes a transition but the transformed code
  does not. *)

Definition measure (st: state) : nat :=
  match st with
  | State s f sp pc rs m => (List.length s * (niter + 2) + return_measure f.(fn_code) pc + 1)%nat
  | Callstate s f args m => 0%nat
  | Returnstate s v m => (List.length s * (niter + 2))%nat
  end.

Ltac TransfInstr :=
  match goal with
  | H: (PTree.get _ (fn_code _) = _) |- _ =>
      destruct (transf_instr_lookup _ _ _ H) as [i' [TINSTR TSPEC]]; inv TSPEC
  end.

Ltac EliminatedInstr :=
  match goal with
  | H: (is_return_spec _ _ _) |- _ => inv H; try congruence
  | _ => idtac
  end.

(** The proof of semantic preservation, then, is a simulation diagram
  of the ``option'' kind. *)

Lemma transf_step_correct:
  forall s1 t s2, step ge s1 t s2 ->
  forall s1' (MS: match_states s1 s1'),
  (exists s2', step tge s1' t s2' /\ match_states s2 s2')
  \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.
Proof.
  induction 1; intros; inv MS; EliminatedInstr.

- (* nop *)
  TransfInstr. left. econstructor; split.
  eapply exec_Inop; eauto. constructor; auto.
- (* eliminated nop *)
  assert (s0 = pc') by congruence. subst s0.
  right. split. simpl. omega. split. auto.
  econstructor; eauto.

- (* op *)
  TransfInstr.
  assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto.
  exploit eval_operation_lessdef; eauto.
  intros [v' [EVAL' VLD]].
  left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#res <- v') m'); split.
  eapply exec_Iop; eauto.  rewrite <- EVAL'.
  apply eval_operation_preserved. exact symbols_preserved.
  econstructor; eauto. apply set_reg_lessdef; auto.
- (* eliminated move *)
  rewrite H1 in H. clear H1. inv H.
  right. split. simpl. omega. split. auto.
  econstructor; eauto. simpl in H0. rewrite PMap.gss. congruence.

- (* load *)
  TransfInstr.
  assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto.
  exploit eval_addressing_lessdef; eauto.
  intros [a' [ADDR' ALD]].
  exploit Mem.loadv_extends; eauto.
  intros [v' [LOAD' VLD]].
  left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- v') m'); split.
  eapply exec_Iload with (a0 := a'). eauto.  rewrite <- ADDR'.
  apply eval_addressing_preserved. exact symbols_preserved. eauto.
  econstructor; eauto. apply set_reg_lessdef; auto.

- (* store *)
  TransfInstr.
  assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto.
  exploit eval_addressing_lessdef; eauto.
  intros [a' [ADDR' ALD]].
  exploit Mem.storev_extends. 2: eexact H1. eauto. eauto. apply RLD.
  intros [m'1 [STORE' MLD']].
  left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' m'1); split.
  eapply exec_Istore with (a0 := a'). eauto.  rewrite <- ADDR'.
  apply eval_addressing_preserved. exact symbols_preserved. eauto.
  destruct a; simpl in H1; try discriminate.
  econstructor; eauto.

- (* call *)
  exploit find_function_translated; eauto. intro FIND'.
  TransfInstr.
+ (* call turned tailcall *)
  assert ({ m'' | Mem.free m' sp0 0 (fn_stacksize (transf_function f)) = Some m''}).
    apply Mem.range_perm_free. rewrite stacksize_preserved. rewrite H7.
    red; intros; omegaContradiction.
  destruct X as [m'' FREE].
  left. exists (Callstate s' (transf_fundef fd) (rs'##args) m''); split.
  eapply exec_Itailcall; eauto. apply sig_preserved.
  constructor. eapply match_stackframes_tail; eauto. apply regs_lessdef_regs; auto.
  eapply Mem.free_right_extends; eauto.
  rewrite stacksize_preserved. rewrite H7. intros. omegaContradiction.
+ (* call that remains a call *)
  left. exists (Callstate (Stackframe res (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' :: s')
                          (transf_fundef fd) (rs'##args) m'); split.
  eapply exec_Icall; eauto. apply sig_preserved.
  constructor. constructor; auto. apply regs_lessdef_regs; auto. auto.

- (* tailcall *)
  exploit find_function_translated; eauto. intro FIND'.
  exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]].
  TransfInstr.
  left. exists (Callstate s' (transf_fundef fd) (rs'##args) m'1); split.
  eapply exec_Itailcall; eauto. apply sig_preserved.
  rewrite stacksize_preserved; auto.
  constructor. auto.  apply regs_lessdef_regs; auto. auto.

- (* builtin *)
  TransfInstr.
  exploit (eval_builtin_args_lessdef (ge := ge) (e1 := fun r => rs#r) (fun r => rs'#r)); eauto.
  intros (vargs' & P & Q).
  exploit external_call_mem_extends; eauto.
  intros [v' [m'1 [A [B [C D]]]]].
  left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res v' rs') m'1); split.
  eapply exec_Ibuiltin; eauto.
  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
  econstructor; eauto. apply set_res_lessdef; auto.

- (* cond *)
  TransfInstr.
  left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) (if b then ifso else ifnot) rs' m'); split.
  eapply exec_Icond; eauto.
  apply eval_condition_lessdef with (rs##args) m; auto. apply regs_lessdef_regs; auto.
  constructor; auto.

- (* jumptable *)
  TransfInstr.
  left. exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' rs' m'); split.
  eapply exec_Ijumptable; eauto.
  generalize (RLD arg). rewrite H0. intro. inv H2. auto.
  constructor; auto.

- (* return *)
  exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]].
  TransfInstr.
  left. exists (Returnstate s' (regmap_optget or Vundef rs') m'1); split.
  apply exec_Ireturn; auto. rewrite stacksize_preserved; auto.
  constructor. auto.
  destruct or; simpl. apply RLD. constructor.
  auto.

- (* eliminated return None *)
  assert (or = None) by congruence. subst or.
  right. split. simpl. omega. split. auto.
  constructor. auto.
  simpl. constructor.
  eapply Mem.free_left_extends; eauto.

- (* eliminated return Some *)
  assert (or = Some r) by congruence. subst or.
  right. split. simpl. omega. split. auto.
  constructor. auto.
  simpl. auto.
  eapply Mem.free_left_extends; eauto.

- (* internal call *)
  exploit Mem.alloc_extends; eauto.
    instantiate (1 := 0). omega.
    instantiate (1 := fn_stacksize f). omega.
  intros [m'1 [ALLOC EXT]].
  assert (fn_stacksize (transf_function f) = fn_stacksize f /\
          fn_entrypoint (transf_function f) = fn_entrypoint f /\
          fn_params (transf_function f) = fn_params f).
    unfold transf_function. destruct (zeq (fn_stacksize f) 0); auto.
  destruct H0 as [EQ1 [EQ2 EQ3]].
  left. econstructor; split.
  simpl. eapply exec_function_internal; eauto. rewrite EQ1; eauto.
  rewrite EQ2. rewrite EQ3. constructor; auto.
  apply regs_lessdef_init_regs. auto.

- (* external call *)
  exploit external_call_mem_extends; eauto.
  intros [res' [m2' [A [B [C D]]]]].
  left. exists (Returnstate s' res' m2'); split.
  simpl. econstructor; eauto.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
  constructor; auto.

- (* returnstate *)
  inv H2.
+ (* synchronous return in both programs *)
  left. econstructor; split.
  apply exec_return.
  constructor; auto. apply set_reg_lessdef; auto.
+ (* return instr in source program, eliminated because of tailcall *)
  right. split. unfold measure. simpl length.
  change (S (length s) * (niter + 2))%nat
   with ((niter + 2) + (length s) * (niter + 2))%nat.
  generalize (return_measure_bounds (fn_code f) pc). omega.
  split. auto.
  econstructor; eauto.
  rewrite Regmap.gss. auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inv H.
  exploit funct_ptr_translated; eauto. intro FIND.
  exists (Callstate nil (transf_fundef f) nil m0); split.
  econstructor; eauto. apply (Genv.init_mem_transf TRANSL). auto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  symmetry; eapply match_program_main; eauto.
  rewrite <- H3. apply sig_preserved.
  constructor. constructor. constructor. apply Mem.extends_refl.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv H5. inv H3. constructor.
Qed.

(** The preservation of the observable behavior of the program then
  follows. *)

Theorem transf_program_correct:
  forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
  eapply forward_simulation_opt with (measure := measure); eauto.
  apply senv_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  exact transf_step_correct.
Qed.

End PRESERVATION.


Require Export Iron.Language.SystemF2Cap.Step.Frame.
Require Export Iron.Language.SystemF2Cap.Store.Bind.

(* All region identifiers for private regions defined in the frame
   stack are in the store properties.

   We don't require the other way, forcing all store properties to be in
   the frame stack. This is because we need to be able to pop a Priv frame
   and still have any region handles in the expression being well typed,
   along with dangling references into that region. *)
Definition StoreP  (sp : stprops) (fs : stack)
 := (forall m1 p2 ts, In (FPriv  m1       p2 ts) fs -> In (SRegion p2) sp)
 /\ (forall p1 p2 ts, In (FPriv (Some p1) p2 ts) fs -> In (SRegion p1) sp).

(* Weaken frame stack in store properties. *)
Lemma storeP_snoc
 :  forall sp fs p ts
 ,  StoreP sp fs
 -> StoreP (SRegion p <: sp) (fs :> FPriv None p ts).
Proof.
 unfold StoreP in *. rip.
 - inverts H0. inverts H.
   + eauto.
   + have HN: (p = p2 \/ ~(p = p2)).
     inverts HN; eauto.
 - inverts H0; nope; eauto.
Qed.
Hint Resolve storeP_snoc.

Lemma storeP_stprops_snoc
 :  forall sp fs p
 ,  StoreP sp fs
 -> StoreP (p <: sp) fs.
Proof.
 unfold StoreP in *. rip; eauto.
Qed.
Hint Resolve storeP_stprops_snoc.

Lemma storeP_pop
 :  forall sp fs f
 ,  StoreP sp (fs :> f)
 -> StoreP sp fs.
Proof.
 intros.
 unfold StoreP in *.
 firstorder.
Qed.
Hint Resolve storeP_pop.