Require Import Coq.Logic.Classical_Prop.

Require Import SpecCert.Equality.
Require Import SpecCert.Map.
Require Import SpecCert.Address.
Require Import SpecCert.Cache.
Require Import SpecCert.Interval.
Require Import SpecCert.Memory.
Require Import SpecCert.Smm.Delta.Invariant.
Require Import SpecCert.Smm.Software.
Require Import SpecCert.x86.

Lemma pa1_not_in_interval_pa2_in_interval_pa1_neq_pa2
      (pa pa': PhysicalAddress)
      (i:      Interval)
      (not_in: ~ address_offset pa ∈ i)
      (is_in:  address_offset pa' ∈ i)
  : ~ eq pa pa'.
  simpl.
  unfold addr_eq.
  intros [Heq Heq'].
  assert (address_offset pa <> address_offset pa').
  + apply (x1_not_in_interval_x2_in_interval_x1_neq_x2 (address_offset pa) (address_offset pa') i not_in is_in).
  + apply H in Heq.
    exact Heq.
Qed.

Lemma neq_dram_vga_cast
      (pa pa': PhysicalAddress)
  : ~ eq (dram pa) (vga pa').
Proof.
  unfold not.
  simpl.
  unfold addr_eq.
  unfold vga, dram.
  induction pa; induction pa'.
  simpl.
  intros [_H H].
  apply eq_equal in H.
  discriminate H.
Qed.

Lemma hardware_dram_cast
      (pa pa': PhysicalAddress)
      : eq (dram pa) (dram pa') <-> eq pa pa'.
Proof.
  split.
  + intro Heq.
    induction pa; induction pa'; unfold dram in *; unfold addr_eq in *;
      unfold address_offset in *; unfold address_scope in *.
    destruct Heq as [Heq Heq'].
    split.
    * exact Heq.
    * simpl.
      apply mm_singleton.
  + intro Heq.
    induction pa; induction pa'; unfold dram in *; unfold addr_eq in *;
      unfold address_offset in *; unfold address_scope in *.
    destruct Heq as [Heq Heq'].
    split.
    * exact Heq.
    * apply eq_refl.
Qed.

Lemma update_memory_content_with_cache_content_preserves_smram_code_inv
      (a a': Architecture Software)
      (pa:   PhysicalAddress)
  : let cont := find_in_cache_location (cache a) pa
    in inv a
       -> a' = update_memory_content a
                                     (phys_to_hard a (cache_location_address (cache a) pa))
                                     cont
       -> smram_code_inv a'.
Proof.
  simpl.
  remember (cache_location_address (cache a) pa) as pa'.
  remember (find_in_cache_location (cache a) pa) as c'.
  remember (phys_to_hard a pa') as ha.
  intros [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Heqa'.
  destruct (is_inside_smram_dec pa') as [Hinside|Houtside].
  + rewrite (cache_location_cache_location (cache a) pa pa') in Heqc'; [
    | apply x86_cache_is_well_formed
    | trivial
    ].
    symmetry in Heqc'.
    apply find_in_cache_cache_location in Heqc'; [
      | apply x86_cache_is_well_formed ].
    assert (cache_hit (cache a) pa') as Hhit.
    rewrite Heqpa';
      apply cache_hit_cache_location_address;
      apply x86_cache_is_well_formed.
    rewrite <- cache_hit_cache_location_cache_find in Heqc'; [
      | trivial
      ].
    unfold cache_clean_inv in *.
    unfold find_cache_content in Hclean.
    induction c' as [v s].
    assert (s = smm).
    apply (Hclean pa' v s Hinside Hhit Heqc').
    unfold smram_code_inv.
    intros addr val s' Hinside' Hfind.
    rewrite H in Heqa'.
    destruct (eq_dec ha (dram addr)) as [Heq|Hneq].
    * apply eq_equal in Heq.
      rewrite Heqa' in Hfind.
      rewrite Heq in Hfind.
      rewrite update_ha_in_memory_is_ha in Hfind.
      inversion Hfind.
      reflexivity.
    * rewrite Heqa' in Hfind.
      unfold find_memory_content, find_in_memory, update_memory_content, update_in_memory in Hfind.
      simpl in Hfind.
      rewrite <- add_2 in Hfind; [| exact Hneq].
      unfold smram_code_inv in Hsmram.
      apply (Hsmram addr val s' Hinside' Hfind).
  + unfold smram_code_inv.
    intros addr val s Haddr.
    unfold phys_to_hard, translate_physical_address in Heqha.
    destruct (is_inside_smram_dec pa') as [_H|_H']; [ intuition |].
    rewrite Heqha in *.
    rewrite Heqa'.
    assert (~ eq (dram pa') (dram addr)) as Hneqdram.
    * unfold not; intro Hfalse.
      assert (~ eq pa' addr).
      unfold is_inside_smram in *.
      apply hardware_dram_cast in Hfalse.
      apply (pa1_not_in_interval_pa2_in_interval_pa1_neq_pa2 pa' addr smram_space Houtside Haddr).
      apply hardware_dram_cast in Hfalse.
      apply H in Hfalse.
      exact Hfalse.
    * rewrite <- update_ha_in_memory_changes_only_ha.
      apply Hsmram; trivial.
      trivial.
Qed.

Lemma update_memory_content_with_cache_content_preserves_cache_clean_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a
                                         (phys_to_hard a (cache_location_address (cache a) pa))
                                         (find_in_cache_location (cache a) pa))
  : cache_clean_inv a'.
Proof.
  remember (cache_location_address (cache a) pa) as pa'.
  remember (find_in_cache_location (cache a) pa) as c'.
  remember (phys_to_hard a pa') as ha'.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  unfold cache_clean_inv.
  unfold find_cache_content.
  apply update_memory_changes_only_memory in Heqa'.
  destruct Heqa' as [Hmc [Hproc Hcache]].
  rewrite <- Hcache.
  apply Hclean.
Qed.

Lemma update_memory_content_with_cache_content_preserves_smrr_inv:
  forall a a' :Architecture Software,
  forall pa   :PhysicalAddress,
    inv a
    -> a' = update_memory_content a
                                 (phys_to_hard a (cache_location_address (cache a) pa))
                                 (find_in_cache_location (cache a) pa)
    -> smrr_inv a'.
Proof.
  intros a a' pa.
  remember (cache_location_address (cache a) pa) as pa'.
  remember (find_in_cache_location (cache a) pa) as c'.
  remember (phys_to_hard a pa') as ha'.
  intros [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Heqa'.
  unfold smrr_inv.
  apply update_memory_changes_only_memory in Heqa'.
  destruct Heqa' as [Hmc [Hproc Hcache]].
  rewrite <- Hproc.
  apply Hsmrr.
Qed.

Lemma update_memory_content_with_cache_content_preserves_smramc_inv:
  forall a a' :Architecture Software,
  forall pa   :PhysicalAddress,
    inv a
    -> a' = update_memory_content a
                                 (phys_to_hard a (cache_location_address (cache a) pa))
                                 (find_in_cache_location (cache a) pa)
    -> smramc_inv a'.
Proof.
  intros a a' pa.
  remember (cache_location_address (cache a) pa) as pa'.
  remember (find_in_cache_location (cache a) pa) as c'.
  remember (phys_to_hard a pa') as ha'.
  intros [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Heqa'.
  unfold smramc_inv.
  apply update_memory_changes_only_memory in Heqa'.
  destruct Heqa' as [Hmc [Hproc Hcache]].
  rewrite <- Hmc.
  apply Hsmramc.
Qed.

Lemma context_is_preserves:
  forall h h': Architecture Software,
    proc h = proc h'
    -> smm_context h = smm_context h'.
Proof.
  intros h h' Heqp.
  unfold smm_context.
  rewrite Heqp.
  reflexivity.
Qed.

Lemma update_memory_content_with_cache_content_preserves_ip_inv:
  forall a a' :Architecture Software,
  forall pa   :PhysicalAddress,
    inv a
    -> a' = update_memory_content a
                                 (phys_to_hard a (cache_location_address (cache a) pa))
                                 (find_in_cache_location (cache a) pa)
    -> ip_inv a'.
Proof.
  intros a a' pa.
  remember (cache_location_address (cache a) pa) as pa'.
  remember (find_in_cache_location (cache a) pa) as c'.
  remember (phys_to_hard a pa') as ha'.
  intros [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Heqa'.
  apply update_memory_changes_only_memory in Heqa'.
  destruct Heqa' as [Hmc [Hproc Hcache]].
  unfold ip_inv in *.
  rewrite <- Hproc.
  rewrite <- (context_is_preserves a a' Hproc).
  apply Hip.
Qed.

Lemma update_memory_content_with_cache_content_preserves_smbase_inv:
  forall a a' :Architecture Software,
  forall pa   :PhysicalAddress,
    inv a
    -> a' = update_memory_content a
                                 (phys_to_hard a (cache_location_address (cache a) pa))
                                 (find_in_cache_location (cache a) pa)
    -> smbase_inv a'.
Proof.
  intros a a' pa.
  remember (cache_location_address (cache a) pa) as pa'.
  remember (find_in_cache_location (cache a) pa) as c'.
  remember (phys_to_hard a pa') as ha'.
  intros [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]] Heqa'.
  apply update_memory_changes_only_memory in Heqa'.
  destruct Heqa' as [Hmc [Hproc Hcache]].
  unfold smbase_inv in *.
  rewrite <- Hproc.
  apply Hsmbase.
Qed.

Lemma update_memory_content_with_cache_content_preserves_inv:
  forall a a' :Architecture Software,
  forall pa   :PhysicalAddress,
    inv a
    -> a' = update_memory_content a
                                 (phys_to_hard a (cache_location_address (cache a) pa))
                                 (find_in_cache_location (cache a) pa)
    -> inv a'.
Proof.
  intros a a' pa.
  intros Hinv Heqa'.
  unfold inv.
  split; [| split; [| split; [| split; [| split]]]]; [
      eapply (update_memory_content_with_cache_content_preserves_smramc_inv a a' pa)
    | eapply (update_memory_content_with_cache_content_preserves_smram_code_inv a a' pa)
    | eapply (update_memory_content_with_cache_content_preserves_smrr_inv a a' pa)
    | eapply (update_memory_content_with_cache_content_preserves_cache_clean_inv a a' pa)
    | eapply (update_memory_content_with_cache_content_preserves_ip_inv a a' pa)
    | eapply (update_memory_content_with_cache_content_preserves_smbase_inv a a' pa) ]; trivial.
Qed.

Lemma update_memory_content_with_context_preserves_smram_code_inv
      (a a':   Architecture Software)
      (pa:     PhysicalAddress)
      (val:    Value)
      (Hinv:   inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
    : smram_code_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hclean [Hsmrr [Hip Hsmbase]]]]].
  unfold smram_code_inv.
  intros pa' val' s Hinside' Hfind.
  unfold update_memory_content in Heqa'.
  unfold update_in_memory in Heqa'.
  unfold find_memory_content, find_in_memory.
  rewrite Heqa' in Hfind.
  unfold find_memory_content, find_in_memory in Hfind.
  simpl in Hfind.
  unfold phys_to_hard, translate_physical_address in Hfind.
  destruct is_inside_smram_dec as [Hinside|Houtside].
  + destruct can_access_smram_dec as [Hcan|Hcannot].
    * assert (smm_context a = smm) as Hcontext.
      - unfold can_access_smram in Hcan.
        destruct Hcan as [Hsmm|Hfalse].
        unfold smm_context.
        destruct is_in_smm_dec as [Hin|Hnotin]; try reflexivity.
        unfold is_in_smm in Hnotin.
        apply Hnotin in Hsmm.
        destruct Hsmm.
        unfold smramc_inv in Hsmramc.
        unfold smramc_is_locked in Hsmramc.
        unfold smramc_is_ro in Hsmramc.
        apply (lock_is_close (smramc (memory_controller a))) in Hsmramc.
        rewrite Hsmramc in Hfalse.
        discriminate.
      - rewrite Hcontext in Hfind.
        destruct (eq_dec pa pa').
        apply eq_equal in e.
        rewrite e in Hfind.
        rewrite add_1 in Hfind.
        inversion Hfind.
        reflexivity.
        rewrite <- add_2 in Hfind.
        unfold smram_code_inv in Hsmram.
        apply (Hsmram pa' val' s Hinside' Hfind).
        intro Hfalse.
        apply hardware_dram_cast in Hfalse.
        apply n in Hfalse.
        exact Hfalse.
    * rewrite <- add_2 in Hfind.
      apply (Hsmram pa' val' s Hinside' Hfind).
      intro H.
      apply eq_sym in H.
      assert (~ eq (dram pa') (vga pa)).
      apply (neq_dram_vga_cast pa' pa).
      apply H0 in H.
      exact H.
  + assert (~ eq pa pa') as Hneqpapa'.
    apply (pa1_not_in_interval_pa2_in_interval_pa1_neq_pa2 pa pa' smram_space Houtside Hinside').
    rewrite <- (add_2 (memory a) (dram pa) (dram pa')) in Hfind.
    * apply (Hsmram pa' val' s Hinside' Hfind).
    * intro Hfalse.
      apply hardware_dram_cast in Hfalse.
      apply Hneqpapa' in Hfalse.
      exact Hfalse.
Qed.

Lemma update_memory_content_with_context_preserves_smramc_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (val:   Value)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
  : smramc_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_memory_changes_only_memory in Heqa' as [Hmc [Hproc Hother]].
  unfold smramc_inv.
  rewrite <- Hmc.
  exact Hsmramc.
Qed.

Lemma update_memory_content_with_context_preserves_smbase_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (val:   Value)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
  : smbase_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_memory_changes_only_memory in Heqa' as [Hmc [Hproc Hother]].
  unfold smbase_inv.
  rewrite <- Hproc.
  exact Hsmbase.
Qed.

Lemma update_memory_content_with_context_preserves_cache_clean_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (val:   Value)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
  : cache_clean_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean Hip]]]].
  apply update_memory_changes_only_memory in Heqa' as [Hmc [Hproc Hother]].
  unfold cache_clean_inv.
  unfold find_cache_content.
  rewrite <- Hother.
  exact Hclean.
Qed.

Lemma update_memory_content_with_context_preserves_smrr_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (val:   Value)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
  : smrr_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean Hip]]]].
  apply update_memory_changes_only_memory in Heqa' as [Hmc [Hproc Hother]].
  unfold smrr_inv.
  rewrite <- Hproc.
  exact Hsmrr.
Qed.

Lemma update_memory_content_with_context_preserves_ip_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (val:   Value)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
  : ip_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_memory_changes_only_memory in Heqa' as [Hmc [Hproc Hother]].
  unfold ip_inv.
  rewrite <- Hproc.
  rewrite <- (context_is_preserves a a' Hproc).
  exact Hip.
Qed.

Lemma update_memory_content_with_context_preserves_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (val:   Value)
      (Hinv:  inv a)
      (Heqa': a' = update_memory_content a (phys_to_hard a pa) (val, smm_context a))
  : inv a'.
Proof.
  unfold inv.
  split; [| split; [| split; [| split; [| split]]]]; [
      eapply (update_memory_content_with_context_preserves_smramc_inv a a' pa val)
    | eapply (update_memory_content_with_context_preserves_smram_code_inv a a' pa val)
    | eapply (update_memory_content_with_context_preserves_smrr_inv a a' pa val)
    | eapply (update_memory_content_with_context_preserves_cache_clean_inv a a' pa val)
    | eapply (update_memory_content_with_context_preserves_ip_inv a a' pa val)
    | eapply (update_memory_content_with_context_preserves_smbase_inv a a' pa val) ]; trivial.
Qed.

Lemma load_in_cache_from_memory_preserves_smram_code_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (Hinv:    inv a)
      (Heqa':   a' = load_in_cache_from_memory a pa)
  : smram_code_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  assert (inv a) as Hinv.
  split; [ exact Hsmramc
         | split; [ exact Hsmram
                  | split ; [ exact Hsmrr
                            | split ; [ exact Hclean
                                      | split; [ exact Hip
                                               | exact Hsmbase ]]]]].
  unfold load_in_cache_from_memory in Heqa'.
  destruct (cache_location_is_dirty_dec (cache a) pa) as [Hdirty|Hndirty].
  + remember (update_memory_content a
                                    (phys_to_hard a (cache_location_address (cache a) pa))
                                    (find_in_cache_location (cache a) pa)) as ax.
    assert (inv ax).
    apply (update_memory_content_with_cache_content_preserves_inv a ax pa); trivial.
    apply update_cache_changes_only_cache in Heqa'.
    destruct Heqa' as [Hproc' [Hmc' Hmem']].
    unfold smram_code_inv, find_memory_content.
    rewrite <- Hmem'.
    destruct H as [Hsmramcx [Hsmramx Hrest]].
    exact Hsmramx.
  + apply update_cache_changes_only_cache in Heqa'.
    destruct Heqa' as [Hproc' [Hmc' Hmem']].
    unfold smram_code_inv, find_memory_content.
    rewrite <- Hmem'.
    exact Hsmram.
Qed.

Lemma update_cache_with_memory_cache_clean_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (Hinv:  inv a)
      (Hin_smm: (is_inside_smram pa -> is_in_smm (proc a)))
      (Heqa': a' = update_cache_content a pa (find_memory_content a (phys_to_hard a pa)))
  : cache_clean_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  unfold cache_clean_inv, find_cache_content.
  intros pa' v' s Hinside' Hcache_hit Hfind.
  remember (find_memory_content a (phys_to_hard a pa)) as c'.
  unfold update_cache_content in Heqa'.
  rewrite Heqa' in Hfind.
  simpl in Hfind.
  unfold global_update_in_cache in Hfind.
  destruct (cache_hit_dec (cache a) pa) as [Hcache_hit_pa|Hnot_cache_hit_pa].
  * unfold update_in_cache, find_in_cache in Hfind.
    destruct (eq_dec pa pa') as [Heqpapa'|Hneqpapa'].
    - apply eq_equal in Heqpapa'.
      rewrite Heqpapa' in Hfind.
      assert (cache_hit
                (add_in_map (cache a) (phys_to_index pa')
                            {| dirty := true; content := c'; tag := pa' |}) pa') as Hcache_hit_add.
      unfold cache_hit.
      rewrite add_1.
      apply eq_refl.
      destruct (cache_hit_dec
                (add_in_map (cache a) (phys_to_index pa')
                            {| dirty := true; content := c'; tag := pa' |}) pa');
        [| intuition].
      rewrite add_1 in Hfind.
      simpl in Hfind.
      rewrite Heqpapa' in Heqc'.
      unfold phys_to_hard, translate_physical_address in Heqc'.
      destruct (is_inside_smram_dec pa') as [Hinside|_H]; [| intuition ].
      assert (is_in_smm (proc a)); [
          rewrite <- Heqpapa' in Hinside;
          apply (Hin_smm Hinside) |].
      destruct (can_access_smram_dec (memory_controller a) (in_smm (proc a))) as [Hcan|Hcannot]; [
        |  unfold can_access_smram in Hcannot;
          intuition ].
      destruct c'.
      apply (Hsmram pa' v s Hinside).
      rewrite <- Heqc'.
      inversion Hfind.
      reflexivity.
    - destruct (eq_dec (phys_to_index pa) (phys_to_index pa')) as [Heqi|Hneqi].
      assert (cache_hit (cache a') pa); [
          rewrite Heqa';
          simpl;
          apply global_update_in_cache_cache_hit |].
      assert (~ cache_hit (cache a') pa'); [
          apply (cache_hit_same_index_cache_miss (cache a') pa); trivial
        | intuition ].
      assert (cache_hit
                (add_in_map (cache a) (phys_to_index pa)
                            {| dirty := true; content := c'; tag := pa |}) pa').
      unfold cache_hit.
      rewrite <- add_2; [| exact Hneqi ].
      rewrite Heqa' in Hcache_hit.
      simpl in Hcache_hit.
      unfold cache_hit, global_update_in_cache in Hcache_hit.
      destruct (cache_hit_dec (cache a) pa) as [Hcache_hit_x_pa|Hncache_hit_x_pa].
      unfold update_in_cache in Hcache_hit.
      rewrite <- add_2 in Hcache_hit; [| exact Hneqi ].
      exact Hcache_hit.
      apply Hncache_hit_x_pa in Hcache_hit_pa.
      destruct Hcache_hit_pa.
      destruct (cache_hit_dec
                  (add_in_map (cache a) (phys_to_index pa)
                              {| dirty := true; content := c'; tag := pa |}) pa') as [Hcache_add|Hncache_add].
      rewrite <- add_2 in Hfind.
      unfold cache_clean_inv in Hclean.
      assert (cache_hit (cache a) pa') as Hcache_hit_x_pa'; [
          apply (cache_hit_is_preserve_by_non_conflicted_update (cache a)
                                                                (cache a')
                                                                pa
                                                                pa'
                                                                c'); [
          exact Hneqi |
          rewrite Heqa'; simpl; reflexivity |
          exact Hcache_hit ] |].
      assert (find_cache_content a pa' = Some (content (find_in_map (cache a) (phys_to_index pa')))) as Hfind'.
      unfold find_cache_content, find_in_cache.
      destruct (cache_hit_dec (cache a) pa') as [_H|_H]; [ reflexivity | intuition ].
      apply (Hclean pa' v' s Hinside' Hcache_hit_x_pa').
      inversion Hfind.
      exact Hfind'.
      exact Hneqi.
      discriminate Hfind.
  * destruct (eq_dec (phys_to_index pa) (phys_to_index pa')) as [Heqi|Hneqi].
    - assert (cache a'=global_update_in_cache (cache a) pa c') as Heqcache'; [
        rewrite Heqa';
        simpl;
        reflexivity |].
      assert (cache_hit (global_update_in_cache (cache a) pa c') pa); [
          apply (global_update_in_cache_cache_hit (cache a) pa) |].
      rewrite <- Heqcache' in H.
      destruct (eq_dec pa pa') as [Heq|Hneq].
      (* case addr_eq *)
      apply eq_equal in Heq.
      rewrite Heq in Heqc'.
      unfold smram_code_inv in Hsmram.
      assert (is_inside_smram pa'); try exact Hinside'.
      rewrite <- Heq in Hinside'.
      apply Hin_smm in Hinside'.
      unfold is_in_smm in Hinside'.
      unfold phys_to_hard, translate_physical_address in Heqc'.
      rewrite <- Heq in Heqc'.
      destruct (is_inside_smram_dec pa).
      rewrite Hinside' in Heqc'.
      destruct (can_access_smram_dec (memory_controller a) true).
      destruct c' as [v l].
      assert (l = smm).
      apply (Hsmram pa v l i).
      symmetry; exact Heqc'.
      rewrite H1 in *.
      unfold find_in_cache, load_in_cache in Hfind.
      rewrite <- Heq in Hfind.
      destruct cache_hit_dec.
      rewrite add_1 in Hfind.
      simpl in Hfind.
      inversion Hfind.
      reflexivity.
      unfold cache_hit in n.
      rewrite add_1 in n.
      simpl in n.
      unfold not in n.
      assert (eq pa pa) by (apply eq_refl).
      apply n in H2.
      destruct H2.
      unfold can_access_smram in n.
      apply not_or_and in n.
      destruct n as [G1 G2].
      intuition.
      rewrite <- Heq in H0.
      intuition.
      (* case ~ addr_eq *)
      apply (global_update_not_cache_hit (cache a) (cache a') pa pa' c') in Heqcache'; try intuition.
    - unfold find_in_cache, load_in_cache in Hfind.
      destruct cache_hit_dec.
      rewrite <- add_2 in Hfind.
      assert (cache_hit (cache a) pa') as Hcache_hit_before; [
          apply (cache_hit_is_preserve_by_non_conflicted_update (cache a)
                                                                (cache a')
                                                                pa
                                                                pa'
                                                                c'); [
            exact Hneqi
          | rewrite Heqa'; reflexivity
          | exact Hcache_hit ] |].
      unfold cache_clean_inv in Hclean.
      inversion Hfind.
      apply (Hclean pa' v' s Hinside' Hcache_hit_before).
      unfold find_cache_content.
      unfold find_in_cache.
      destruct cache_hit_dec; intuition.
      exact Hneqi.
      discriminate Hfind.
Qed.

Lemma load_in_cache_from_memory_preserves_cache_clean_inv
      (a a':  Architecture Software)
      (pa:    PhysicalAddress)
      (Hinv:  inv a)
      (Hin_smm: (is_inside_smram pa -> is_in_smm (proc a)))
      (Heqa': a' = load_in_cache_from_memory a pa)
  : cache_clean_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  assert (inv a) as Hinv.
  split; [ exact Hsmramc
         | split; [ exact Hsmram
                  | split ; [ exact Hsmrr
                            | split ; [ exact Hclean
                                      | split; [ exact Hip
                                               | exact Hsmbase ]]]]].
  unfold load_in_cache_from_memory in Heqa'.
  destruct (cache_location_is_dirty_dec (cache a) pa) as [Hdirty|Hndirty].
  + remember (update_memory_content a
                                    (phys_to_hard a (cache_location_address (cache a) pa))
                                    (find_in_cache_location (cache a) pa)) as ax.
    assert (inv ax) as Hinvx.
    apply (update_memory_content_with_cache_content_preserves_inv a ax pa); trivial.
    apply (update_cache_with_memory_cache_clean_inv ax a' pa Hinvx);
      destruct Hinvx as [Hsmramcx [Hsmramx [Hsmrrx [Hcleanx [Hipx Hsmbasex]]]]].
    - apply update_memory_changes_only_memory in Heqax.
      destruct Heqax as [_Hmc [Hproc _Hcache]].
      rewrite <- Hproc.
      exact Hin_smm.
    - exact Heqa'.
  + apply (update_cache_with_memory_cache_clean_inv a a' pa Hinv Hin_smm Heqa').
Qed.

Lemma load_in_cache_from_memory_preserves_smrr_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = load_in_cache_from_memory a pa)
  : smrr_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply load_in_cache_from_memory_changes_only_mem_and_cache in Heqa' as [Hproc Hother].
  unfold smrr_inv.
  rewrite <- Hproc.
  exact Hsmrr.
Qed.

Lemma load_in_cache_from_memory_preserves_smramc_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = load_in_cache_from_memory a pa)
  : smramc_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply load_in_cache_from_memory_changes_only_mem_and_cache in Heqa' as [Hproc Hother].
  unfold smramc_inv.
  rewrite <- Hother.
  exact Hsmramc.
Qed.

Lemma load_in_cache_from_memory_preserves_smbase_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = load_in_cache_from_memory a pa)
  : smbase_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply load_in_cache_from_memory_changes_only_mem_and_cache in Heqa' as [Hproc Hother].
  unfold smbase_inv.
  rewrite <- Hproc.
  exact Hsmbase.
Qed.

Lemma load_in_cache_from_memory_preserves_ip_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = load_in_cache_from_memory a pa)
  : ip_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply load_in_cache_from_memory_changes_only_mem_and_cache in Heqa' as [Hproc Hother].
  unfold ip_inv.
  rewrite <- Hproc.
  rewrite <- (context_is_preserves a a' Hproc).
  exact Hip.
Qed.

Lemma load_in_cache_from_memory_preserves_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = load_in_cache_from_memory a pa)
  : inv a'.
Proof.
  unfold inv.
  split; [| split; [| split; [| split; [| split]]]]; [
      eapply (load_in_cache_from_memory_preserves_smramc_inv a a' pa)
    | eapply (load_in_cache_from_memory_preserves_smram_code_inv a a' pa)
    | eapply (load_in_cache_from_memory_preserves_smrr_inv a a' pa)
    | eapply (load_in_cache_from_memory_preserves_cache_clean_inv a a' pa)
    | eapply (load_in_cache_from_memory_preserves_ip_inv a a' pa)
    | eapply (load_in_cache_from_memory_preserves_smbase_inv a a' pa) ]; trivial.
Qed.

Lemma update_cache_content_with_context_preserves_smramc_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : smramc_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_cache_changes_only_cache in Heqa' as [Hproc [Hmc Hother]].
  unfold smramc_inv.
  rewrite <- Hmc.
  exact Hsmramc.
Qed.

Lemma update_cache_content_with_context_preserves_smrr_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : smrr_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_cache_changes_only_cache in Heqa' as [Hproc [Hmc Hother]].
  unfold smrr_inv.
  rewrite <- Hproc.
  exact Hsmrr.
Qed.

Lemma update_cache_content_with_context_preserves_smram_code_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : smram_code_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_cache_changes_only_cache in Heqa' as [Hproc [Hmc Hmem]].
  unfold smram_code_inv.
  unfold find_memory_content.
  rewrite <- Hmem.
  exact Hsmram.
Qed.

Lemma update_cache_content_with_context_preserves_ip_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : ip_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_cache_changes_only_cache in Heqa' as [Hproc [Hmc Hmem]].
  unfold ip_inv.
  rewrite <- Hproc.
  rewrite <- (context_is_preserves a a' Hproc).
  exact Hip.
Qed.

Lemma update_cache_content_with_context_preserves_smbase_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : smbase_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  apply update_cache_changes_only_cache in Heqa' as [Hproc [Hmc Hmem]].
  unfold smbase_inv.
  rewrite <- Hproc.
  exact Hsmbase.
Qed.

Lemma update_cache_content_with_context_preserves_cache_clean_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : cache_clean_inv a'.
Proof.
  destruct Hinv as [Hsmramc [Hsmram [Hsmrr [Hclean [Hip Hsmbase]]]]].
  unfold cache_clean_inv.
  intros pa' val' s' Hinside' Hcache_hit' Hfind'.
  assert (cache a' = global_update_in_cache (cache a) pa (val, smm_context a))
    as Heqcache
      by (rewrite Heqa'; reflexivity).
  unfold global_update_in_cache in Heqcache.
  destruct (cache_hit_dec (cache a) pa).
  + unfold update_in_cache in Heqcache.
    unfold find_cache_content in Hfind'.
    unfold find_in_cache in Hfind'.
    destruct cache_hit_dec; [| intuition ].
    rewrite Heqa' in Hfind'; simpl.
    destruct (eq_dec pa pa') as [Heq|Hneq].
    * apply eq_equal in Heq.
      rewrite <- Heq in Hfind'.
      unfold update_cache_content, global_update_in_cache in Hfind'.
      simpl in Hfind'.
      destruct cache_hit_dec; [| intuition ].
      unfold update_in_cache in Hfind'.
      rewrite add_1 in Hfind'.
      simpl in Hfind'.
      inversion Hfind'.
      rewrite <- Heq in Hinside'.
      apply Hin_smm in Hinside'.
      unfold smm_context.
      destruct is_in_smm_dec.
      reflexivity.
      apply n in Hinside'.
      destruct Hinside'.
    * destruct (eq_dec (phys_to_index pa) (phys_to_index pa')) as [Heqi|Hneqi].
      - assert (~ cache_hit (cache a') pa'); [| intuition ].
        assert (cache_hit (cache a') pa) as Hcache_hit_pa.
        unfold cache_hit.
        rewrite Heqa'.
        unfold update_cache_content, global_update_in_cache, update_in_cache.
        simpl.
        destruct cache_hit_dec; [| intuition ].
        rewrite add_1.
        simpl.
        apply addr_eq_refl.
        apply (cache_hit_same_index_cache_miss (cache a') pa pa' Hcache_hit_pa Hneq Heqi).
      - simpl in Hfind'.
        unfold global_update_in_cache, update_in_cache in Hfind'.
        destruct cache_hit_dec; [| intuition].
        rewrite <- add_2 in Hfind' ; [| exact Hneqi ].
        assert (cache_hit (cache a) pa').
        apply (cache_hit_is_preserve_by_non_conflicted_update (cache a)
                                                              (cache a')
                                                              pa pa'
                                                              (val, smm_context a)
                                                              Hneqi).
        rewrite Heqa'.
        simpl.
        reflexivity.
        exact Hcache_hit'.
        inversion Hfind'.
        unfold cache_clean_inv in Hclean.
        apply (Hclean pa' val' s' Hinside' H).
        unfold find_cache_content, find_in_cache.
        destruct cache_hit_dec; [| intuition].
        rewrite H1.
        reflexivity.
  + unfold load_in_cache in Heqcache.
    unfold find_cache_content in Hfind'.
    unfold find_in_cache in Hfind'.
    destruct cache_hit_dec; [| intuition ].
    rewrite Heqa' in Hfind'; simpl in Hfind'.
    inversion Hfind'.
    destruct (eq_dec pa pa') as [Heqpa|Hneqpa].
    * apply eq_equal in Heqpa.
      rewrite <- Heqpa in H0.
      unfold global_update_in_cache in H0.
      destruct cache_hit_dec; [intuition|].
      unfold load_in_cache in H0.
      rewrite add_1 in H0.
      simpl in H0.
      inversion H0.
      rewrite <- Heqpa in Hinside'.
      apply Hin_smm in Hinside'.
      unfold smm_context.
      destruct is_in_smm_dec.
      reflexivity.
      apply n1 in Hinside'.
      destruct Hinside'.
    * destruct (eq_dec (phys_to_index pa) (phys_to_index pa')) as [Heqi|Hneqi].
      - assert (~ cache_hit (cache a') pa'); [| intuition ].
        assert (cache_hit (cache a') pa).
        unfold cache_hit.
        rewrite Heqa'.
        unfold update_cache_content, global_update_in_cache, load_in_cache.
        simpl.
        destruct cache_hit_dec; [intuition|].
        rewrite add_1.
        simpl.
        apply addr_eq_refl.
        apply (cache_hit_same_index_cache_miss (cache a') pa pa' H Hneqpa Heqi).
      - unfold update_cache_content, global_update_in_cache, load_in_cache in H0.
        destruct cache_hit_dec; [intuition|].
        rewrite <- add_2 in H0; [| exact Hneqi ].
        assert (cache_hit (cache a) pa').
        apply (cache_hit_is_preserve_by_non_conflicted_update (cache a)
                                                              (cache a')
                                                              pa pa'
                                                              (val, smm_context a)
                                                              Hneqi).
        rewrite Heqa'.
        simpl.
        reflexivity.
        exact Hcache_hit'.
        unfold cache_clean_inv in Hclean.
        apply (Hclean pa' val' s' Hinside' H).
        unfold find_cache_content, find_in_cache.
        destruct cache_hit_dec; [|intuition].
        rewrite H0.
        reflexivity.
Qed.

Lemma update_cache_content_with_context_preserves_inv
      (a a':    Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa':   a' = update_cache_content a pa (val, (smm_context a)))
  : inv a'.
Proof.
  unfold inv.
  split; [| split; [| split; [| split; [| split]]]]; [
      eapply (update_cache_content_with_context_preserves_smramc_inv a a' pa val)
    | eapply (update_cache_content_with_context_preserves_smram_code_inv a a' pa val)
    | eapply (update_cache_content_with_context_preserves_smrr_inv a a' pa val)
    | eapply (update_cache_content_with_context_preserves_cache_clean_inv a a' pa val)
    | eapply (update_cache_content_with_context_preserves_ip_inv a a' pa val)
    | eapply (update_cache_content_with_context_preserves_smbase_inv a a' pa val) ]; trivial.
Qed.

Lemma load_then_update_cache_with_context_preserves_inv
      (a a'':   Architecture Software)
      (pa:      PhysicalAddress)
      (val:     Value)
      (Hinv:    inv a)
      (Hin_smm: is_inside_smram pa -> is_in_smm (proc a))
      (Heqa'':  a'' = update_cache_content (load_in_cache_from_memory a pa) pa (val, smm_context a))
  : inv a''.
Proof.
  remember (load_in_cache_from_memory a pa) as a'.
  assert (inv a')
    as Hinv'
      by (apply (load_in_cache_from_memory_preserves_inv a a' pa Hinv Hin_smm Heqa')).
  assert (proc a = proc a').
  apply load_in_cache_from_memory_changes_only_mem_and_cache in Heqa' as [Hproc _H].
  exact Hproc.
  rewrite H in Hin_smm.
  rewrite (context_is_preserves a a' H) in Heqa''.
  apply (update_cache_content_with_context_preserves_inv a' a'' pa val Hinv' Hin_smm Heqa'').
Qed.


Require Import coqutil.Macros.unique.
Require Import coqutil.Decidable.
Require Import compiler.FlatImp.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.ZArith.ZArith.
Require Import riscv.Spec.Machine.
Require Import riscv.Spec.PseudoInstructions.
Require Import riscv.Utility.InstructionCoercions.
Require Import coqutil.Z.Lia.
Require Import riscv.Spec.Primitives.
Require Import riscv.Utility.Utility.
Require Import coqutil.Datatypes.ListSet.
Require Import riscv.Utility.Encode.
Require Import riscv.Utility.RegisterNames.
Require Import bedrock2.Syntax.
Require Import coqutil.Map.Interface.
Require Import compiler.SeparationLogic.
Require Import riscv.Spec.Decode.
Require Import compiler.Registers.
Require Import compiler.FlatImpConstraints.

Local Open Scope ilist_scope.
Local Open Scope Z_scope.

Set Implicit Arguments.

Notation Register0 := 0%Z (only parsing).

Definition valid_instructions(iset: InstructionSet)(prog: list Instruction): Prop :=
  forall instr, In instr prog -> verify instr iset.

(* x0 is the constant 0, x1 is ra, x2 is sp, the others are usable *)
Definition valid_FlatImp_var(x: Z): Prop := 3 <= x < 32.

Lemma sp_not_valid_FlatImp_var: ~ valid_FlatImp_var RegisterNames.sp.
Proof. unfold valid_FlatImp_var, RegisterNames.sp. clear. blia. Qed.

Lemma ra_not_valid_FlatImp_var: ~ valid_FlatImp_var RegisterNames.ra.
Proof. unfold valid_FlatImp_var, RegisterNames.ra. clear. blia. Qed.

Lemma valid_FlatImp_var_implies_valid_register: forall (x: Z),
    valid_FlatImp_var x -> valid_register x.
Proof. unfold valid_FlatImp_var, valid_register. intros. blia. Qed.

Section FlatToRiscv1.

  (* Part 1: Definitions needed to state when compilation outputs valid code *)

  Definition valid_registers_bcond: bcond Z -> Prop := ForallVars_bcond valid_register.
  Definition valid_FlatImp_vars_bcond: bcond Z -> Prop := ForallVars_bcond valid_FlatImp_var.

  Lemma valid_FlatImp_vars_bcond_implies_valid_registers_bcond: forall b,
      valid_FlatImp_vars_bcond b -> valid_registers_bcond b.
  Proof.
    unfold valid_FlatImp_vars_bcond, valid_registers_bcond.
    intros. eauto using ForallVars_bcond_impl, valid_FlatImp_var_implies_valid_register.
  Qed.

  Definition valid_FlatImp_vars: stmt Z -> Prop := Forall_vars_stmt valid_FlatImp_var.

  Definition valid_FlatImp_fun: list Z * list Z * stmt Z -> Prop :=
    fun '(argnames, retnames, body) =>
      argnames = List.firstn (List.length argnames) (reg_class.all reg_class.arg) /\
      retnames = List.firstn (List.length retnames) (reg_class.all reg_class.arg) /\
      valid_FlatImp_vars body /\
      uses_standard_arg_regs body.

  Context (iset: InstructionSet).

  (* Part 2: compilation *)

  (* load & store depend on the bitwidth: on 32-bit machines, Lw just loads 4 bytes,
     while on 64-bit machines, it loads 4 bytes and sign-extends them.
     If we want a command which always loads 4 bytes without sign-extending them,
     we need to make a case distinction on the bitwidth and choose Lw on 32-bit,
     but Lwu on 64-bit.
     We can't just always choose Lwu, because Lwu is not available on 32-bit machines. *)

  Definition compile_load(sz: access_size):
    Z -> Z -> Z -> Instruction :=
    match sz with
    | access_size.one => Lbu
    | access_size.two => Lhu
    | access_size.four => if bitwidth iset =? 32 then Lw else Lwu
    | access_size.word => if bitwidth iset =? 32 then Lw else Ld
    end.

  Definition compile_store(sz: access_size):
    Z -> Z -> Z -> Instruction :=
    match sz with
    | access_size.one => Sb
    | access_size.two => Sh
    | access_size.four => Sw
    | access_size.word => if bitwidth iset =? 32 then Sw else Sd
    end.

  Definition compile_op_imm(rd: Z)(op: Syntax.bopname)(rs1: Z)(c2: Z): list Instruction :=
    match op with
    | Syntax.bopname.add => [[Addi rd rs1 c2]]
    | Syntax.bopname.and => [[Andi rd rs1 c2]]
    | Syntax.bopname.or  => [[Ori  rd rs1 c2]]
    | Syntax.bopname.xor => [[Xori rd rs1 c2]]
    | Syntax.bopname.sru => [[Srli rd rs1 c2]]
    | Syntax.bopname.slu => [[Slli rd rs1 c2]]
    | Syntax.bopname.srs => [[Srai rd rs1 c2]]
    | Syntax.bopname.lts => [[Slti rd rs1 c2]]
    | Syntax.bopname.ltu => [[Sltiu rd rs1 c2]]
    | _ => [InvalidInstruction (-1)]
    end.

  Definition compile_op_register(rd: Z)(op: Syntax.bopname)(rs1 rs2: Z): list Instruction :=
    match op with
    | Syntax.bopname.add => [[Add rd rs1 rs2]]
    | Syntax.bopname.sub => [[Sub rd rs1 rs2]]
    | Syntax.bopname.mul => [[Mul rd rs1 rs2]]
    | Syntax.bopname.mulhuu => [[Mulhu rd rs1 rs2]]
    | Syntax.bopname.divu => [[Divu rd rs1 rs2]]
    | Syntax.bopname.remu => [[Remu rd rs1 rs2]]
    | Syntax.bopname.and => [[And rd rs1 rs2]]
    | Syntax.bopname.or  => [[Or  rd rs1 rs2]]
    | Syntax.bopname.xor => [[Xor rd rs1 rs2]]
    | Syntax.bopname.sru => [[Srl rd rs1 rs2]]
    | Syntax.bopname.slu => [[Sll rd rs1 rs2]]
    | Syntax.bopname.srs => [[Sra rd rs1 rs2]]
    | Syntax.bopname.lts => [[Slt rd rs1 rs2]]
    | Syntax.bopname.ltu => [[Sltu rd rs1 rs2]]
    | Syntax.bopname.eq  => [[Sub rd rs1 rs2; Seqz rd rd]]
    end.
  Definition compile_op(rd: Z)(op: Syntax.bopname)(op1 : Z)(op2: operand): list Instruction :=
    match  op2 with
    | Var v2 => compile_op_register rd op op1 v2
    | Const c2 => compile_op_imm rd op op1 c2
    end.

  Definition compile_lit_12bit(rd: Z)(v: Z): list Instruction :=
    [[ Addi rd Register0 (signExtend 12 v) ]].

  (* On a 64bit machine, loading a constant -2^31 <= v < 2^31 is not always possible with
     a Lui followed by an Addi:
     If the constant is of the form 0x7ffffXXX, and XXX has its highest bit set, we would
     have to put 0x80000--- into the Lui, but then that value will be sign-extended.

     Or spelled differently:
     If we consider all possible combinations of a Lui followed by an Addi, we get 2^32
     different values, but some of them are not in the range -2^31 <= v < 2^31.
     On the other hand, this property holds for combining Lui followed by a Xori.

     Or yet differently:
     Lui 0x80000--- ; Addi 0xXXX
     where XXX has the highest bit set,
     loads a value < 2^31, so some Lui+Addi pairs do not load a value in the range
     -2^31 <= v < 2^31, so some Lui+Addi pairs are "wasted" and we won't find a
     Lui+Addi pairs for all desired values in the range -2^31 <= v < 2^31
 *)

  Definition compile_lit_32bit(rd: Z)(v: Z): list Instruction :=
    let lo := signExtend 12 v in
    let hi := Z.lxor (signExtend 32 v) lo in
    [[ Lui rd hi ; Xori rd rd lo ]].

  Definition compile_lit_64bit(rd: Z)(v: Z): list Instruction :=
    let v0 := bitSlice v  0 11 in
    let v1 := bitSlice v 11 22 in
    let v2 := bitSlice v 22 32 in
    let hi := bitSlice v 32 64 in
    compile_lit_32bit rd (signExtend 32 hi) ++
    [[ Slli rd rd 10 ;
       Xori rd rd v2 ;
       Slli rd rd 11 ;
       Xori rd rd v1 ;
       Slli rd rd 11 ;
       Xori rd rd v0 ]].

  Definition compile_lit(rd: Z)(v: Z): list Instruction :=
    if ((-2^11 <=? v)%Z && (v <? 2^11)%Z)%bool then
      compile_lit_12bit rd v
    else if ((bitwidth iset =? 32)%Z || (- 2 ^ 31 <=? v)%Z && (v <? 2 ^ 31)%Z)%bool then
      compile_lit_32bit rd v
    else compile_lit_64bit rd v.

  (* Inverts the branch condition. *)
  Definition compile_bcond_by_inverting
             (cond: bcond Z) (amt: Z) : Instruction:=
    match cond with
    | CondBinary op x y =>
        match op with
        | BEq  => Bne x y amt
        | BNe  => Beq x y amt
        | BLt  => Bge x y amt
        | BGe  => Blt x y amt
        | BLtu => Bgeu x y amt
        | BGeu => Bltu x y amt
        end
    | CondNez x =>
        Beq x Register0 amt
    end.

  Local Notation bytes_per_word := (Memory.bytes_per_word (bitwidth iset)).

  Fixpoint save_regs(regs: list Z)(offset: Z): list Instruction :=
    match regs with
    | nil => nil
    | r :: regs => compile_store access_size.word sp r offset
                   :: (save_regs regs (offset + bytes_per_word))
    end.

  Fixpoint load_regs(regs: list Z)(offset: Z): list Instruction :=
    match regs with
    | nil => nil
    | r :: regs => compile_load access_size.word r sp offset
                   :: (load_regs regs (offset + bytes_per_word))
    end.

  (* number of words of stack allocation space needed within current frame *)
  Fixpoint stackalloc_words(s: stmt Z): Z :=
    match s with
    | SLoad _ _ _ _ | SStore _ _ _ _ | SInlinetable _ _ _ _ | SLit _ _ | SOp _ _ _ _ | SSet _ _
    | SSkip | SCall _ _ _ | SInteract _ _ _ => 0
    | SIf _ s1 s2 | SLoop s1 _ s2 | SSeq s1 s2 => Z.max (stackalloc_words s1) (stackalloc_words s2)
    (* ignore negative values, and round up values that are not divisible by bytes_per_word *)
    | SStackalloc x n body => (Z.max 0 n + bytes_per_word - 1) / bytes_per_word
                              + stackalloc_words body
    end.

  Definition compile4bytes(l: list byte): Instruction :=
    InvalidInstruction (LittleEndian.combine 4 (HList.tuple.of_list [
      nth 0 l Byte.x00;
      nth 1 l Byte.x00;
      nth 2 l Byte.x00;
      nth 3 l Byte.x00
    ])).

  Fixpoint compile_byte_list(l: list byte): list Instruction :=
    match l with
    | b0 :: b1 :: b2 :: b3 :: rest => compile4bytes l :: compile_byte_list rest
    | nil => nil
    | _ => [compile4bytes l]
    end.

  (* All positions are relative to the beginning of the progam, so we get completely
     position independent code. *)

  Context {env: map.map String.string (list Z * list Z * stmt Z)}.
  Context {pos_map: map.map String.string Z}.
  Context (compile_ext_call: pos_map -> Z -> Z -> stmt Z -> list Instruction).

  Section WithEnv.
    Variable e: pos_map.

    (* mypos: position of the code relative to the positions in e
       stackoffset: $sp + stackoffset is the (last) highest used stack address (for SStackalloc)
       s: statement to be compiled *)
    Fixpoint compile_stmt(mypos: Z)(stackoffset: Z)(s: stmt Z): list Instruction :=
      match s with
      | SLoad  sz x y ofs => [[compile_load  sz x y ofs]]
      | SStore sz x y ofs => [[compile_store sz x y ofs]]
      | SInlinetable sz x t i =>
        let bs := compile_byte_list t in
        [[ Jal x (4 + Z.of_nat (length bs) * 4) ]] ++ bs ++ [[ Add x x i; compile_load sz x x 0 ]]
      | SStackalloc x n body =>
          [[Addi x sp (stackoffset-n)]] ++ compile_stmt (mypos + 4) (stackoffset-n) body
      | SLit x v => compile_lit x v
      | SOp x op y z => compile_op x op y z
      | SSet x y => [[Add x Register0 y]]
      | SIf cond bThen bElse =>
          let bThen' := compile_stmt (mypos + 4) stackoffset bThen in
          let bElse' := compile_stmt (mypos + 4 + 4 * Z.of_nat (length bThen') + 4) stackoffset bElse in
          (* only works if branch lengths are < 2^12 *)
          [[compile_bcond_by_inverting cond ((Z.of_nat (length bThen') + 2) * 4)]] ++
          bThen' ++
          [[Jal Register0 ((Z.of_nat (length bElse') + 1) * 4)]] ++
          bElse'
      | SLoop body1 cond body2 =>
          let body1' := compile_stmt mypos stackoffset body1 in
          let body2' := compile_stmt (mypos + (Z.of_nat (length body1') + 1) * 4) stackoffset body2 in
          (* only works if branch lengths are < 2^12 *)
          body1' ++
          [[compile_bcond_by_inverting cond ((Z.of_nat (length body2') + 2) * 4)]] ++
          body2' ++
          [[Jal Register0 (- Z.of_nat (length body1' + 1 + length body2') * 4)]]
      | SSeq s1 s2 =>
          let s1' := compile_stmt mypos stackoffset s1 in
          let s2' := compile_stmt (mypos + 4 * Z.of_nat (length s1')) stackoffset s2 in
          s1' ++ s2'
      | SSkip => nil
      | SCall resvars f argvars =>
        let fpos := match map.get e f with
                    | Some pos => pos
                    (* don't fail so that we can measure the size of the resulting code *)
                    | None => 42
                    end in
        [[ Jal ra (fpos - mypos) ]]
      | SInteract _ _ _ => compile_ext_call e mypos stackoffset s
      end.

    (*
     Stack layout:

     high addresses              ...
                      old sp --> begin of stack scratch space of previous function
                                 ra
                                 mod_var_n
                                 ...
                                 mod_var_0
                                 end of stack scratch space of current function
                                 ...  (stack scratch space also grows downwards, from "end" to "begin")
                      new sp --> begin of stack scratch space of current function
     low addresses               ...

     Expected stack layout at beginning of function call: like above, but only filled up to arg0.
     Stack grows towards low addresses.
    *)
    Definition compile_function(mypos: Z):
      (list Z * list Z * stmt Z) -> list Instruction :=
      fun '(argvars, resvars, body) =>
        let need_to_save := list_diff Z.eqb (modVars_as_list Z.eqb body) resvars in
        let scratchwords := stackalloc_words body in
        let framesize := bytes_per_word *
                         (Z.of_nat (1 + length need_to_save) + scratchwords) in
        [[ Addi sp sp (-framesize) ]] ++
        [[ compile_store access_size.word sp ra
                         (bytes_per_word * (Z.of_nat (length need_to_save) + scratchwords)) ]] ++
        save_regs need_to_save (bytes_per_word * scratchwords) ++
        compile_stmt (mypos + 4 * (2 + Z.of_nat (length need_to_save)))
                     (bytes_per_word * scratchwords) body ++
        load_regs need_to_save (bytes_per_word * scratchwords) ++
        [[ compile_load access_size.word ra sp
                        (bytes_per_word * (Z.of_nat (length need_to_save) + scratchwords)) ]] ++
        [[ Addi sp sp framesize ]] ++
        [[ Jalr zero ra 0 ]].

    Definition add_compiled_function(state: list Instruction * pos_map)(fname: String.string)
               (fimpl: list Z * list Z * stmt Z): list Instruction * pos_map :=
      let '(old_insts, infomap) := state in
      let pos := 4 * Z.of_nat (length (old_insts)) in
      let new_insts := compile_function pos fimpl in
      let '(argnames, retnames, fbody) := fimpl in
      (old_insts ++ new_insts,
       map.put infomap fname pos).

    Definition compile_funs: env -> list Instruction * pos_map :=
      map.fold add_compiled_function (nil, map.empty).
  End WithEnv.

  (* compiles all functions just to obtain their code size *)
  Definition build_fun_pos_env(e_impl: env): pos_map :=
    (* since we pass map.empty as the fun_pos_env into compile_funs, the instrs
       returned don't jump to the right positions yet (they all jump to 42),
       but the instructions have the right size, so the posmap we return is correct *)
    snd (compile_funs map.empty e_impl).

End FlatToRiscv1.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition reset_last_run_info_spec0 (rec: Pointer) (adt: RData) : option RData :=
    match rec with
    | (_rec_base, _rec_ofst) =>
      when adt == set_rec_last_run_info_esr_spec (_rec_base, _rec_ofst) (VZ64 0) adt;
      Some adt
     end
    .

End SpecLow.


(* Testing robustness of typing for a fixpoint with evars in its type *)

Inductive foo (n : nat) : Type := .
Definition foo_denote {n} (x : foo n) : Type := match x with end.

Definition baz : forall n (x : foo n), foo_denote x.
refine (fix go n (x : foo n) : foo_denote x := _).
Abort.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal28.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (l1:lst):@eq lst (Cons n (append l1 Nil)) (Cons n (append (append l1 Nil) Nil)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal28_append_assoc_55_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (l1:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"l1:" ++ "(" ++ show l1 ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  l1.
QuickChick collect_data.
Success.


Require Import VST.msl.msl_standard.
Require Import VST.msl.corable.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.msl_ext.
Require Import RamifyCoq.msl_ext.sepalg.

Local Open Scope pred.

Lemma join_age {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall h1 h2 h12 h1' h2' h12', join h1 h2 h12 -> join h1' h2' h12' -> age h1 h1' -> age h2 h2' -> age h12 h12'.
Proof.
  intros; destruct (age1_join _ H H1) as [w2 [w12 [? [? ?]]]];
  equate_age h2' w2; equate_join h12' w12; auto.
Qed.

Program Definition ocon {A: Type}{JA: Join A}{PA : Perm_alg A}{AG : ageable A} {AA : Age_alg A} (p q:pred A) : pred A :=
  fun h:A => exists h1 h2 h3 h12 h23, join h1 h2 h12 /\ join h2 h3 h23 /\ join h12 h3 h /\ p h12 /\ q h23.
Next Obligation.
  destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  try_join h2 h3 h23'; equate_join h23 h23'.
  destruct (age1_join2 _ H2 H) as [w12 [w3 [? [? ?]]]].
  destruct (age1_join2 _ H0 H7) as [w1 [w2 [? [? ?]]]].
  try_join w2 w3 w23.
  exists w1, w2, w3, w12, w23.
  repeat split; auto.
  apply pred_hereditary with h12; auto.
  apply pred_hereditary with h23; auto.
  apply (join_age h2 h3 _ w2 w3 _); auto.
Qed.

Notation "P ⊗ Q" := (ocon P Q) (at level 40, left associativity) : pred.

Program Definition owand {A: Type}{JA: Join A}{PA : Perm_alg A}{AG : ageable A} {AA : Age_alg A} (p q:pred A) : pred A :=
  fun h23':A => forall h23 h1 h2 h3 h12 h123, necR h23' h23 -> join h1 h2 h12 -> join h2 h3 h23 -> join h12 h3 h123 -> p h12 -> q h123.
Next Obligation.
  rename a' into h23'.
  eapply (H0 h23 h1 h2 h3 h12 h123); eauto.
  apply necR_power_age.
  apply necR_power_age in H1.
  destruct H1 as [n ?H].
  exists (S n).
  exists h23'; auto.
Qed.

Lemma ocon_emp_i {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{AG : ageable A} {AA : Age_alg A}: forall P: pred A, P ⊗ emp = P.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros.
  destruct_ocon H h; try_join h2 h3 h23'; equate_join h23 h23'.
  rewrite (H3 _ _ (join_comm H5)) in H.
  generalize (join_positivity H H1); intro; rewrite H4; trivial.
  exists a, (core a), (core a), a, (core a).
  generalize (core_unit a); intro.
  unfold unit_for in H0.
  repeat split; auto.
  apply core_duplicable.
  apply core_identity.
Qed.

Lemma ocon_TT_i {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{AG : ageable A} {AA : Age_alg A}: forall P: pred A, P ⊗ TT = P * TT.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros.
  + destruct_ocon H h.
    exists h12, h3; auto.
  + destruct H as [? [? [? [? ?]]]].
    exists x, (core x), x0, x, x0.
    repeat split; auto.
    - apply join_comm, core_unit.
    - apply join_core2 in H.
      rewrite H.
      apply core_unit.
Qed.

Lemma andp_ocon_i {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q, P && Q |-- P ⊗ Q.
Proof.
  intros.
  hnf; intros; simpl in *; intros.
  destruct H.
  remember (core a) as u.
  exists u, a, u, a, a.
  repeat split; try rewrite Hequ; auto;
  try apply core_unit;
  apply join_comm; apply core_unit.
Qed.

Lemma ocon_andp_prop_i {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q R, P ⊗ (!!Q && R) = !!Q && (P ⊗ R).
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *.
  + destruct H as [h1 [h2 [h3 [h12 [h23 [? [? [? [? [? ?]]]]]]]]]].
    split; auto. exists h1, h2, h3, h12, h23. intuition.
  + destruct H as [? [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]]].
    exists h1, h2, h3, h12, h23. intuition.
Qed.

Lemma sepcon_ocon_i {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q, P * Q |-- P ⊗ Q.
Proof.
  intros; hnf; intros; simpl in *; intros.
  destruct H as [y [z [? [? ?]]]].
  remember (core z) as u.
  exists y, u, z, y, z.
  repeat split; auto.
  generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
  rewrite Hequ.
  replace (core z) with (core y).
  apply join_comm, core_unit.
  rewrite H2, H3; trivial.
  rewrite Hequ. apply core_unit.
Qed.

Lemma join_necR {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall h1 h2 h12 h1' h2' h12', join h1 h2 h12 -> join h1' h2' h12' -> necR h1 h1' -> necR h2 h2' -> necR h12 h12'.
Proof.
  intros; destruct (nec_join H H1) as [w2 [w12 [? [? ?]]]];
  destruct (join_level _ _ _ H3); rewrite <- H7 in H6;
  destruct (join_level _ _ _ H0); rewrite <- H9 in H8;
  rewrite H8 in H6; generalize (necR_linear' H2 H4 H6); intro;
  rewrite <- H10 in H3; equate_join h12' w12; auto.
Qed.

Lemma ocon_wand_i {A}{JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q, P ⊗ Q = EX R : pred A, (R -* P) * (R -* Q) * R.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *.
  destruct H as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  try_join h2 h3 h23'; equate_join h23 h23'; try_join h1 h3 h13.
  exists (exactly h2), h13, h2; repeat split; simpl; auto; exists h1, h3; repeat split; auto.
  intros h1' h2' h12'; intros; apply (pred_nec_hereditary P h12); auto; apply (join_necR h1 h2 _ h1' h2' _); auto.
  intros h3' h2' h23'; intros; apply (pred_nec_hereditary Q h23); auto; apply (join_necR h2 h3 _ h2' h3' _); auto.
  (* another direction *)
  destruct H as [R [w13 [w2 [? [[w1 [w3 [? [HP HQ]]]] HR]]]]].
  try_join w2 w3 w23; try_join w1 w2 w12.
  exists w1, w2, w3, w12, w23; repeat split; auto.
  apply (HP w1 w2); auto. apply (HQ w3 w2); auto.
Qed.

Lemma ocon_comm_i {A}{JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q, P ⊗ Q = Q ⊗ P.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros;
  destruct_ocon H h; exists h3, h2, h1, h23, h12;
  repeat split; auto; try_join h2 h3 h23'; equate_join h23 h23'; auto.
Qed.

Lemma cross_rev {A}{JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}: forall h1 h2 h3 h4
  h12 h34 h13 h24 h1234, join h1 h2 h12 -> join h1 h3 h13 -> join h3 h4
  h34 -> join h2 h4 h24 -> join h12 h34 h1234 -> join h13 h24 h1234.
Proof.
  intros; try_join h2 h34 h234;
  try_join h2 h4 h24'; equate_join h24 h24';
  try_join h1 h3 h13'; equate_join h13 h13'; auto.
Qed.

Lemma ocon_assoc_i {A}{JA: Join A}{PA: Perm_alg A}{CA: Cross_alg A}{AG : ageable A} {AA : Age_alg A}:
  forall P Q R: pred A, P ⊗ Q ⊗ R = P ⊗ (Q ⊗ R).
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros.
  destruct H as [w124 [w567 [w3 [w124567 [w3567 [? [? [? [[w15 [w47 [w26 [w1457 [w2467 [? [? [? [? ?]]]]]]]]] ?]]]]]]]]].
  destruct (cross_split _ _ _ _ _ H H4) as [[[[w14 w2] w57] w6] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H2 H10) as [[[[w1 w5] w4] w7] [? [? [? ?]]]].
  try_join w5 w47 w457; try_join w3 w26 w236; try_join w236 w457 w234567.
  exists w1, w457, w236, w1457, w234567; repeat split; auto.
  try_join w2 w4 w24; try_join w6 w7 w67; try_join w3 w5 w35.
  exists w24, w67, w35, w2467, w3567; repeat split; auto.
  apply (cross_rev w2 w6 w4 w7 w26 w47); auto. apply (cross_rev w47 w5 w26 w3 w457 w236); auto.
  (* another direction *)
  destruct H as [w1 [w457 [w236 [w1457 [w234567 [? [? [? [? [w24 [w67 [w35 [w2467 [w3567 [? [? [? [? ?]]]]]]]]]]]]]]]]]].
  destruct (cross_split _ _ _ _ _ H0 H5) as [[[[w47 w5] w26] w3] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H3 H10) as [[[[w4 w2] w7] w6] [? [? [? ?]]]].
  try_join w26 w1457 w124567; try_join w5 w67 w567; try_join w5 w7 w57; try_join w1 w4 w14;
  try_join w14 w26 w1246; try_join w2 w14 w124.
  exists w124, w567, w3, w124567, w3567; repeat split; auto.
  apply join_comm; apply (cross_rev w6 w2 w57 w14 w26 w1457); auto.
  try_join_through w67 w5 w7 w57'; equate_join w57 w57'; auto.
  try_join w1 w5 w15; exists w15, w47, w26, w1457, w2467;
  repeat split; auto.
Qed.

Lemma ocon_derives_i {A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}: forall p q p' q', (p |-- p') -> (q |-- q') -> (p ⊗ q |-- p' ⊗ q').
Proof.
  repeat (intros; hnf).
  simpl in H1.
  destruct_ocon H1 w.
  exists w1,w2,w3,w12,w23.
  repeat split; auto.
Qed.

Lemma owand_ocon_adjoint_i {A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q R, ocon P Q |-- R <-> P |-- owand Q R.
Proof.
  intros.
  rewrite ocon_comm_i.
  unfold ocon, owand, derives.
  simpl.
  split; intros.
  + apply H.
    exists h1, h2, h3, h12, h23.
    repeat split; auto.
    inversion P.
    apply pred_nec_hereditary with a; auto.
  + destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
    specialize (H h23 H4).
    specialize (H h23 h1 h2 h3 h12 a).
    apply H; auto.
Qed.

Lemma ocon_contain_i {A} {JA: Join A} {PA: Perm_alg A} {SA: Sep_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q, Q |-- P * TT -> Q |-- ocon P Q.
Proof.
  unfold ocon, owand, derives; simpl; intros.
  destruct (H a H0) as [y [z [? [? ?]]]].
  exists (core y), y, z, y, a.
  repeat split; auto.
  apply core_unit.
Qed.

Lemma precise_ocon_contain_i {A} {JA: Join A} {PA: Perm_alg A} {SA: Sep_alg A} {CA: Canc_alg A} {DA: Disj_alg A} {AG : ageable A} {AA : Age_alg A}: forall P Q, precise P -> Q |-- P * TT -> Q = ocon P Q.
Proof.
  intros; apply pred_ext; [apply ocon_contain_i; auto |].
  unfold ocon, owand, derives in *; simpl in *.
  intros.
  destruct H1 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  destruct (H0 _ H5) as [y [z [? [? ?]]]].
  try_join h2 h3 h23'. equate_join h23 h23'. assertSub y a HS1.
  equate_precise y h12.
  try_join z h1 h3'. equate_canc h3 h3'.
  assert (identity h1).
  1: {
    try_join h1 h3 h_temp.
    assertSub h1 h3 H12.
    eapply join_sub_joins_identity; eauto.
  }
  apply join_comm in H4.
  apply H9 in H10; apply H9 in H4.
  subst.
  auto.
Qed.

Definition disjointed {A: Type} {JA: Join A} {AG : ageable A} (P Q: pred A):=
  forall h1 h2 h3 h12 h23,
  join h1 h2 h12 -> join h2 h3 h23 -> P h12 -> Q h23 -> identity h2 /\ joins h1 h3.

Lemma ocon_sepcon_i {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {AG : ageable A} {AA : Age_alg A}:
  forall P Q, disjointed P Q -> ocon P Q |-- P * Q.
Proof.
  unfold ocon, sepcon, disjointed, derives; simpl.
  intros.
  destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  destruct (H h1 h2 h3 h12 h23 H0 H1 H3 H4) as [? ?].
  apply join_comm in H0.
  apply H5 in H0.
  apply H5 in H1.
  subst.
  exists h12, h23.
  auto.
Qed.

Lemma disj_emp_i {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {CA: Canc_alg A} {AG : ageable A} {AA : Age_alg A}: forall P, disjointed P emp.
Proof.
  intros.
  unfold disjointed, emp; simpl; intros.
  pose proof split_identity _ _ H0 H2.
  pose proof split_identity _ _ (join_comm H0) H2.
  pose proof identities_unique H3 H4 (ex_intro _ h23 H0).
  subst.
  split; eauto.
Qed.

Lemma disj_comm_i {A: Type} {JA: Join A} {PA: Perm_alg A} {AG : ageable A}: forall P Q, disjointed P Q -> disjointed Q P.
Proof.
  unfold disjointed; intros.
  specialize (H h3 h2 h1 h23 h12).
  do 2 (spec H; [apply join_comm; auto |]).
  do 2 (spec H; [auto |]).
  destruct H; split; auto.
  apply joins_comm; auto.
Qed.

Lemma disj_derives_i {A: Type} {JA: Join A} {PA: Perm_alg A} {AG : ageable A}:
  forall P P' Q Q', P |-- P' -> Q |-- Q' -> disjointed P' Q' -> disjointed P Q.
Proof.
  unfold derives, disjointed.
  intros.
  apply H1 with h12 h23; auto.
Qed.

(**************************************************************************

          |------------------------------------------|
          |                                          |
          |                                          |
          |                                          |
          |                     P                    |
          |                                          |
          |                                          |
|---------|----------|-----------------------|-------|------------|
|         |          |                       |       |            |
|         |    p1    |         p2            |   p3  |            |
|         |          |                       |       |            |
|         |------------------------------------------|            |
|                    |                       |                    |
|                    |                       |                    |
|        r1          |          r2           |         r3         |
|                    |                       |                    |
|                    |                       |                    |
|                    |                       |                    |
|--------------------|-----------------------|--------------------|

**************************************************************************)

Lemma disj_ocon_right_i {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {CA: Canc_alg A} {CrA: Cross_alg A} {TA: Trip_alg A} {AG : ageable A} {AA : Age_alg A}:
  forall P Q R, disjointed P Q -> disjointed P R -> disjointed P (ocon Q R).
Proof.
  unfold ocon, disjointed, precise; simpl.
  intros P Q R ? ? hP hp1p2p3 hr1r2r3 hPp h123.
  intros.
  destruct H4 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  destruct (join_assoc H4 H6) as [h23' [? ?]]; equate_join h23 h23'.
  destruct (cross_split _ _ _ _ _ H10 H2) as [[[[hp1 hr1] hp2p3] hr2r3] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H5 H11) as [[[[hp2 hr2] hp3] hr3] [? [? [? ?]]]].
  try_join hp1 hp2 hp1p2.
  try_join hr1 hr2 hr1r2.
  assert (join hp1p2 hr1r2 h12).
  1: {
    try_join hp1 h2 hp1p2r2.
    destruct (join_assoc (join_comm H14) (join_comm H22)) as [hp1p2' [? ?]].
    equate_join hp1p2 hp1p2'.
    destruct (join_assoc (join_comm H25) (join_comm H23)) as [hr1r2' [? ?]].
    equate_join hr1r2 hr1r2'.
    auto.
  }

  try_join hP hp3 hPp3.
  assert (identity hp1p2 /\ joins hPp3 hr1r2) as [? ?] by (apply H with hPp h12; auto).
  try_join hP hp1 hPp1.
  assert (identity hp2p3 /\ joins hPp1 hr2r3) as [? ?] by (apply H0 with hPp h23; auto).

  assert (identity hp1) by (apply split_identity with hp2 hp1p2; auto).
  assert (identity hp3) by (apply split_identity with hp2 hp2p3; auto).
  split.
  + apply join_identity with hp1 hp2p3; auto.
  + apply H31 in H27.
    apply H32 in H23.
    subst hPp1 hPp3.
    destruct H26 as [hPr1r2 ?].
    destruct H30 as [hPr1r3 ?].
    destruct (join_assoc H20 (join_comm H23)) as [hPr1 [? ?]].
    destruct (triple_join_exists _ _ _ _ _ _ H13 (join_comm H26) H27) as [hPr1r2r3 ?H].
    apply joins_comm; eauto.
Qed.

Definition covariant {B A : Type} {AG: ageable A} (F: (B -> pred A) -> (B -> pred A)) : Prop :=
forall (P Q: B -> pred A), (forall x, P x |-- Q x) -> (forall x, F P x |-- F Q x).

Lemma covariant_ocon {B}{A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}:
   forall F1 F2 : (B -> pred A) -> (B -> pred A),
    covariant F1 -> covariant F2 ->
    covariant (fun (x : B -> pred A) b => F1 x b ⊗ F2 x b).
Proof.
  intros; hnf.
  intros P Q ? ?.
  eapply ocon_derives_i.
  apply H, H1.
  apply H0, H1.
Qed.

Definition contravariant {B A : Type} {AG: ageable A} (F: (B -> pred A) -> (B -> pred A)) : Prop :=
forall (P Q: B -> pred A), (forall x, P x |-- Q x) -> (forall x, F Q x |-- F P x).

Lemma contravariant_ocon {B}{A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}:
   forall F1 F2 : (B -> pred A) -> (B -> pred A),
    contravariant F1 -> contravariant F2 ->
    contravariant (fun (x : B -> pred A) b => F1 x b ⊗ F2 x b).
Proof.
  intros; hnf.
  intros P Q ? ?.
  eapply ocon_derives_i.
  apply H, H1.
  apply H0, H1.
Qed.

Lemma later_ocon {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q, ((|> (P ⊗ Q)) = |> Q ⊗ |> P).
Proof.
  intros; repeat rewrite later_age; apply pred_ext; hnf; intros; simpl in *.
  case_eq (age1 a); intros.
  destruct (H a0) as [h1' [h2' [h3' [h12' [h23' [? [? [? [? ?]]]]]]]]]; auto.
  destruct (unage_join2 _ H3 H0) as [x12 [x3 [? [? ?]]]].
  destruct (unage_join2 _ H1 H7) as [x1 [x2 [? [? ?]]]].
  try_join x2 x3 x23; exists x3, x2, x1, x23, x12; repeat (split; auto).
  assert (age x23 h23') by (apply (join_age x2 x3 _ h2' h3' _); auto); intro h23; intros; equate_age h23' h23; auto.
  assert (age x12 h12') by (apply (join_age x1 x2 _ h1' h2' _); auto); intro h12; intros; equate_age h12' h12; auto.
  exists (core a), a, (core a), a, a. repeat split.
  apply core_unit. apply join_comm, core_unit. apply join_comm, core_unit.
  intros; unfold age in H1; rewrite H0 in H1; discriminate H1.
  intros; unfold age in H1; rewrite H0 in H1; discriminate H1.
  (* another direction *)
  destruct H as [x1 [x2 [x3 [x12 [x23 [? [? [? [? ?]]]]]]]]]; intros.
  destruct (age1_join2 _ H1 H4) as [h12 [h3 [? [? ?]]]].
  destruct (age1_join2 _ H H6) as [h1 [h2 [? [? ?]]]].
  try_join h2 h3 h23; exists h3, h2, h1, h23, h12; repeat (split; auto).
  apply H3; apply (join_age x2 x3 _ h2 h3 _); auto.
Qed.

Lemma precise_ocon_i {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}{CaA : Canc_alg A}{CrA : Cross_alg A}{DA : Disj_alg A}{AG : ageable A} {AA : Age_alg A} :
  forall P Q, precise P -> precise Q -> precise (P ⊗ Q).
Proof.
  intros; intro; intros.
  destruct_ocon H1 h; destruct_ocon H2 i.
  generalize (join_join_sub H6); intro; generalize (join_sub_trans H13 H3); intro.
  generalize (join_join_sub H10); intro; generalize (join_sub_trans H15 H4); intro.
  generalize (H w h12 i12 H7 H11 H14 H16); intro.
  try_join h2 h3 h23'; equate_join h23 h23'; try_join i2 i3 i23'; equate_join i23 i23'.
  generalize (join_join_sub' H19); intro; generalize (join_sub_trans H18 H3); intro.
  generalize (join_join_sub' H20); intro; generalize (join_sub_trans H22 H4); intro.
  generalize (H0 w h23 i23 H8 H12 H21 H23); intro.
  rewrite H17 in *; rewrite H24 in *. clear h12 h23 H7 H8 H11 H12 H13 H14 H15 H16 H17 H18 H21 H22 H23 H24.
  apply (overlapping_eq h1 h2 h3 i1 i2 i3 i12 i23); trivial.
Qed.

Lemma precise_tri_exp_ocon {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CaA : Canc_alg A}
      {CrA : Cross_alg A} {DA : Disj_alg A}{AG : ageable A} {AA : Age_alg A} B:
  forall (P : B -> B -> B -> pred A) (Q R: B -> pred A),
    precise (EX x : B, EX y : B, EX z : B, P x y z) -> precise (exp Q) -> precise (exp R) ->
    precise (EX x : B, EX y : B, EX z : B, P x y z ⊗ Q y ⊗ R z).
Proof.
  repeat intro.
  destruct H2 as [x1 [y1 [z1 ?]]]; destruct_ocon H2 h; destruct_ocon H8 j;
  destruct H3 as [x2 [y2 [z2 ?]]]; destruct_ocon H3 i; destruct_ocon H16 k.
  assert (j12 = k12) by (hnf in H; apply H with (w := w);
                         [exists x1, y1, z1 | exists x2, y2, z2 | assertSub j12 w Hsub | assertSub k12 w Hsub]; auto).
  assert (j23 = k23) by (hnf in H0; apply H0 with (w := w);
                         [exists y1 | exists y2 | try_join j2 j3 j23'; equate_join j23 j23'; assertSub j23 w Hsub |
                                 try_join k2 k3 k23'; equate_join k23 k23'; assertSub k23 w Hsub]; auto).
  rewrite H22 in *; rewrite H23 in *; assert (h12 = i12) by (apply (overlapping_eq j1 j2 j3 k1 k2 k3 k12 k23); trivial).
  assert (h23 = i23) by (hnf in H1; apply H1 with (w := w);
                         [exists z1 | exists z2 | try_join h2 h3 h23'; equate_join h23 h23'; assertSub h23 w Hsub |
                                 try_join i2 i3 i23'; equate_join i23 i23'; assertSub i23 w Hsub]; auto).
  rewrite H24 in *; rewrite H25 in *; apply (overlapping_eq h1 h2 h3 i1 i2 i3 i12 i23); trivial.
Qed.

Lemma extract_andp_ocon_ocon_left {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}{AG : ageable A} {AA : Age_alg A}:
  forall (w : A) P Q R S, (P && Q ⊗ R ⊗ S) w -> exists w', P w'.
Proof. repeat intro; destruct_ocon H h; destruct_ocon H2 i; destruct H6; exists i12; trivial. Qed.

Lemma ocon_precise_elim  {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA : Disj_alg A}{AG : ageable A} {AA : Age_alg A}:
  forall P : pred A, precise P -> P ⊗ P = P.
Proof.
  intros; apply pred_ext; intro w; intro. destruct_ocon H0 h. try_join h2 h3 h23'; equate_join h23 h23'. equate_precise h12 h23.
  assert (emp h1). assertSub h1 h12 HS. assert (joins h1 h12). exists w; auto. apply (join_sub_joins_identity HS H4).
  equate_canc h1 h3. apply (join_unit1_e _ _ H4) in H6. subst. auto. hnf. exists (core w), w, (core w), w, w. split.
  apply core_unit. split. apply join_comm, core_unit. split. apply join_comm, core_unit. split; auto.
Qed.

Lemma corable_ocon_i: forall {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_alg A} P Q, corable P -> corable Q -> corable (ocon P Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold ocon.
  intros.
  simpl in H2 |- *.
  destruct H2 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  exists (core y), (core y), y, (core y), y.
  pose proof join_core H2.
  pose proof join_core (join_comm H2).
  pose proof join_core H3.
  pose proof join_core (join_comm H3).
  pose proof join_core H4.
  pose proof join_core (join_comm H4).
  repeat split.
  + rewrite <- core_idem at 1.
    apply core_unit.
  + apply core_unit.
  + apply core_unit.
  + apply H with h12; auto.
    rewrite core_idem.
    congruence.
  + apply H0 with h23; auto.
    congruence.
Qed.

Lemma corable_andp_ocon1_i {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  ocon (P && Q) R = P && (ocon Q R).
Proof.
  intros.
  apply pred_ext.
  + intros h [h1 [h2 [h3 [h12 [h23 [? [? [? [[? ?] ?]]]]]]]]].
    split.
    - apply join_core in H2.
      rewrite corable_spec in H.
      apply H with h12; [congruence | auto].
    - exists h1, h2, h3, h12, h23.
      tauto.
  + intros h [? [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]]].
    exists h1, h2, h3, h12, h23.
    rewrite corable_spec in H.
    repeat split; auto.
    apply join_core in H3.
    apply H with h; [congruence | auto].
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Compopts.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import ValueDomain.
Require Import RTL.

(** Value analysis for ARM operators *)

Definition eval_static_shift (s: shift) (v: aval): aval :=
  match s with
  | Slsl x => shl v (I x)
  | Slsr x => shru v (I x)
  | Sasr x => shr v (I x)
  | Sror x => ror v (I x)
  end.

Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
  | Ccompshift c s, v1 :: v2 :: nil => cmp_bool c v1 (eval_static_shift s v2)
  | Ccompushift c s, v1 :: v2 :: nil => cmpu_bool c v1 (eval_static_shift s v2)
  | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
  | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
  | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
  | Ccompfzero c, v1 :: nil => cmpf_bool c v1 (F Float.zero)
  | Cnotcompfzero c, v1 :: nil => cnot (cmpf_bool c v1 (F Float.zero))
  | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2
  | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2)
  | Ccompfszero c, v1 :: nil => cmpfs_bool c v1 (FS Float32.zero)
  | Cnotcompfszero c, v1 :: nil => cnot (cmpfs_bool c v1 (FS Float32.zero))
  | _, _ => Bnone
  end.

Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
  match addr, vl with
  | Aindexed n, v1::nil => add v1 (I n)
  | Aindexed2, v1::v2::nil => add v1 v2
  | Aindexed2shift s, v1::v2::nil => add v1 (eval_static_shift s v2)
  | Ainstack ofs, nil => Ptr(Stk ofs)
  | _, _ => Vbot
  end.

Definition eval_static_operation (op: operation) (vl: list aval): aval :=
  match op, vl with
  | Omove, v1::nil => v1
  | Ointconst n, nil => I n
  | Ofloatconst n, nil => if propagate_float_constants tt then F n else ftop
  | Osingleconst n, nil => if propagate_float_constants tt then FS n else ftop
  | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
  | Oaddrstack ofs, nil => Ptr (Stk ofs)
  | Ocast8signed, v1 :: nil => sign_ext 8 v1
  | Ocast16signed, v1 :: nil => sign_ext 16 v1
  | Oadd, v1::v2::nil => add v1 v2
  | Oaddshift s, v1::v2::nil => add v1 (eval_static_shift s v2)
  | Oaddimm n, v1::nil => add v1 (I n)
  | Osub, v1::v2::nil => sub v1 v2
  | Osubshift s, v1::v2::nil => sub v1 (eval_static_shift s v2)
  | Orsubshift s, v1::v2::nil => sub (eval_static_shift s v2) v1
  | Orsubimm n, v1::nil => sub (I n) v1
  | Omul, v1::v2::nil => mul v1 v2
  | Omla, v1::v2::v3::nil => add (mul v1 v2) v3
  | Omulhs, v1::v2::nil => mulhs v1 v2
  | Omulhu, v1::v2::nil => mulhu v1 v2
  | Odiv, v1::v2::nil => divs v1 v2
  | Odivu, v1::v2::nil => divu v1 v2
  | Oand, v1::v2::nil => and v1 v2
  | Oandshift s, v1::v2::nil => and v1 (eval_static_shift s v2)
  | Oandimm n, v1::nil => and v1 (I n)
  | Oor, v1::v2::nil => or v1 v2
  | Oorshift s, v1::v2::nil => or v1 (eval_static_shift s v2)
  | Oorimm n, v1::nil => or v1 (I n)
  | Oxor, v1::v2::nil => xor v1 v2
  | Oxorshift s, v1::v2::nil => xor v1 (eval_static_shift s v2)
  | Oxorimm n, v1::nil => xor v1 (I n)
  | Obic, v1::v2::nil => and v1 (notint v2)
  | Obicshift s, v1::v2::nil => and v1 (notint (eval_static_shift s v2))
  | Onot, v1::nil => notint v1
  | Onotshift s, v1::nil => notint (eval_static_shift s v1)
  | Oshl, v1::v2::nil => shl v1 v2
  | Oshr, v1::v2::nil => shr v1 v2
  | Oshru, v1::v2::nil => shru v1 v2
  | Oshift s, v1::nil => eval_static_shift s v1
  | Oshrximm n, v1::nil => shrx v1 (I n)
  | Onegf, v1::nil => negf v1
  | Oabsf, v1::nil => absf v1
  | Oaddf, v1::v2::nil => addf v1 v2
  | Osubf, v1::v2::nil => subf v1 v2
  | Omulf, v1::v2::nil => mulf v1 v2
  | Odivf, v1::v2::nil => divf v1 v2
  | Onegfs, v1::nil => negfs v1
  | Oabsfs, v1::nil => absfs v1
  | Oaddfs, v1::v2::nil => addfs v1 v2
  | Osubfs, v1::v2::nil => subfs v1 v2
  | Omulfs, v1::v2::nil => mulfs v1 v2
  | Odivfs, v1::v2::nil => divfs v1 v2
  | Osingleoffloat, v1::nil => singleoffloat v1
  | Ofloatofsingle, v1::nil => floatofsingle v1
  | Ointoffloat, v1::nil => intoffloat v1
  | Ointuoffloat, v1::nil => intuoffloat v1
  | Ofloatofint, v1::nil => floatofint v1
  | Ofloatofintu, v1::nil => floatofintu v1
  | Ointofsingle, v1::nil => intofsingle v1
  | Ointuofsingle, v1::nil => intuofsingle v1
  | Osingleofint, v1::nil => singleofint v1
  | Osingleofintu, v1::nil => singleofintu v1
  | Omakelong, v1::v2::nil => longofwords v1 v2
  | Olowlong, v1::nil => loword v1
  | Ohighlong, v1::nil => hiword v1
  | Ocmp c, _ => of_optbool (eval_static_condition c vl)
  | _, _ => Vbot
  end.

Section SOUNDNESS.

Variable bc: block_classification.
Variable ge: genv.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.

Lemma eval_static_shift_sound:
  forall s v a,
  vmatch bc v a ->
  vmatch bc (eval_shift s v) (eval_static_shift s a).
Proof.
  intros. unfold eval_shift, eval_static_shift. destruct s; eauto with va.
Qed.

Hint Resolve eval_static_shift_sound: va.

Theorem eval_static_condition_sound:
  forall cond vargs m aargs,
  Forall2 (vmatch bc) vargs aargs ->
  cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
Proof.
  intros until aargs; intros VM.
  inv VM.
  destruct cond; auto with va.
  inv H0.
  destruct cond; simpl; eauto with va.
  inv H2.
  destruct cond; simpl; eauto with va.
  destruct cond; auto with va.
Qed.

Lemma symbol_address_sound:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)).
Proof.
  intros; apply symbol_address_sound; apply GENV.
Qed.

Hint Resolve symbol_address_sound: va.

Ltac InvHyps :=
  match goal with
  | [H: None = Some _ |- _ ] => discriminate
  | [H: Some _ = Some _ |- _] => inv H
  | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
     H2: Forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
  | _ => idtac
  end.

Theorem eval_static_addressing_sound:
  forall addr vargs vres aargs,
  eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres ->
  Forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing addr aargs).
Proof.
  unfold eval_addressing, eval_static_addressing; intros;
  destruct addr; InvHyps; eauto with va.
  rewrite Int.add_zero_l; auto with va.
Qed.

Theorem eval_static_operation_sound:
  forall op vargs m vres aargs,
  eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres ->
  Forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_operation op aargs).
Proof.
  unfold eval_operation, eval_static_operation; intros;
  destruct op; InvHyps; eauto with va.
  destruct (propagate_float_constants tt); constructor.
  destruct (propagate_float_constants tt); constructor.
  rewrite Int.add_zero_l; eauto with va.
  fold (Val.sub (Vint i) x). auto with va.
  apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
Qed.

End SOUNDNESS.


From Equations Require Import Equations.

Require Import Psatz.

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Export SystemFR.OpenTOpen.
Require Export SystemFR.EqualWithRelation.
Require Export SystemFR.ReducibilityCandidate.
Require Export SystemFR.ReducibilityDefinition.
Require Export SystemFR.SubstitutionLemmas.
Require Export SystemFR.TOpenTClose.
Require Export SystemFR.NoTypeFVar.
Require Export SystemFR.PolarityLemmas.
Require Export SystemFR.FVLemmasLists.
Require Export SystemFR.NoTypeFVarLemmas.
Require Export SystemFR.TypeErasureLemmas.
Require Export SystemFR.AnnotatedTermLemmas.

Opaque makeFresh.
Opaque PeanoNat.Nat.eq_dec.

Lemma erase_type_topen2:
  forall T1 T2 k,
    is_annotated_type T1 ->
    erase_type T2 = T2 ->
    erase_type (topen k T1 T2) = topen k (erase_type T1) T2.
Proof.
  induction T1;
    repeat step || rewrite erase_term_topen in * || t_equality || rewrite topen_erase_term in *.
Qed.

Lemma has_polarities_erase_aux:
  forall n T pols,
    type_nodes T < n ->
    is_annotated_type T ->
    has_polarities T pols ->
    has_polarities (erase_type T) pols.
Proof.
  induction n; destruct T; steps; try lia;
    repeat
      step || step_inversion has_polarities || constructor || exists X || t_fv_erase ||
      rewrite <- erase_type_topen2 || apply_any || autorewrite with bsize in *;
        eauto with lia;
        eauto 2 with annot step_tactic.
Qed.

Lemma has_polarities_erase:
  forall T pols,
    is_annotated_type T ->
    has_polarities T pols ->
    has_polarities (erase_type T) pols.
Proof.
  eauto using has_polarities_erase_aux.
Qed.

Lemma has_polarities_subst_aux:
  forall n T pols l,
    type_nodes T < n ->
    has_polarities T pols ->
    pclosed_mapping l type_var ->
    twfs l 0 ->
    has_polarities (psubstitute T l term_var) pols.
Proof.
  induction n; destruct T;
    repeat step || constructor || step_inversion has_polarities || exists X || t_pfv_in_subst || eapply_any ||
           autorewrite with bsize in * ||
           (rewrite substitute_topen2 by steps);
      eauto with lia.
Qed.

Lemma has_polarities_subst:
  forall T pols l,
    has_polarities T pols ->
    pclosed_mapping l type_var ->
    twfs l 0 ->
    has_polarities (psubstitute T l term_var) pols.
Proof.
  eauto using has_polarities_subst_aux.
Qed.

Lemma has_polarities_subst_erase:
  forall (X : nat) (Γ : map nat tree) (Ts : tree) (ρ : interpretation) l pols,
    is_annotated_type Ts ->
    has_polarities (topen 0 Ts (fvar X type_var)) pols ->
    satisfies (reducible_values ρ) (erase_context Γ) l ->
    has_polarities (topen 0 (psubstitute (erase_type Ts) l term_var) (fvar X type_var)) pols.
Proof.
  steps.
  apply has_polarities_erase in H0;
    repeat step || rewrite erase_type_topen in * by steps; eauto 2 with annot step_tactic.
  rewrite substitute_topen2; steps; eauto with twf.
  apply has_polarities_subst; steps; eauto with fv twf.
Qed.