Require Import compcert.common.Memory.
Require Import compcert.common.AST.
Require Import compcert.common.Values. (*for val*)
Require Import concurrency.permissions.
Require Import Coq.ZArith.ZArith.
Require Import compcert.lib.Coqlib.

(** ** Various results about CompCert's memory model*)
Module MemoryLemmas.

  Global Notation "a # b" := (Maps.PMap.get b a) (at level 1).
  Transparent Mem.store.
  (*TODO: see if we can reuse that for gsoMem_obs_eq.*)
  (*TODO: maybe we don't need to open up the interface here*)
  Lemma store_contents_other:
    forall m m' b b' ofs ofs' v chunk
      (Hstore: Mem.store chunk m b ofs v = Some m')
      (Hstable: ~ Mem.perm m b' ofs' Cur Writable),
      Maps.ZMap.get ofs' (Mem.mem_contents m') # b' =
      Maps.ZMap.get ofs' (Mem.mem_contents m) # b'.
  Proof.
    intros.
    erewrite Mem.store_mem_contents; eauto.
    simpl.
    destruct (Pos.eq_dec b b') as [Heq | Hneq];
      [| by erewrite Maps.PMap.gso by auto].
    subst b'.
    rewrite Maps.PMap.gss.
    destruct (Z_lt_le_dec ofs' ofs) as [Hlt | Hge].
    erewrite Mem.setN_outside by (left; auto);
      by reflexivity.
    destruct (Z_lt_ge_dec
                ofs' (ofs + (size_chunk chunk)))
      as [Hlt | Hge'].
    (* case the two addresses coincide - contradiction*)
    apply Mem.store_valid_access_3 in Hstore.
    unfold Mem.valid_access in Hstore. simpl in Hstore.
    destruct Hstore as [Hcontra _].
    unfold Mem.range_perm in Hcontra.
    specialize (Hcontra ofs' (conj Hge Hlt));
      by exfalso.
    erewrite Mem.setN_outside by (right; rewrite size_chunk_conv in Hge';
                                    by rewrite encode_val_length);
      by auto.
  Qed.

  Transparent Mem.alloc.

  Lemma val_at_alloc_1:
    forall m m' sz nb b ofs
      (Halloc: Mem.alloc m 0 sz = (m', nb))
      (Hvalid: Mem.valid_block m b),
      Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m)) =
      Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m')).
  Proof.
    intros.
    unfold Mem.alloc in Halloc.
    inv Halloc.
    simpl.
    rewrite Maps.PMap.gso; auto.
    intro; subst. unfold Mem.valid_block in *.
    eapply Plt_strict; eauto.
  Qed.

  Lemma val_at_alloc_2:
    forall m m' sz nb ofs
      (Halloc: Mem.alloc m 0 sz = (m', nb)),
      Maps.ZMap.get ofs (Maps.PMap.get nb (Mem.mem_contents m')) = Undef.
  Proof.
    intros.
    unfold Mem.alloc in Halloc.
    inv Halloc.
    simpl.
    rewrite PMap.gss, ZMap.gi.
    reflexivity.
  Qed.

  (*stronger version of val_at_alloc_1*)
  Lemma val_at_alloc_3:
    forall m m' sz nb b ofs
      (Halloc: Mem.alloc m 0 sz = (m', nb))
      (Hvalid: b <> nb),
      Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m)) =
      Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m')).
  Proof.
    intros.
    unfold Mem.alloc in Halloc.
    inv Halloc.
    simpl.
    rewrite Maps.PMap.gso; auto.
  Qed.

  Lemma permission_at_alloc_1:
    forall m m' lo hi nb b ofs
      (Halloc: Mem.alloc m lo hi = (m', nb))
      (Hvalid: Mem.valid_block m b),
    forall k, permissions.permission_at m b ofs k =
         permissions.permission_at m' b ofs k.
  Proof.
    intros.
    unfold Mem.alloc in Halloc.
    inv Halloc.
    unfold permissions.permission_at. simpl.
    rewrite Maps.PMap.gso; auto.
    intro; subst. unfold Mem.valid_block in *.
    eapply Plt_strict; eauto.
  Qed.

  Lemma permission_at_alloc_2:
    forall m m' lo sz nb ofs
      (Halloc: Mem.alloc m lo sz = (m', nb))
      (Hofs: (lo <= ofs < sz)%Z),
      forall k, permissions.permission_at m' nb ofs k = Some Freeable.
  Proof.
    intros.
    eapply Memory.alloc_access_same in Halloc; eauto.
  Qed.

  Lemma permission_at_alloc_3:
    forall m m' lo sz nb ofs
      (Halloc: Mem.alloc m lo sz = (m', nb))
      (Hofs: (ofs < lo \/ ofs >= sz)%Z),
      forall k, permissions.permission_at m' nb ofs k = None.
  Proof.
    intros.
    pose proof (Mem.fresh_block_alloc _ _ _ _ _ Halloc) as Hinvalid.
    apply Mem.nextblock_noaccess with (ofs := ofs) (k := k) in Hinvalid.
    unfold permission_at.
    eapply Memory.alloc_access_other with (b' := nb) (k := k) in Halloc;
      unfold Memory.access_at, permission_at in *; simpl in *; eauto.
    rewrite <- Halloc;
      now auto.
  Qed.

  Lemma permission_at_alloc_4:
    forall m m' lo hi nb b ofs
      (Halloc: Mem.alloc m lo hi = (m', nb))
      (Hb: b <> nb),
    forall k, permissions.permission_at m b ofs k =
         permissions.permission_at m' b ofs k.
  Proof.
    intros.
    unfold Mem.alloc in Halloc.
    inv Halloc.
    unfold permissions.permission_at. simpl.
    rewrite Maps.PMap.gso; auto.
  Qed.

  Lemma permission_at_free_1 :
    forall m m' (lo hi : Z) b b' ofs'
      (Hfree: Mem.free m b lo hi = Some m')
      (Hnon_freeable: ~ Mem.perm m b' ofs' Cur Freeable),
    forall k : perm_kind,
      permission_at m b' ofs' k = permission_at m' b' ofs' k.
  Proof.
    intros.
    pose proof (Mem.free_result _ _ _ _ _ Hfree) as Hfree'.
    subst.
    unfold Mem.unchecked_free. unfold permission_at. simpl.
    destruct (Pos.eq_dec b' b); subst.
    - destruct (zle lo ofs' && zlt ofs' hi) eqn:Hintv.
      + exfalso.
        apply andb_true_iff in Hintv.
        destruct Hintv as [Hle Hlt].
        destruct (zle lo ofs'); simpl in *; auto.
        destruct (zlt ofs' hi); simpl in *; auto.
        apply Mem.free_range_perm in Hfree.
        unfold Mem.range_perm in Hfree.
        specialize (Hfree ofs' (conj l l0)).
        auto.
      + rewrite Maps.PMap.gss.
        rewrite Hintv.
        reflexivity.
    - rewrite Maps.PMap.gso;
      auto.
  Qed.

  Lemma permission_at_free_2 :
    forall m m' (lo hi : Z) b b' ofs'
      (Hfree: Mem.free m b lo hi = Some m')
      (Hb: b <> b'),
    forall k : perm_kind,
      permission_at m b' ofs' k = permission_at m' b' ofs' k.
  Proof.
    intros.
    pose proof (Mem.free_result _ _ _ _ _ Hfree) as Hfree'.
    subst.
    unfold Mem.unchecked_free. unfold permission_at. simpl.
    destruct (Pos.eq_dec b' b); subst.
    - exfalso; now auto.
    - rewrite Maps.PMap.gso;
        auto.
  Qed.

  Lemma permission_at_free_list_1:
    forall m m' l b ofs
      (Hfree: Mem.free_list m l = Some m')
      (Hnon_freeable: ~ Mem.perm m b ofs Cur Freeable),
    forall k : perm_kind,
      permission_at m b ofs k = permission_at m' b ofs k.
  Proof.
    intros m m' l.
    generalize dependent m.
    induction l; intros.
    - simpl in Hfree; inv Hfree; reflexivity.
    - simpl in Hfree. destruct a, p.
      destruct (Mem.free m b0 z0 z) eqn:Hfree'; try discriminate.
      pose proof Hfree' as Hfree''.
      eapply permission_at_free_1 with (k := k) in Hfree'; eauto.
      eapply permission_at_free_1 with (k := Cur) in Hfree''; eauto.
      rewrite Hfree'. eapply IHl; eauto.
      unfold Mem.perm in *. unfold permission_at in *.
      rewrite <- Hfree''. assumption.
  Qed.

  Lemma mem_free_contents:
    forall m m2 sz b
      (Hfree: Mem.free m b 0 sz = Some m2),
    forall b' ofs,
      Maps.ZMap.get ofs (Maps.PMap.get b' (Mem.mem_contents m)) =
      Maps.ZMap.get ofs (Maps.PMap.get b' (Mem.mem_contents m2)).
  Proof.
    intros.
    apply Mem.free_result in Hfree.
    subst; unfold Mem.unchecked_free.
    reflexivity.
  Qed.

  Lemma mem_store_max:
    forall chunk b ofs v m m',
      Mem.store chunk m b ofs v = Some m' ->
      forall b' ofs',
        (getMaxPerm m) # b' ofs' = (getMaxPerm m') # b' ofs'.
  Proof.
    intros.
    unfold Mem.store in *.
    destruct (Mem.valid_access_dec m chunk b ofs Writable); try discriminate.
    inversion H; subst.
    do 2 rewrite getMaxPerm_correct.
    reflexivity.
  Qed.

  Lemma mem_storebytes_cur :
    forall b (ofs : Z) bytes (m m' : mem),
      Mem.storebytes m b ofs bytes = Some m' ->
      forall (b' : positive) (ofs' : Z),
        (getCurPerm m) !! b' ofs' = (getCurPerm m') !! b' ofs'.
  Proof.
    intros.
    Transparent Mem.storebytes.
    unfold Mem.storebytes in *.
    destruct (Mem.range_perm_dec m b ofs (ofs + Z.of_nat (length bytes)) Cur
                                 Writable); try discriminate.
    inversion H; subst.
    do 2 rewrite getCurPerm_correct.
    reflexivity.
  Qed.

  Lemma mem_store_cur:
    forall chunk b ofs v m m',
      Mem.store chunk m b ofs v = Some m' ->
      forall b' ofs',
        (getCurPerm m) # b' ofs' = (getCurPerm m') # b' ofs'.
  Proof.
    intros.
    apply Mem.store_storebytes in H.
    eapply mem_storebytes_cur; eauto.
  Qed.

  Lemma mem_storev_store:
    forall chunk ptr v m m',
      Mem.storev chunk m ptr v = Some m' ->
      exists b ofs, ptr = Vptr b ofs /\
               Mem.store chunk m b (Integers.Int.intval ofs) v = Some m'.
  Proof.
    intros.
    destruct ptr; try discriminate.
    simpl in H.
    do 2 eexists; split; eauto.
  Qed.

  Lemma load_valid_block:
    forall (m : mem) b ofs chunk v,
      Mem.load chunk m b ofs = Some v ->
      Mem.valid_block m b.
  Proof.
    intros m b ofs chunk v Hload.
    apply Mem.load_valid_access in Hload.
    apply Mem.valid_access_valid_block with (chunk:=chunk) (ofs:= ofs).
    eapply Mem.valid_access_implies; eauto.
    constructor.
  Qed.

  Definition max_inv mf := forall b ofs, Mem.valid_block mf b ->
                                    permission_at mf b ofs Max = Some Freeable.

  Lemma max_inv_store:
    forall m m' chunk b ofs v pmap
      (Hlt: permMapLt pmap (getMaxPerm m))
      (Hmax: max_inv m)
      (Hstore: Mem.store chunk (restrPermMap Hlt) b ofs v = Some m'),
      max_inv m'.
  Proof.
    intros.
    intros b0 ofs0 Hvalid0.
    unfold permission_at.
    erewrite Mem.store_access; eauto.
    assert (H := restrPermMap_Max Hlt b0 ofs0).
    eapply Mem.store_valid_block_2 in Hvalid0; eauto.
    erewrite restrPermMap_valid in Hvalid0.
    specialize (Hmax b0 ofs0 Hvalid0).
    unfold permission_at in H.
    rewrite H.
    rewrite getMaxPerm_correct;
      by assumption.
  Qed.

   Lemma sim_valid_access:
    forall (mf m1f : mem)
      (b1 b2 : block) (ofs : Z)
      (Hm1f: m1f = makeCurMax mf)
      (HmaxF: max_inv mf)
      (Hvalidb2: Mem.valid_block mf b2)
      (Halign: (4 | ofs)%Z),
      Mem.valid_access m1f Mint32 b2 ofs Freeable.
  Proof.
    unfold Mem.valid_access. simpl. split; try assumption.
    unfold Mem.range_perm. intros ofs0 Hbounds. subst m1f.
    specialize (HmaxF _ ofs0 Hvalidb2).
    unfold Mem.perm.
    assert (Hperm := makeCurMax_correct mf b2 ofs0 Cur).
    rewrite HmaxF in Hperm.
    unfold permission_at in Hperm.
    unfold Mem.perm.
    rewrite <- Hperm.
    simpl;
      by constructor.
  Qed.

  Lemma setPermBlock_lt:
    forall pmap m b ofs sz p
      (Hinv: max_inv m)
      (Hvalid: Mem.valid_block m b)
      (Hlt: permMapLt pmap (getMaxPerm m)),
      permMapLt (setPermBlock p b ofs pmap sz) (getMaxPerm m).
  Proof.
    intros.
    intros b' ofs'.
    specialize (Hlt b' ofs').
    destruct (Pos.eq_dec b b').
    - subst.
      destruct (Intv.In_dec ofs' (ofs, ofs + Z.of_nat sz)%Z).
      + erewrite setPermBlock_same by eauto.
        specialize (Hinv _ ofs' Hvalid).
        erewrite getMaxPerm_correct in *.
        erewrite Hinv in *.
        simpl; destruct p; eauto using perm_order.
      + destruct sz. simpl.
        assumption.
        erewrite setPermBlock_other_1.
        assumption.
        eapply Intv.range_notin in n; eauto.
        simpl. zify; omega.
    - erewrite setPermBlock_other_2 by eauto.
      assumption.
  Qed.

  Lemma setN_inside: forall (vl : list memval) (c : ZMap.t memval) (ofs0 ofs: Z),
      Intv.In ofs0 (ofs, (ofs + Z.of_nat (length vl))%Z) ->
      ZMap.get ofs0 (Mem.setN vl ofs c) = List.nth (Z.to_nat (ofs0 - ofs)%Z) vl Undef.
  Proof.
    intros vl.
    induction vl using rev_ind; intros.
    - unfold Intv.In in H.
      simpl in H. exfalso.
      now omega.
    - simpl in *.
      unfold Intv.In in H. simpl in H.
      rewrite Mem.setN_concat.
      simpl.
      rewrite ZMap.gsspec.
      destruct (ZIndexed.eq ofs0 (ofs + Z.of_nat (length vl))). subst.
      + assert ((Z.to_nat (ofs + Z.of_nat (length vl) - ofs)) = length vl)
          by (rewrite <- Z.add_sub_assoc;
              rewrite Zplus_minus, Nat2Z.id; reflexivity).
        rewrite H0.
        rewrite List.app_nth2.
        rewrite NPeano.Nat.sub_diag. reflexivity.
        omega.
      + rewrite List.app_length in H.
        simpl in H.
        rewrite NPeano.Nat.add_1_r in H.
        simpl in H.
        rewrite Zpos_P_of_succ_nat in H.
        apply threads_lemmas.lt_succ_neq in H; eauto.
        rewrite List.app_nth1.
        eapply IHvl. auto.
        destruct H.
        clear - H0 H.
        zify.
        erewrite Z2Nat.id in * by omega.
        omega.
  Qed.

End MemoryLemmas.


Require Import Bedrock.Platform.AutoSep Bedrock.Platform.Malloc Bedrock.Platform.tests.Abort Bedrock.Platform.Bootstrap.

Module Type S.
  Parameter heapSize : nat.
End S.

Module Make(M : S).
Import M.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 0.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 0.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [Abort.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREonly[_] 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREonly[_] mallocHeap 0];;

        Goto "test"!"main"
      end
    }}.

  Theorem ok : moduleOk boot.
    vcgen; abstract genesis.
  Qed.

  Definition m0 := link Malloc.m boot.
  Definition m1 := link Abort.m m0.

  Lemma ok0 : moduleOk m0.
    link Malloc.ok ok.
  Qed.

  Lemma ok1 : moduleOk m1.
    link Abort.ok ok0.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $ (size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok1.
  Qed.
End boot.

End Make.


Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.spec_salsa.
Require Import sha.general_lemmas.
Require Import tweetnacl20140427.tweetNaclBase.

(*from verif_ld_st*)
Lemma Byte_unsigned_range_32 b: 0 <= Byte.unsigned b <= Int.max_unsigned.
Proof. destruct (Byte.unsigned_range_2 b). specialize Byte_Int_max_unsigned; omega. Qed.

Lemma vn_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_vn vn_spec.
Proof.
start_function.
forward.
assert_PROP (n = Zlength (map Vint (map Int.repr (map Byte.unsigned xcont))) /\
             n = Zlength (map Vint (map Int.repr (map Byte.unsigned ycont)))) as LEN by entailer!.
destruct LEN as [LenX LenY].
assert (ZWS: Int.zwordsize = 32) by reflexivity.
assert (BWS: Byte.zwordsize = 8) by reflexivity.
forward_for_simple_bound n
(EX i:Z, EX d:_,
  (PROP  (Byte.eq d Byte.zero = if list_eq_dec Byte.eq_dec (sublist 0 i xcont) (sublist 0 i ycont) then true else false)
   LOCAL (temp _d (Vint (Int.repr (Byte.unsigned d)));
          temp _x x; temp _y y; temp _n (Vint (Int.repr n)))
   SEP (data_at xsh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
   data_at ysh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y))).
{ Exists Byte.zero. entailer!.  }
{ Intros. rename H0 into I. rename H1 into B. rename x0 into b.
  rewrite 3 Zlength_map in LenX, LenY.
  forward.
  { entailer!.
    rewrite Znth_map with (d':=Byte.zero); trivial.
    rewrite Int.unsigned_repr. apply Byte.unsigned_range_2. apply Byte_unsigned_range_32. }
  rewrite Znth_map with (d':=Byte.zero) by omega.
  forward.
  { entailer!.
    rewrite Znth_map with (d':=Byte.zero) by omega.
    rewrite Int.unsigned_repr. apply Byte.unsigned_range_2. apply Byte_unsigned_range_32. }
  rewrite Znth_map with (d':=Byte.zero) by omega.
  forward. entailer!. clear H3 H6 H4 H7.
  rewrite <- (sublist_rejoin 0 i (i+1) xcont), sublist_len_1 with (d:=Byte.zero); try omega.
  rewrite <- (sublist_rejoin 0 i (i+1) ycont), sublist_len_1 with (d:=Byte.zero); try omega.
  rewrite list_eq_dec_app. 2: rewrite 2 Zlength_sublist; trivial; omega. 2: rewrite 2 Zlength_cons, Zlength_nil; trivial.
  rewrite <- B. unfold Int.xor.
  remember (list_eq_dec Byte.eq_dec [Znth i xcont Byte.zero] [Znth i ycont Byte.zero]).  simpl.
  rewrite or_repr. clear H0 H1 H2 (*H4*) H5 (*H7*) SH SH0 PNx PNy Heqs.
(*  rewrite 2 zero_ext_inrange by
      (rewrite Int.unsigned_repr; [ apply Byte.unsigned_range_2 | apply byte_unsigned_range_int_unsigned_max]).*)
  rewrite 2 Int.unsigned_repr by apply byte_unsigned_range_int_unsigned_max.
  destruct (list_eq_dec Byte.eq_dec (sublist 0 i xcont) (sublist 0 i ycont)).
  + specialize (Byte.eq_spec b Byte.zero); rewrite B; intros; subst b; clear B.
    simpl. destruct s.
    - inv e0. rewrite H1, Z.lxor_nilpotent, Z.lor_0_r.
      Exists Byte.zero. entailer.
    - destruct (Z_lxor_byte_neq (Znth i xcont Byte.zero) (Znth i ycont Byte.zero)) as [bb [BB HBB]].
      * intros N. apply n; rewrite N; trivial.
      * Exists bb; entailer!. split. apply Byte.eq_false; trivial.
        rewrite BB, Zlor_Byteor, Byte.or_zero_l; trivial.
  + destruct s.
    - inv e. rewrite H1, Z.lxor_nilpotent, Z.lor_0_r, andb_true_r.
      Exists b. entailer!.
    - destruct (Z_lxor_byte_neq (Znth i xcont Byte.zero) (Znth i ycont Byte.zero)) as [bb [BB HBB]].
      * intros N. apply n0; rewrite N; trivial.
      * rewrite BB, Zlor_Byteor, andb_false_r.
        Exists (Byte.or b bb). entailer!. apply Byte.eq_false. intros N.
        destruct (ByteOr_zero _ _ N). contradiction. }
apply extract_exists_pre; intros b.
forward. apply prop_right.
  rewrite ! Zlength_map in *. rewrite 2 sublist_same in H0; trivial.
  clear H1 H4 H6 H3 H2 H5 SH SH0 PNx PNy.
  destruct (list_eq_dec Byte.eq_dec xcont ycont).
  + specialize (Byte.eq_spec b Byte.zero). rewrite H0; intros; subst. reflexivity.
  + specialize (Byte.eq_spec b Byte.zero). rewrite H0; intros. clear - ZWS BWS H1.
    f_equal. unfold Int.sub.
    assert (Int.shru (Int.repr (Byte.unsigned b - 1)) (Int.repr 8) = Int.zero).
    - apply Int.same_bits_eq. rewrite ZWS; intros. rewrite Int.bits_zero, Int.bits_shru; try omega.
      rewrite (Int.unsigned_repr 8), ZWS. 2: rewrite int_max_unsigned_eq; omega.
      if_tac; trivial. rewrite Int.testbit_repr by omega. apply isbyteZ_testbit. 2: omega.
      destruct (Byte.unsigned_range b). replace Byte.modulus with 256 in H3 by reflexivity. split; try omega.
      destruct (zle 0 (Byte.unsigned b - 1)); trivial. elim H1; clear H1.
      assert (ZZ: Byte.unsigned b =0) by omega.
      apply initialize.zero_ext_inj. rewrite ZZ; reflexivity.
    - rewrite H, Int.and_zero; reflexivity.
Qed.

Lemma verify16_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_crypto_verify_16_tweet verify16_spec.
Proof.
start_function.
forward_call (x,y,16,xsh,ysh,xcont,ycont).
forward.
Qed.

Lemma verify32_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_crypto_verify_32_tweet verify32_spec.
Proof.
start_function.
forward_call (x,y,32,xsh,ysh,xcont,ycont).
forward.
Qed.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Require Import common.

Lemma pure1 (sz1l1 : nat) (sz2l1 : nat) (sz2 : nat) : (0) <= (sz1l1) -> (0) <= (((1) + (sz1l1)) + (sz2l1)) -> (0) <= (sz2) -> (0) <= (sz2l1) -> ((sz1l1) + (((1) + (sz2l1)) + (sz2))) = ((((1) + (sz1l1)) + (sz2l1)) + (sz2)). intros; hammer. Qed.
Hint Resolve pure1: ssl_pure.
Lemma pure2 (sz2l1 : nat) (sz2 : nat) (sz1l1 : nat) : (0) <= (sz1l1) -> (0) <= (((1) + (sz1l1)) + (sz2l1)) -> (0) <= (sz2) -> (0) <= (sz2l1) -> (0) <= (((1) + (sz2l1)) + (sz2)). intros; hammer. Qed.
Hint Resolve pure2: ssl_pure.
Lemma pure3 (hi2l1 : nat) (hi1l1 : nat) (lo2 : nat) (v1 : nat) (lo2l1 : nat) (vl11 : nat) : ((if (hi2l1) <= (vl11) then vl11 else hi2l1)) <= (v1) -> (vl11) <= (lo2l1) -> (0) <= (vl11) -> (v1) <= (lo2) -> (0) <= (v1) -> (vl11) <= (7) -> (hi1l1) <= (vl11) -> (v1) <= (7) -> (hi2l1) <= (v1).
  (* intros; hammer. *)
  intros.
  intros.
  destruct (hi2l1 <= vl11) eqn:H7; last by done.
  exact (leq_trans H7 H).
Qed.
Hint Resolve pure3: ssl_pure.
Lemma pure4 (hi2l1 : nat) (hi1l1 : nat) (lo2 : nat) (v1 : nat) (lo2l1 : nat) (vl11 : nat) : ((if (hi2l1) <= (vl11) then vl11 else hi2l1)) <= (v1) -> (vl11) <= (lo2l1) -> (0) <= (vl11) -> (v1) <= (lo2) -> (0) <= (v1) -> (vl11) <= (7) -> (hi1l1) <= (vl11) -> (v1) <= (7) -> (vl11) <= ((if (v1) <= (lo2l1) then v1 else lo2l1)).
  (* intros; hammer. *)
  intros.
  destruct (v1 <= lo2l1) eqn:H7; last by done.
  destruct (hi2l1 <= vl11) eqn:H8; first by done.
  apply negbT in H8.
  rewrite -ltnNge in H8.
  apply ltnW in H8.
  exact (leq_trans H8 H).
Qed.
Hint Resolve pure4: ssl_pure.

Definition bst_right_rotate_type :=
  forall (vprogs : ptr * ptr),
  {(vghosts : nat * nat * nat * nat * ptr * nat * nat * ptr * nat * ptr)},
  STsep (
    fun h =>
      let: (x, retv) := vprogs in
      let: (sz1, sz2, v, hi1, l, lo2, lo1, r, hi2, unused) := vghosts in
      exists h_bst_lsz1lo1hi1_a h_bst_rsz2lo2hi2_b,
      (0) <= (sz1) /\ (0) <= (sz2) /\ (0) <= (v) /\ (hi1) <= (v) /\ ~~ ((l) == (null)) /\ (v) <= (7) /\ (v) <= (lo2) /\ h = retv :-> (unused) \+ x :-> (v) \+ x .+ 1 :-> (l) \+ x .+ 2 :-> (r) \+ h_bst_lsz1lo1hi1_a \+ h_bst_rsz2lo2hi2_b /\ bst l sz1 lo1 hi1 h_bst_lsz1lo1hi1_a /\ bst r sz2 lo2 hi2 h_bst_rsz2lo2hi2_b,
    [vfun (_: unit) h =>
      let: (x, retv) := vprogs in
      let: (sz1, sz2, v, hi1, l, lo2, lo1, r, hi2, unused) := vghosts in
      exists sz3 sz4 v3 hi3 lo4 l3 lo3 hi4 y,
      exists h_bst_l3sz3lo3hi3_2 h_bst_xsz4lo4hi4_3,
      (0) <= (sz3) /\ (0) <= (sz4) /\ (0) <= (v3) /\ (hi3) <= (v3) /\ ((sz3) + (sz4)) == ((sz1) + (sz2)) /\ (v3) <= (7) /\ (v3) <= (lo4) /\ h = retv :-> (y) \+ y :-> (v3) \+ y .+ 1 :-> (l3) \+ y .+ 2 :-> (x) \+ h_bst_l3sz3lo3hi3_2 \+ h_bst_xsz4lo4hi4_3 /\ bst l3 sz3 lo3 hi3 h_bst_l3sz3lo3hi3_2 /\ bst x sz4 lo4 hi4 h_bst_xsz4lo4hi4_3
    ]).

Program Definition bst_right_rotate : bst_right_rotate_type :=
  Fix (fun (bst_right_rotate : bst_right_rotate_type) vprogs =>
    let: (x, retv) := vprogs in
    Do (
      unused1 <-- @read ptr retv;
      v1 <-- @read nat x;
      l1 <-- @read ptr (x .+ 1);
      r1 <-- @read ptr (x .+ 2);
      if (l1) == (null)
      then
        ret tt
      else
        vl11 <-- @read nat l1;
        ll11 <-- @read ptr (l1 .+ 1);
        rl11 <-- @read ptr (l1 .+ 2);
        (l1 .+ 2) ::= x;;
        (x .+ 1) ::= rl11;;
        retv ::= l1;;
        ret tt
    )).
Obligation Tactic := intro; move=>[x retv]; ssl_program_simpl.
Next Obligation.
ssl_ghostelim_pre.
move=>[[[[[[[[[sz1 sz2] v] hi1] l] lo2] lo1] r] hi2] unused].
ex_elim h_bst_lsz1lo1hi1_a h_bst_rsz2lo2hi2_b.
move=>[phi_self0] [phi_self1] [phi_self2] [phi_self3] [phi_self4] [phi_self5] [phi_self6].
move=>[sigma_self].
subst h_self.
move=>[H_bst_lsz1lo1hi1_a H_bst_rsz2lo2hi2_b].
ssl_ghostelim_post.
ssl_read retv.
try rename unused into unused1.
ssl_read x.
try rename v into v1.
ssl_read (x .+ 1).
try rename l into l1.
try rename h_bst_lsz1lo1hi1_a into h_bst_l1sz1lo1hi1_a.
try rename H_bst_lsz1lo1hi1_a into H_bst_l1sz1lo1hi1_a.
ssl_read (x .+ 2).
try rename r into r1.
try rename h_bst_rsz2lo2hi2_b into h_bst_r1sz2lo2hi2_b.
try rename H_bst_rsz2lo2hi2_b into H_bst_r1sz2lo2hi2_b.
ssl_open ((l1) == (null)) H_bst_l1sz1lo1hi1_a.
move=>[phi_bst_l1sz1lo1hi1_a0] [phi_bst_l1sz1lo1hi1_a1] [phi_bst_l1sz1lo1hi1_a2].
move=>[sigma_bst_l1sz1lo1hi1_a].
subst h_bst_l1sz1lo1hi1_a.
ssl_inconsistency.
ex_elim sz1l1 sz2l1 vl1 hi2l1 hi1l1.
ex_elim lo1l1 lo2l1 ll1 rl1.
ex_elim h_bst_ll1sz1l1lo1l1hi1l1_0l1 h_bst_rl1sz2l1lo2l1hi2l1_1l1.
move=>[phi_bst_l1sz1lo1hi1_a0] [phi_bst_l1sz1lo1hi1_a1] [phi_bst_l1sz1lo1hi1_a2] [phi_bst_l1sz1lo1hi1_a3] [phi_bst_l1sz1lo1hi1_a4] [phi_bst_l1sz1lo1hi1_a5] [phi_bst_l1sz1lo1hi1_a6] [phi_bst_l1sz1lo1hi1_a7] [phi_bst_l1sz1lo1hi1_a8].
move=>[sigma_bst_l1sz1lo1hi1_a].
subst h_bst_l1sz1lo1hi1_a.
move=>[H_bst_ll1sz1l1lo1l1hi1l1_0l1 H_bst_rl1sz2l1lo2l1hi2l1_1l1].
try rename h_bst_l1sz1lo1hi1_a into h_bst_l1sz1lo1hi2l1vl1vl1hi2l1_a.
try rename H_bst_l1sz1lo1hi1_a into H_bst_l1sz1lo1hi2l1vl1vl1hi2l1_a.
try rename h_bst_l1sz1lo1hi2l1vl1vl1hi2l1_a into h_bst_l1sz1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a.
try rename H_bst_l1sz1lo1hi2l1vl1vl1hi2l1_a into H_bst_l1sz1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a.
try rename h_bst_l1sz1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a into h_bst_l1sz1l1sz2l1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a.
try rename H_bst_l1sz1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a into H_bst_l1sz1l1sz2l1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a.
ssl_read l1.
try rename vl1 into vl11.
try rename h_bst_l1sz1l1sz2l1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a into h_bst_l1sz1l1sz2l1vl11lo1l1vl11lo1l1hi2l1vl11vl11hi2l1_a.
try rename H_bst_l1sz1l1sz2l1vl1lo1l1vl1lo1l1hi2l1vl1vl1hi2l1_a into H_bst_l1sz1l1sz2l1vl11lo1l1vl11lo1l1hi2l1vl11vl11hi2l1_a.
ssl_read (l1 .+ 1).
try rename ll1 into ll11.
try rename h_bst_ll1sz1l1lo1l1hi1l1_0l1 into h_bst_ll11sz1l1lo1l1hi1l1_0l1.
try rename H_bst_ll1sz1l1lo1l1hi1l1_0l1 into H_bst_ll11sz1l1lo1l1hi1l1_0l1.
ssl_read (l1 .+ 2).
try rename rl1 into rl11.
try rename h_bst_rl1sz2l1lo2l1hi2l1_1l1 into h_bst_rl11sz2l1lo2l1hi2l1_1l1.
try rename H_bst_rl1sz2l1lo2l1hi2l1_1l1 into H_bst_rl11sz2l1lo2l1hi2l1_1l1.
try rename h_bst_xsz4lo4hi4_3 into h_bst_xsz4lo4hi21xv2xv2xhi21x_3.
try rename H_bst_xsz4lo4hi4_3 into H_bst_xsz4lo4hi21xv2xv2xhi21x_3.
try rename h_bst_xsz4lo4hi21xv2xv2xhi21x_3 into h_bst_xsz4v2xlo11xv2xlo11xhi21xv2xv2xhi21x_3.
try rename H_bst_xsz4lo4hi21xv2xv2xhi21x_3 into H_bst_xsz4v2xlo11xv2xlo11xhi21xv2xv2xhi21x_3.
try rename h_bst_xsz4v2xlo11xv2xlo11xhi21xv2xv2xhi21x_3 into h_bst_xsz11xsz21xv2xlo11xv2xlo11xhi21xv2xv2xhi21x_3.
try rename H_bst_xsz4v2xlo11xv2xlo11xhi21xv2xv2xhi21x_3 into H_bst_xsz11xsz21xv2xlo11xv2xlo11xhi21xv2xv2xhi21x_3.
try rename h_bst_l3sz3lo3hi3_2 into h_bst_ll11sz1l1lo1l1hi1l1_0l1.
try rename H_bst_l3sz3lo3hi3_2 into H_bst_ll11sz1l1lo1l1hi1l1_0l1.
try rename h_bst_l2xsz11xlo11xhi11x_0x into h_bst_rl11sz2l1lo2l1hi2l1_1l1.
try rename H_bst_l2xsz11xlo11xhi11x_0x into H_bst_rl11sz2l1lo2l1hi2l1_1l1.
try rename h_bst_xsz11xsz21xv2xlo11xv2xlo11xhi21xv2xv2xhi21x_3 into h_bst_xsz11xsz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3.
try rename H_bst_xsz11xsz21xv2xlo11xv2xlo11xhi21xv2xv2xhi21x_3 into H_bst_xsz11xsz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3.
try rename h_bst_xsz11xsz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3 into h_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3.
try rename H_bst_xsz11xsz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3 into H_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3.
try rename h_bst_r2xsz21xlo21xhi21x_1x into h_bst_r1sz2lo2hi2_b.
try rename H_bst_r2xsz21xlo21xhi21x_1x into H_bst_r1sz2lo2hi2_b.
try rename h_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3 into h_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi2v2xv2xhi2_3.
try rename H_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi21xv2xv2xhi21x_3 into H_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi2v2xv2xhi2_3.
try rename h_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi2v2xv2xhi2_3 into h_bst_xsz2l1sz2v2xlo2l1v2xlo2l1hi2v2xv2xhi2_3.
try rename H_bst_xsz2l1sz21xv2xlo2l1v2xlo2l1hi2v2xv2xhi2_3 into H_bst_xsz2l1sz2v2xlo2l1v2xlo2l1hi2v2xv2xhi2_3.
ssl_write (l1 .+ 2).
ssl_write_post (l1 .+ 2).
ssl_write (x .+ 1).
ssl_write_post (x .+ 1).
ssl_write retv.
ssl_write_post retv.
try rename h_bst_xsz2l1sz2v2xlo2l1v2xlo2l1hi2v2xv2xhi2_3 into h_bst_xsz2l1sz2v1lo2l1v1lo2l1hi2v1v1hi2_3.
try rename H_bst_xsz2l1sz2v2xlo2l1v2xlo2l1hi2v2xv2xhi2_3 into H_bst_xsz2l1sz2v1lo2l1v1lo2l1hi2v1v1hi2_3.
ssl_emp;
exists (sz1l1), (((1) + (sz2l1)) + (sz2)), (vl11), (hi1l1), ((if (v1) <= (lo2l1) then v1 else lo2l1)), (ll11), (lo1l1), ((if (hi2) <= (v1) then v1 else hi2)), (l1);
exists (h_bst_ll11sz1l1lo1l1hi1l1_0l1);
exists (x :-> (v1) \+ x .+ 1 :-> (rl11) \+ x .+ 2 :-> (r1) \+ h_bst_rl11sz2l1lo2l1hi2l1_1l1 \+ h_bst_r1sz2lo2hi2_b);
sslauto.
shelve.
ssl_close 2;
exists (sz2l1), (sz2), (v1), (hi2), (hi2l1), (lo2l1), (lo2), (rl11), (r1), (h_bst_rl11sz2l1lo2l1hi2l1_1l1), (h_bst_r1sz2lo2hi2_b);
sslauto.
shelve.
shelve.
Unshelve.
ssl_frame_unfold.
ssl_frame_unfold.
ssl_frame_unfold.
Qed.


From iris.proofmode Require Import tactics.
From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.algebra Require Import base pagetable mem trans.
From HypVeri.rules Require Import rules_base mult.
From HypVeri.logrel Require Import logrel logrel_extra.
From HypVeri Require Import proofmode.
Import uPred.

Section ftlr_mult.
  Context `{hypconst:HypervisorConstants}.
  Context `{hypparams:!HypervisorParameters}.
  Context `{vmG: !gen_VMG Σ}.

Lemma ftlr_mult {i mem_acc_tx ai regs rxs ps_acc p_tx p_rx instr trans op1 op2} P:
  base_extra.is_total_gmap regs ->
  base_extra.is_total_gmap rxs ->
  {[p_tx; p_rx]} ⊆ ps_acc ->
  currently_accessible_in_trans_memory_pages i trans ⊆ ps_acc ∖ {[p_tx; p_rx]} ->
  p_rx ∉ ps_acc ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i trans ->
  p_tx ∉ ps_acc ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i trans ->
  regs !! PC = Some ai ->
  tpa ai ∈ ps_acc ->
  tpa ai ≠ p_tx ->
  dom mem_acc_tx = set_of_addr (ps_acc ∖ {[p_tx]}) ->
  tpa ai ∈ ps_acc ∖ {[p_tx]} ->
  mem_acc_tx !! ai = Some instr ->
  decode_instruction instr = Some (Mult op1 op2) ->
  ⊢ ▷ (∀ (a : gmap reg_name Word) (a0 : gset PID) (a1 : gmap Word transaction) (a2 : gmap VMID (option (Word * VMID))),
              ⌜base_extra.is_total_gmap a2⌝ -∗
              ⌜base_extra.is_total_gmap a⌝ -∗
              ⌜{[p_tx; p_rx]} ⊆ a0⌝ -∗
              ⌜currently_accessible_in_trans_memory_pages i a1 ⊆ a0 ∖ {[p_tx; p_rx]}⌝ -∗
              ⌜p_rx ∉ a0 ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i a1⌝ -∗
              ⌜p_tx ∉ a0 ∖ {[p_rx; p_tx]} ∪ accessible_in_trans_memory_pages i a1⌝ -∗
              ([∗ map] r↦w ∈ a, r @@ i ->r w) -∗
              TX@i:=p_tx -∗
              p_tx -@O> - ∗ p_tx -@E> true -∗
              mailbox.rx_page i p_rx -∗
              i -@A> a0 -∗
              pagetable_entries_excl_owned i (a0 ∖ {[p_rx; p_tx]} ∖ currently_accessible_in_trans_memory_pages i a1) -∗
              transaction_hpool_global_transferred a1 -∗
              transaction_pagetable_entries_transferred i a1 -∗
              retrievable_transaction_transferred i a1 -∗
              rx_state_get i a2 -∗
              rx_states_global (delete i a2) -∗
              transaction_pagetable_entries_owned i a1 -∗
              retrieved_transaction_owned i a1 -∗
              (∃ mem : lang.mem, memory_pages (a0 ∪ (accessible_in_trans_memory_pages i a1)) mem) -∗
              (P a1 a2) -∗
              WP ExecI @ i {{ _, True }}) -∗
   ([∗ map] r↦w ∈ regs, r @@ i ->r w) -∗
   TX@i:=p_tx -∗
   p_tx -@O> - ∗ p_tx -@E> true -∗
   i -@A> ps_acc -∗
   pagetable_entries_excl_owned i (ps_acc ∖ {[p_rx; p_tx]} ∖ (currently_accessible_in_trans_memory_pages i trans)) -∗
   transaction_hpool_global_transferred trans -∗
   transaction_pagetable_entries_transferred i trans -∗
   retrievable_transaction_transferred i trans -∗
   rx_state_get i rxs -∗
   mailbox.rx_page i p_rx -∗
   rx_states_global (delete i rxs) -∗
   transaction_pagetable_entries_owned i trans -∗
   retrieved_transaction_owned i trans -∗
   (∃ mem1 : mem, memory_pages ((ps_acc ∪ (accessible_in_trans_memory_pages i trans)) ∖ ps_acc) mem1) -∗
   ([∗ map] k↦v ∈ mem_acc_tx, k ->a v) -∗
   (∃ mem2 : mem, memory_page p_tx mem2) -∗
   (P trans rxs) -∗
   SSWP ExecI @ i {{ bm, (if bm.1 then VMProp_holds i (1 / 2) else True) -∗ WP bm.2 @ i {{ _, True }} }}.
  Proof.
    iIntros (Htotal_regs Htotal_rxs Hsubset_mb Hsubset_acc Hnin_rx Hnin_tx Hlookup_PC Hin_ps_acc Hneq_ptx Hdom_mem_acc_tx Hin_ps_acc_tx Hlookup_mem_ai Heqn).
    iIntros "IH regs tx pgt_tx pgt_acc pgt_owned trans_hpool_global tran_pgt_transferred retri rx_state rx other_rx tran_pgt_owned
                 retri_owned mem_rest mem_acc_tx mem_tx P".
    destruct op1 as [| | n nle].
    {
      apply decode_instruction_valid in Heqn.
      inversion Heqn.
      unfold reg_valid_cond in *.
      exfalso.
      naive_solver.
    }
    {
      apply decode_instruction_valid in Heqn.
      inversion Heqn.
      unfold reg_valid_cond in *.
      exfalso.
      naive_solver.
    }
    pose proof (Htotal_regs (R n nle)) as [a_arg1 Hlookup_arg1].
    (* getting registers *)
    iDestruct ((reg_big_sepM_split_upd2 i Hlookup_PC Hlookup_arg1)
                with "[$regs]") as "(PC & r_arg1 & Hacc_regs)"; [done | done |].
    (* getting mem *)
    iDestruct (mem_big_sepM_split mem_acc_tx Hlookup_mem_ai with "[$mem_acc_tx]")
      as "[mem_instr Hacc_mem_acc_tx]".
    iApply (mult_word _ op2 (R n nle) with "[PC tx pgt_acc mem_instr r_arg1]"); iFrameAutoSolve.
    iNext. iIntros "(PC & mem_instr & pgt_acc & r_arg1 & tx) _".
    iDestruct ("Hacc_regs" with "[$PC $r_arg1]") as (regs') "[%Htotal_regs' regs]";iFrame.
    iDestruct ("Hacc_mem_acc_tx" with "mem_instr") as "mem_acc_tx".
    iApply ("IH" $! _ ps_acc trans _ Htotal_rxs Htotal_regs' Hsubset_mb Hsubset_acc Hnin_rx Hnin_tx with "regs tx pgt_tx rx pgt_acc pgt_owned
                       trans_hpool_global tran_pgt_transferred retri rx_state other_rx
                           tran_pgt_owned retri_owned [mem_rest mem_acc_tx mem_tx] P").
    {
      iDestruct (memory_pages_split_singleton' p_tx ps_acc with "[mem_acc_tx $mem_tx]") as "mem_acc". set_solver + Hsubset_mb.
      iExists mem_acc_tx;by iFrame "mem_acc_tx".
      iApply (memory_pages_split_diff' _ ps_acc with "[$mem_rest $mem_acc]").
      set_solver +.
    }
  Qed.

End ftlr_mult.


(****************************************************************************)
(* 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.Lists.List.
Require Import Coq.Vectors.Vector.
Require Import Cava.Arrow.Classes.Category Cava.Arrow.Classes.Arrow.
Require Import Cava.Arrow.Primitives.

Import ListNotations.
Import VectorNotations.
Import CategoryNotations.

Local Open Scope category_scope.
Local Open Scope arrow_scope.

(* Class CircuitLaws `(A: Arrow, ! ArrowCopy A, ! ArrowSwap A, ! ArrowDrop A) := {
  cancelr_unit_uncancelr {x}: @cancelr x >>> uncancelr =M= id;
  cancell_unit_uncancell {x}: @cancell _ _ A x >>> uncancell =M= id;
  uncancelr_cancelr {x}:      @uncancelr _ _ A x >>> cancelr =M= id;
  uncancell_cancell {x}:      @uncancell _ _ A x >>> cancell =M= id;

  drop_annhilates {x y} (f: x~>y): f >>> drop =M= drop;

  cancelr_unit_is_drop : @cancelr A unit =M= drop;
  cancell_unit_is_drop : @cancell A unit =M= drop;

  first_first   {x y z w} (f: x~>y) (g:y~>z): @first A x y w f >>> first g  =M= first (f >>> g);
  second_second {x y z w} (f: x~>y) (g:y~>z): @second A x y w f >>> second g  =M= second (f >>> g);

  swap_swap {x y}: @swap A _ x y >>> swap =M= id;

  first_id  {x w}: @first A x x w id  =M= id;
  second_id {x w}: @second A x x w id  =M= id;

  first_f  {x y w} (f: x~>y) (g:x~>y): f =M= g -> @first A x y w f =M= first g;
  second_f {x y w} (f: x~>y) (g:x~>y): f =M= g -> @second A x y w f =M= second g;
}. *)

Notation arrow_input x := (arrow_input (object:=Kind) (unit:=Unit) (product:=Tuple) x).
Notation arrow_output x := (arrow_output (object:=Kind) (unit:=Unit) (product:=Tuple) x).

(* Single clock circuit *)
Inductive Circuit: Kind -> Kind -> Type :=
  | Structural: forall (x: ArrowStructure), Circuit (arrow_input x) (arrow_output x)
  | Primitive: forall (x: CircuitPrimitive), Circuit (primitive_input x) (primitive_output x)

  (* contains subcircuits *)
  | Composition: forall x y z, Circuit x y -> Circuit y z -> Circuit x z
  | First: forall x y z, Circuit x y -> Circuit (Tuple x z) (Tuple y z)
  | Second: forall x y z, Circuit x y -> Circuit (Tuple z x) (Tuple z y)
  | Loopr: forall x y z, Circuit (Tuple x z) (Tuple y z) -> Circuit x y
  | Loopl: forall x y z, Circuit (Tuple z x) (Tuple z y) -> Circuit x y

  | Delay: forall x, Circuit x x

  | RewriteTy: forall x y, Circuit x y
  .

Instance CircuitCat : Category Kind := {
  morphism X Y := Circuit X Y;
  id X := Structural (Id X);
  compose X Y Z f g := Composition X Y Z g f;
}.

Instance CircuitArrow : Arrow Kind CircuitCat Unit Tuple := {
  first  f := First f;
  second f := Second f;
  assoc   x y z := Structural (Assoc x y z);
  unassoc x y z := Structural (Unassoc x y z);
  cancelr  x := Structural (Cancelr x);
  cancell  x := Structural (Cancell x);
  uncancell x := Structural (Uncancell x);
  uncancelr x := Structural (Uncancelr x);
}.

Instance CircuitArrowDrop : ArrowDrop CircuitArrow := { drop _ := Structural (Drop _); }.
Instance CircuitArrowSwap : ArrowSwap CircuitArrow := { swap _ _ := Structural (Swap _ _); }.
Instance CircuitArrowCopy : ArrowCopy CircuitArrow := { copy _ := Structural (Copy _); }.
Instance CircuitArrowLoop : ArrowLoop CircuitArrow := { loopl := Loopl; loopr := Loopr; }.
Instance CircuitArrowSTKC : ArrowSTKC CircuitArrow := { }.

Ltac match_primitive X :=
  match X with
  | (Circuit _ _ _) => idtac
  end.

Ltac match_compose X :=
  match X with
  | (Composition _ _ ?Y ?Z) => idtac
  end.

Definition high : Unit ~> Bit := Primitive (P0 (Constant Bit true)).
Definition low : Unit ~> Bit := Primitive (P0 (Constant Bit false)).


Require Import Coq.Strings.Ascii.
Require Import Coq.ZArith.ZArith.

Require Import ByteData.
Require Import DiskSubset.
Require Import Fetch.
Require Import File.
Require Import FileData.

Local Open Scope bool.
Local Open Scope char.
Local Open Scope N.

Definition isJpeg (file: File) (disk: Disk) :=
     file @[  0 | disk ] = Found "255"
  /\ file @[  1 | disk ] = Found "216"
  /\ file @[- 2 | disk ] = Found "255"
  /\ file @[- 1 | disk ] = Found "217".

Definition isJpeg_compute (file: File) (disk: Disk) :=
     Byte.feqb (file @[  0 | disk ]) (Found "255")
  && Byte.feqb (file @[  1 | disk ]) (Found "216")
  && Byte.feqb (file @[- 2 | disk ]) (Found "255")
  && Byte.feqb (file @[- 1 | disk ]) (Found "217").

Lemma isJpeg_reflection (file: File) (disk: Disk) :
  isJpeg_compute file disk = true -> isJpeg file disk.
Proof.
  intros. unfold isJpeg_compute in H. unfold isJpeg.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  split. apply Byte.feqb_reflection. auto.
  split. apply Byte.feqb_reflection. auto.
  split. apply Byte.feqb_reflection. auto.
  apply Byte.feqb_reflection. auto.
Qed.

Definition isJpeg_subset:
  forall (sub super: Disk) (file: File),
    sub ⊆ super ->
      isJpeg file sub -> isJpeg file super.
Proof.
  intros sub super file subset.
  unfold isJpeg.
  intros H. destruct H as [H0 [H1 [Hn2 Hn1]]].
  split. apply fetchByte_subset with (1:=subset). auto.
  split. apply fetchByte_subset with (1:=subset). auto.
  split. apply fetchByte_subset_neg with (1:=subset). auto.
         apply fetchByte_subset_neg with (1:=subset). auto.
Qed.

Definition isGzip (file: File) (disk: Disk) :=
     file @[ 0 | disk ] = Found "031"
  /\ file @[ 1 | disk ] = Found "139"
  /\ file @[ 2 | disk ] = Found "008".

Definition isGzip_compute (file: File) (disk: Disk) :=
     Byte.feqb (file @[ 0 | disk ]) (Found "031")
  && Byte.feqb (file @[ 1 | disk ]) (Found "139")
  && Byte.feqb (file @[ 2 | disk ]) (Found "008").

Lemma isGzip_reflection (file: File) (disk: Disk) :
  isGzip_compute file disk = true -> isGzip file disk.
Proof.
  intros. unfold isGzip_compute in H. unfold isGzip.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  split. apply Byte.feqb_reflection. auto.
  split. apply Byte.feqb_reflection. auto.
  apply Byte.feqb_reflection. auto.
Qed.

Definition isGzip_subset:
  forall (sub super: Disk) (file: File),
    sub ⊆ super ->
      isGzip file sub -> isGzip file super.
Proof.
  intros sub super file subset.
  unfold isGzip.
  intros H. destruct H as [H0 [H1 H2]].
  split. apply fetchByte_subset with (1:=subset). auto.
  split. apply fetchByte_subset with (1:=subset). auto.
         apply fetchByte_subset with (1:=subset). auto.
Qed.

Definition isElf (file: File) (disk: Disk) :=
     file @[ 0 | disk ] = Found "127"
  /\ file @[ 1 | disk ] = Found "E"
  /\ file @[ 2 | disk ] = Found "L"
  /\ file @[ 3 | disk ] = Found "F".

Definition isElf_compute (file: File) (disk: Disk) :=
     Byte.feqb (file @[ 0 | disk ]) (Found "127")
  && Byte.feqb (file @[ 1 | disk ]) (Found "E")
  && Byte.feqb (file @[ 2 | disk ]) (Found "L")
  && Byte.feqb (file @[ 3 | disk ]) (Found "F").

Lemma isElf_reflection (file: File) (disk: Disk) :
  isElf_compute file disk = true -> isElf file disk.
Proof.
  intros. unfold isElf_compute in H. unfold isElf.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  split. apply Byte.feqb_reflection. auto.
  split. apply Byte.feqb_reflection. auto.
  split. apply Byte.feqb_reflection. auto.
  apply Byte.feqb_reflection. auto.
Qed.

Definition isElf_subset:
  forall (sub super: Disk) (file: File),
    sub ⊆ super ->
      isElf file sub -> isElf file super.
Proof.
  intros sub super file subset.
  unfold isElf.
  intros H. destruct H as [H0 [H1 [H2 H3]]].
  split. apply fetchByte_subset with (1:=subset). auto.
  split. apply fetchByte_subset with (1:=subset). auto.
  split. apply fetchByte_subset with (1:=subset). auto.
         apply fetchByte_subset with (1:=subset). auto.
Qed.

Lemma jpeg_is_not_gzip : forall (file: File) (disk: Disk),
  (isJpeg file disk) -> ~ (isGzip file disk).
Proof.
  unfold isGzip, isJpeg.
  intros file disk jpeg_asmpt.
  destruct jpeg_asmpt as [byte0_is_255]. rewrite byte0_is_255.
  unfold not. intros contra. destruct contra as [not_equal].
  discriminate not_equal.
Qed.


Require Import Charge.Open.Subst.
Require Import Charge.Open.Open.
Require Import Charge.Open.Stack.
Require Import Charge.Logics.BILogic.
Require Import Charge.ModularFunc.ILogicFunc.
Require Import Charge.ModularFunc.BILogicFunc.
Require Import Charge.ModularFunc.LaterFunc.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.OpenFunc.
Require Import Charge.ModularFunc.EmbedFunc.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.String.
Require Import ExtLib.Data.Sum.
Require Import ExtLib.Tactics.Consider.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.syms.SymSum.
Require Import MirrorCore.Subst.FMapSubst.

Require Import Java.Logic.AssertionLogic.
Require Import Java.Logic.SpecLogic.
Require Import Java.Language.Lang.
Require Import Java.Language.Program.
Require Import Java.Semantics.OperationalSemantics.
Require Import Java.Func.JavaType.

Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.

Set Implicit Arguments.
Set Strict Implicit.

	Inductive java_func :=

	| pMethodSpec
	| pProgEq
	| pTriple
	| pTypeOf
	| pFieldLookup
	| pMethodLookup

	| pPointsto
	| pNull

	| pMethodBody
	| pMethodArgs
	| pMethodRet

	| pPlus
	| pMinus
	| pTimes
	| pAnd
	| pOr
	| pNot
	| pLt
	| pValEq.

	Fixpoint beq_list {A} (f : A -> A -> bool) (xs ys : list A) :=
		match xs, ys with
			| nil, nil => true
			| x::xs, y :: ys => andb (f x y) (beq_list f xs ys)
			| _, _ => false
		end.

	Definition typeof_java_func bf :=
		match bf with
		    | pMethodSpec => Some (tyArr tyString (tyArr tyString (tyArr tyVarList
		    	 (tyArr tyString (tyArr tySasn (tyArr tySasn tySpec))))))
		    | pProgEq => Some (tyArr tyProg tySpec)
		    | pTriple => Some (tyArr tySasn (tyArr tySasn (tyArr tyCmd tySpec)))

		    | pTypeOf => Some (tyArr tyString (tyArr tyVal tyProp))

		    | pFieldLookup => Some (tyArr tyProg (tyArr tyString (tyArr tyFields tyProp)))
		    | pMethodLookup => Some (tyArr tyProg (tyArr tyString (tyArr tyString (tyArr tyMethod tyProp))))

		    | pPointsto => Some (tyArr tyVal (tyArr tyString (tyArr tyVal tyAsn)))
		    | pNull => Some tyVal

		    | pMethodBody => Some (tyArr tyMethod tyCmd)
		    | pMethodArgs => Some (tyArr tyMethod (tyList tyString))
		    | pMethodRet => Some (tyArr tyMethod tyDExpr)

		    | pPlus => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pMinus => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pTimes => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pAnd => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pOr => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pNot => Some (tyArr tyVal tyVal)
		    | pLt => Some (tyArr tyVal (tyArr tyVal tyVal))
		    | pValEq => Some (tyArr tyVal (tyArr tyVal tyVal))
		end.

	Definition java_func_eq (a b : java_func) : option bool :=
	  match a , b with
	    | pMethodSpec, pMethodSpec => Some true
	    | pProgEq, pProgEq => Some true
		| pTriple, pTriple => Some true

	    | pTypeOf, pTypeOf => Some true

	    | pPointsto, pPointsto => Some true
	    | pFieldLookup, pFieldLookup => Some true
	    | pMethodLookup, pMethodLookup => Some true

	    | pMethodBody, pMethodBody => Some true
	    | pMethodArgs, pMethodArgs => Some true
	    | pMethodRet, pMethodRet => Some true

	    | pNull, pNull => Some true
	    | pPlus, pPlus => Some true
	    | pMinus, pMinus => Some true
	    | pTimes, pTimes => Some true
	    | pAnd, pAnd => Some true
	    | pOr, pOr => Some true
	    | pNot, pNot => Some true
	    | pLt, pLt => Some true
	    | pValEq, pValEq => Some true
	    | _, _ => None
	  end.

    Global Instance RelDec_java_func : RelDec (@eq java_func) := {
      rel_dec a b := match java_func_eq a b with
    	  		       | Some b => b
    		 	       | None => false
    			     end
    }.

    Global Instance RelDec_Correct_java_func : RelDec_Correct RelDec_java_func.
    Proof.
      constructor.
      destruct x; destruct y; simpl;
      try solve [ try rewrite Bool.andb_true_iff ;
                  repeat rewrite rel_dec_correct; intuition congruence ].
    Qed.

Definition set_fold_fun (x : String.string) (f : field) (P : sasn) :=
	(`pointsto) (x/V) `f `null ** P.

  	 Definition java_func_symD bf :=
		match bf as bf return match typeof_java_func bf with
								| Some t => typD t
								| None => unit
							  end with
              | pMethodSpec => method_spec
              | pProgEq => prog_eq
              | pTriple => triple

              | pTypeOf => typeof

              | pFieldLookup => field_lookup
              | pMethodLookup => method_lookup

              | pPointsto => pointsto

              | pNull => null

              | pMethodBody => m_body
              | pMethodArgs => m_params
              | pMethodRet => m_ret

              | pPlus => eplus
              | pMinus => eminus
              | pTimes => etimes
              | pAnd => eand
              | pOr => eor
              | pNot => enot
              | pLt => elt
              | pValEq => eeq
	end.

	Global Instance RSym_JavaFunc : SymI.RSym java_func := {
	  typeof_sym := typeof_java_func;
	  symD := java_func_symD;
	  sym_eqb := java_func_eq
	}.

	Global Instance RSymOk_JavaFunc : SymI.RSymOk RSym_JavaFunc.
	Proof.
		split; intros.
		destruct a, b; simpl; try apply I; try reflexivity.
	Qed.

Definition func := (SymEnv.func + @ilfunc typ + @bilfunc typ +
                    @base_func typ RType_typ + @list_func typ + @open_func typ _ _ +
                    @embed_func typ + @later_func typ + java_func)%type.

Notation pProg P := (Inj (inl (inl (inl (inl (inl (inr (pConst tyProg P)))))))).
Notation pMethod M := (Inj (inl (inl (inl (inl (inl (inr (pConst tyMethod M)))))))).

Section MakeJavaFunc.

	Definition mkVal v : expr typ func := Inj (inl (inl (inl (inl (inl (inr (pConst tyVal v))))))).
	Definition mkProg P : expr typ func := pProg P.
	Definition mkMethod M : expr typ func := pMethod M.
	Definition mkCmd c : expr typ func := Inj (inl (inl (inl (inl (inl (inr (pConst tyCmd c))))))).
	Definition mkDExpr e : expr typ func := Inj (inl (inl (inl (inl (inl (inr (pConst tyDExpr e))))))).
	Definition mkFields fs : expr typ func := Inj (inl (inl (inl (inl (inl (inr (pConst (tyList tyString) fs))))))).

	Definition fMethodSpec : expr typ func := Inj (inr pMethodSpec).
	Definition fProgEq : expr typ func := Inj (inr pProgEq).
	Definition fTriple : expr typ func := Inj (inr pTriple).
	Definition fTypeOf : expr typ func := Inj (inr pTypeOf).
	Definition fFieldLookup : expr typ func := Inj (inr pFieldLookup).
	Definition fMethodLookup : expr typ func := Inj (inr pMethodLookup).
	Definition fPointsto : expr typ func := Inj (inr pPointsto).
	Definition mkNull : expr typ func := Inj (inr pNull).

	Definition fMethodBody : expr typ func := Inj (inr pMethodBody).
	Definition fMethodArgs : expr typ func := Inj (inr pMethodArgs).
	Definition fMethodRet : expr typ func := Inj (inr pMethodRet).

	Definition fPlus : expr typ func := Inj (inr pPlus).
	Definition fMinus : expr typ func := Inj (inr pMinus).
	Definition fTimes : expr typ func := Inj (inr pTimes).
	Definition fAnd : expr typ func := Inj (inr pAnd).
	Definition fOr : expr typ func := Inj (inr pOr).
	Definition fNot : expr typ func := Inj (inr pNot).
	Definition fLt : expr typ func := Inj (inr pLt).
	Definition fValEq : expr typ func := Inj (inr pValEq).

	Definition mkTriple P c Q : expr typ func := App (App (App fTriple P) Q) c.
	Definition mkFieldLookup P C f : expr typ func := App (App (App fFieldLookup P) C) f.
	Definition mkTypeOf C x : expr typ func := App (App fTypeOf C) x.
	Definition mkProgEq P := App fProgEq P.

	Definition mkMethodBody (M : Method) : expr typ func := App fMethodBody (mkMethod M).
	Definition mkMethodArgs (M : Method) : expr typ func := App fMethodArgs (mkMethod M).
	Definition mkMethodRet (M : Method) : expr typ func := App fMethodRet (mkMethod M).

	Definition mkExprList es :=
		(fold_right (fun (e : dexpr) (acc : expr typ func) =>
			mkCons tyExpr (mkDExpr e) acc) (mkNil tyExpr) es).

	Fixpoint evalDExpr (e : dexpr) : expr typ func :=
		match e with
			| E_val v => mkConst tyVal (mkVal v)
			| E_var x => App (fStackGet (func := expr typ func)) (mkString (func := func) x)
			| E_plus e1 e2 => mkAps fPlus ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_minus e1 e2 => mkAps fMinus ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_times e1 e2 => mkAps fTimes ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_and e1 e2 => mkAps fAnd ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_or e1 e2 => mkAps fOr ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_not e => mkAps fNot ((evalDExpr e, tyVal)::nil) tyVal
			| E_lt e1 e2 => mkAps fLt ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
			| E_eq e1 e2 => mkAps fValEq ((evalDExpr e2, tyVal)::(evalDExpr e1, tyVal)::nil) tyVal
		end.

End MakeJavaFunc.

Require Import Java.Examples.ListModel.

Class Environment := { java_env :> @SymEnv.functions typ _}.

Section JavaFunc.

  Context {fs : Environment}.

(* This needs to be parametric. It shouldn't be here
Definition fs : @SymEnv.functions typ _ :=
  SymEnv.from_list
  	(@SymEnv.F typ _ (tyArr tyVal (tyArr (tyList tyVal) tyAsn)) List::
  	 @SymEnv.F typ _ (tyArr tyVal (tyArr (tyList tyVal) tyAsn)) NodeList::nil).

*)
Check RSym.

  Global Instance RSym_ilfunc : RSym (@ilfunc typ) :=
	  RSym_ilfunc ilops.
  Global Instance RSym_bilfunc : RSym (@bilfunc typ) :=
	  RSym_bilfunc _ bilops.
  Global Instance RSym_embed_func : RSym (@embed_func typ) :=
	  RSym_embed_func _ eops.
  Global Instance RSym_later_func : RSym (@later_func typ) :=
	  RSym_later_func _ lops.
(*
  Global Instance RelDec_func : RelDec (@eq func).
  repeat apply RelDec_eq_pair; try apply _.
  apply _.
*)
  Global Instance RSym_open_func : RSym (@open_func typ _ _) :=
	  @RSym_OpenFunc _ _ _ RType_typ _ _ _ _ _ _ _ _.

  Global Existing Instance RSym_sum.
  Global Existing Instance RSymOk_sum.

  Global Instance RSym_func : RSym func.
    repeat (apply RSym_sum; [|apply _]).
    apply RSym_sum; [|apply (RSym_BaseFunc (edt := edt))].
    repeat (apply RSym_sum; [|apply _]).
    apply (RSym_func java_env).
  Defined.

  Global Instance RSymOk_func : RSymOk RSym_func.
  Proof.
    repeat (apply RSymOk_sum); try apply _.
    apply (RSymOk_BaseFunc (edtOk := edtOk)).
  Qed.

  Global Instance Expr_expr : ExprI.Expr _ (expr typ func) := @Expr_expr typ func _ _ _.
  Global Instance Expr_ok : @ExprI.ExprOk typ RType_typ (expr typ func) Expr_expr := ExprOk_expr.

  Require Import MirrorCore.VariablesI.
  Require Import MirrorCore.Lambda.ExprVariables.

  Global Instance ExprVar_expr : ExprVar (expr typ func) := _.
  Global Instance ExprVarOk_expr : ExprVarOk ExprVar_expr := _.

  Global Instance ExprUVar_expr : ExprUVar (expr typ func) := _.
  Global Instance ExprUVarOk_expr : ExprUVarOk ExprUVar_expr := _.

  Definition subst : Type :=
    FMapSubst.SUBST.raw (expr typ func).
  Global Instance SS : SubstI.Subst subst (expr typ func) :=
    @FMapSubst.SUBST.Subst_subst _.
  Global Instance SU : SubstI.SubstUpdate subst (expr typ func) :=
    @FMapSubst.SUBST.SubstUpdate_subst _ _.
  Global Instance SO : SubstI.SubstOk SS :=
    @FMapSubst.SUBST.SubstOk_subst typ RType_typ (expr typ func) _ _.
  Global Instance SUO :SubstI.SubstUpdateOk SU SO :=  @FMapSubst.SUBST.SubstUpdateOk_subst typ RType_typ (expr typ func) _ _ _.

  Global Instance MA : MentionsAny (expr typ func) := {
    mentionsAny := ExprCore.mentionsAny
  }.

  Global Instance MAOk : MentionsAnyOk MA _ _.
  Proof.
    admit.
  Qed.

  Lemma evalDexpr_wt (e : dexpr) :
	  typeof_expr nil nil (evalDExpr e) = Some tyExpr.
  Proof.
    induction e.
    + simpl; reflexivity.
    + simpl; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
    + simpl; rewrite IHe1, IHe2; reflexivity.
  Qed.

  Definition is_pure (e : expr typ func) : bool :=
	match e with
	  | App f P => match embedS f with
				     | Some (eilf_embed tyPure tySasn) => true
					 | Some (eilf_embed tyProp tySasn) => true
					 | _ => false
				   end

 	  | e =>
 		match ilogicS e with
 		  | Some (ilf_true _) => true
 		  | Some (ilf_false _) => true
 		  | _ => false
 		end
   end.

  Definition mkPointstoVar x f e : expr typ func :=
     mkAp tyVal tyAsn
          (mkAp tyString (tyArr tyVal tyAsn)
                (mkAp tyVal (tyArr tyString (tyArr tyVal tyAsn))
                      (mkConst (tyArr tyVal (tyArr tyString (tyArr tyVal tyAsn)))
                               fPointsto)
                      (App fStackGet (mkString x)))
                (mkConst tyString (mkString f)))
          e.

  Definition test_lemma :=
    @lemmaD typ (expr typ func) RType_typ Expr_expr (expr typ func)
            (fun tus tvs e => exprD' tus tvs tyProp e)
            _
            nil nil.
End JavaFunc.


From mathcomp.ssreflect Require Import ssreflect ssrnat seq eqtype ssrbool ssrfun.
From mathcomp.algebra Require Import ssrint ssralg.
From Coq.Strings Require Import Ascii String.
Require Import Program.Basics.
Require Import UtilString.
Import intZmod.
Require Import Syntax Common Types Memory.

Inductive get_query := Get t:  nat-> ptr t-> int -> ptr t -> nat -> get_query .
Inductive put_query := Put t: value -> ptr t -> nat -> put_query .

    Theorem put_query_eq_dec: eq_dec put_query.
      rewrite /eq_dec.
      move=> x y; case x; case y.
      move=> t v p n t0 v0 p0 n0.
      move: (ctype_eq_dec t0 t)=> [Heqt|Heqt].
        move: (value_eq_dec v0 v) => [Heqv|Heqv];
        move: (nat_eq_dec n0 n) => [Heqn|Heqn]; subst; try
      move: (ptr_eq_dec _ p0 p) => [Heqp|Heqp]; try by [right;case].
      subst; by left.
      right.
      case.
      move=> H.
        by depcomp H.
      move: (nat_eq_dec n0 n) => [Hn|Hn]; by [right; case | done].
    Defined.

    Definition put_query_eqP := reflect_from_dec put_query_eq_dec.

    Canonical put_query_eqMixin := EqMixin put_query_eqP.
    Canonical put_query_eqType := EqType put_query put_query_eqMixin.

Inductive push_query := Push: anyptr -> nat -> push_query.
Inductive pop_query := Pop: anyptr -> pop_query.

Record proc_state := mk_proc_state {
                         proc_id : nat;
                         proc_symbols : seq (seq var_descr);
                         proc_queue_get: seq get_query;
                         proc_queue_put: seq ( seq put_query );
                         proc_queue_pop_reg: seq pop_query;
                         proc_queue_push_reg: seq push_query;
                         proc_memory: seq block;
                         proc_conts: seq statement;
                         proc_registered_locs: seq ( anyptr * nat )
                       }.
Definition ps_mod_f
           mod_syms
           mod_queue_get
           mod_queue_put
           mod_queue_pop
           mod_queue_push
           mod_memory
           mod_conts
           mod_reg_locs
           (ps: proc_state) : proc_state :=
  mk_proc_state
    (proc_id ps)
    (mod_syms ps)
    (mod_queue_get ps)
    (mod_queue_put ps)
    (mod_queue_pop ps)
    (mod_queue_push ps)
    (mod_memory ps)
    (mod_conts ps)
    (mod_reg_locs ps)
.

Definition ps_mod
           mod_syms
           mod_queue_get
           mod_queue_put
           mod_queue_pop
           mod_queue_push
           mod_memory
           mod_conts
           mod_reg_locs : proc_state -> proc_state :=
  ps_mod_f
    (mod_syms \o proc_symbols)
    (mod_queue_get \o proc_queue_get)
    (mod_queue_put \o proc_queue_put)
    (mod_queue_pop \o proc_queue_pop_reg)
    (mod_queue_push \o proc_queue_push_reg)
    (mod_memory \o proc_memory)
    (mod_conts \o proc_conts)
    (mod_reg_locs \o proc_registered_locs).

Definition ps_mod_syms       f := ps_mod f  id id id id id id id.
Definition ps_mod_queue_get  f := ps_mod id f  id id id id id id.
Definition ps_mod_queue_put  f := ps_mod id id f  id id id id id.
Definition ps_mod_queue_pop  f := ps_mod id id id f  id id id id.
Definition ps_mod_queue_push f := ps_mod id id id id f  id id id.
Definition ps_mod_mem        f := ps_mod id id id id id f  id id.
Definition ps_mod_cont       f := ps_mod id id id id id id f  id.
Definition ps_mod_reg_loc    f := ps_mod id id id id id id id f .

Inductive error_code := | OK | BadPointer | ModNonExistingBlock | PointerOutsideBlock| BadWriteLocation | TypeMismatch | WritingGarbage | NonExistingSymbol | GenericError | InvalidPopReg | InvalidPushReg | InvalidGet | InvalidPut.
Scheme Equality for error_code.
Canonical error_code_eqMixin := EqMixin (reflect_from_dec error_code_eq_dec).
Canonical error_code_eqType := EqType error_code error_code_eqMixin.

Inductive machine_state :=
| MGood: seq proc_state -> seq function -> machine_state
| MBad:  seq ((error_code * option statement) * proc_state) -> seq function -> machine_state
| MNeedSync: seq( seq (seq put_query) )-> seq proc_state -> seq function -> machine_state.

Definition ms_source s := match s with | MGood _ f | MBad  _  f | MNeedSync _ _ f => f end.
Definition ms_procs s := match s with | MGood p _ | MNeedSync _ p _ => p | MBad  p _ => map snd p end.

Definition proc_state_empty:= @nil (seq var_descr).

Definition get_var (ps:proc_state) (name:string) : option var_descr :=
  option_find (fun p: var_descr => var_name p == name) (flatten (proc_symbols ps)).

Definition get_fun (s:machine_state) (name:string) : option function :=
         option_find (fun p: function => fun_name p == name) $ ms_source s.

Definition add_var (vd: var_descr) := ps_mod_syms
                                        (fun s=> match s with
                                                   | nil => cons [::vd] nil
                                                   | cons x xs => cons (cons vd x) xs
                                                 end).

Definition ms_mod_proc_all (f:proc_state->proc_state) (ms:machine_state) :=
  match ms with
    | MNeedSync q ps fs => MNeedSync q (map f ps) fs
    | MGood ps fs  => MGood (map f ps) fs
    | MBad _ _ =>  ms
  end.

Definition ms_mod_proc_all_or_fail (f:proc_state->proc_state ?) (ms:machine_state) :=

  match ms with
    | MNeedSync q ps fs =>   let newprocs := seq_unsome (map f ps) in
                             option_map (fun p => MNeedSync q p fs) newprocs
    | MGood ps fs  =>   let newprocs := seq_unsome (map f ps) in
                              option_map (fun p => MGood p fs) newprocs
                              | MBad _ _ =>  None
  end.

Definition ms_for_proc {T} (ms:machine_state) (pid:nat) (f: proc_state -> T) : T? :=
  option_map f $  option_nth (ms_procs ms) pid.

Definition ms_mod_proc (pid:nat) (f:proc_state->proc_state) : machine_state->machine_state :=
  ms_mod_proc_all (fun p=> if proc_id p == pid then f p else p).

Definition can_write (b:block) (i:nat) (v:value) : error_code :=
  match option_nth (contents b) i, v with
    | Some Garbage, val => if el_type b == type_of_val val then OK else TypeMismatch
    | Some Deallocated, _ => BadWriteLocation
    | Some _, Deallocated => WritingGarbage
    | Some _, Error => GenericError
    | Some _, Garbage => WritingGarbage
    | Some Error, _ => GenericError
    | None, _ => BadWriteLocation
    | Some vx, vy  => if (el_type b == type_of_val vy) && (el_type b == type_of_val vx) then OK else TypeMismatch
  end.
Definition ErrorBlock := mk_block Data 0 0 ErrorType [::].

Definition mem_write  (bid:nat) (pos: nat) (val:value) (ps: proc_state): (error_code * proc_state) :=
  let m := proc_memory ps in
  let oldblock := option_nth m bid in
  match oldblock with
    | Some oldblock =>
      let err_code_write := can_write oldblock pos val in
      if err_code_write == OK then
        let newblockcnt := set_nth val (contents oldblock) pos val in
        let newblock := block_mod_cont (const newblockcnt) oldblock in
        let newmem := set_nth ErrorBlock m bid newblock in
        (OK, ps_mod_mem (const newmem) ps)
      else (err_code_write , ps)
    | None => (ModNonExistingBlock, ps)
  end.

Definition mem_mod_block (bid:nat) (f:block->block) (ps:proc_state) : proc_state :=
  ps_mod_mem (mod_at ErrorBlock bid f) ps.

Definition mem_fill_block (bid:nat) (val:value) (ps: proc_state): proc_state :=
  let block_trans := block_mod id id id match val with
                         | Garbage
                         | Deallocated
                         | Error => id
                         | x =>  const $ type_of_val x
                       end (map (const val))
  in
  mem_mod_block bid block_trans ps.

(*** Tests ***)
Module Tests.
  Require Import TestUtils.
  Definition sample_block s := mk_block Data 0 s Int64 $ fill (ValueI64 0) s.
  Definition ps s :proc_state := mk_proc_state 0 nil nil nil nil nil [:: sample_block s ] nil nil .
  Check assert_eq _:  mem_fill_block 0 (ValueI32 11) ( ps 2 )= {|
       proc_id := 0;
       proc_symbols := [::];
       proc_queue_get := [::];
       proc_queue_put := [::];
       proc_queue_pop_reg := [::];
       proc_queue_push_reg := [::];
       proc_memory := [:: {|
                          region := Data;
                          block_id := 0;
                          block_size := 2;
                          el_type := Int S32;
                          contents := [:: ValueI32 11; ValueI32 11] |}];
       proc_conts := [::];
       proc_registered_locs := [::] |}.

  Check assert_eq _ : mem_fill_block 0 (ValueI32 11) (ps 2) = {|
       proc_id := 0;
       proc_symbols := [::];
       proc_queue_get := [::];
       proc_queue_put := [::];
       proc_queue_pop_reg := [::];
       proc_queue_push_reg := [::];
       proc_memory := [:: {|
                          region := Data;
                          block_id := 0;
                          block_size := 2;
                          el_type := Int S32;
                          contents := [:: ValueI32 11; ValueI32 11] |}];
       proc_conts := [::];
       proc_registered_locs := [::] |}.

End Tests.

(* TODO: handle byte sizes instead of elements' counts *)