Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.
Require Import Ctypes. (*for type and access_mode*)
Require Import mem_lemmas. (*needed for definition of valid_block_dec etc*)

Require Import Axioms.
Require Import structured_injections.
Require Import reach.
Require Import effect_semantics.
Require Import effect_properties.
Require Import simulations.

Require Import I64Helpers.

Definition memcpy_Effect sz vargs m:=
       match vargs with
          Vptr b1 ofs1 :: Vptr b2 ofs2 :: nil =>
          fun b z => eq_block b b1 && zle (Int.unsigned ofs1) z &&
                     zlt z (Int.unsigned ofs1 + sz) && valid_block_dec m b
       | _ => fun b z => false
       end.

Lemma memcpy_Effect_unchOn: forall m bsrc osrc sz bytes bdst odst m'
        (LD: Mem.loadbytes m bsrc (Int.unsigned osrc) sz = Some bytes)
        (ST: Mem.storebytes m bdst (Int.unsigned odst) bytes = Some m')
        (SZ: sz >= 0),
    Mem.unchanged_on
      (fun b z=> memcpy_Effect sz (Vptr bdst odst :: Vptr bsrc osrc :: nil)
                 m b z = false) m m'.
Proof. intros.
  split; intros.
    unfold Mem.perm. rewrite (Mem.storebytes_access _ _ _ _ _ ST). intuition.
  unfold memcpy_Effect in H.
    rewrite (Mem.storebytes_mem_contents _ _ _ _ _ ST).
    destruct (valid_block_dec m b); simpl in *. rewrite andb_true_r in H; clear v.
    destruct (eq_block b bdst); subst; simpl in *.
      rewrite PMap.gss. apply Mem.setN_other.
      intros. intros N; subst.
        rewrite (Mem.loadbytes_length _ _ _ _ _ LD), nat_of_Z_eq in H1; trivial.
          destruct (zle (Int.unsigned odst) ofs); simpl in *.
            destruct (zlt ofs (Int.unsigned odst + sz)). inv H.
            omega. omega.
    clear H. rewrite PMap.gso; trivial.
  elim n. eapply Mem.perm_valid_block; eassumption.
Qed.

Lemma external_call_memcpy_unchOn:
    forall {F V:Type} (ge : Genv.t F V) m ty b1 ofs1 b2 ofs2 m' a tr vres,
    external_call (EF_memcpy (sizeof ty) a) ge
                  (Vptr b1 ofs1 :: Vptr b2 ofs2 :: nil) m tr vres m' ->
    Mem.unchanged_on
      (fun b z=> memcpy_Effect (sizeof ty) (Vptr b1 ofs1 :: Vptr b2 ofs2 :: nil)
                 m b z = false) m m'.
Proof. intros. inv H.
  eapply memcpy_Effect_unchOn; try eassumption. omega.
Qed.

Lemma memcpy_Effect_validblock:
    forall {F V:Type} (ge : Genv.t F V) m sz vargs b z,
    memcpy_Effect sz vargs m b z = true ->
    Mem.valid_block m b.
Proof. intros.
 unfold memcpy_Effect in H.
  destruct vargs; try discriminate.
  destruct v; try discriminate.
  destruct vargs; try discriminate.
  destruct v; try discriminate.
  destruct vargs; try discriminate.
  destruct (valid_block_dec m b); simpl in *. trivial.
  rewrite andb_false_r in H. inv H.
Qed.

Definition free_Effect vargs m:=
       match vargs with
          Vptr b1 lo :: nil =>
          match Mem.load Mint32 m b1 (Int.unsigned lo - 4)
          with Some (Vint sz) =>
            fun b z => eq_block b b1 && zlt 0 (Int.unsigned sz) &&
                     zle (Int.unsigned lo - 4) z &&
                     zlt z (Int.unsigned lo + Int.unsigned sz)
          | _ => fun b z => false
          end
       | _ => fun b z => false
       end.

Lemma free_Effect_unchOn: forall {F V : Type} (g : Genv.t F V)
        vargs m t vres m' (FR : external_call EF_free g vargs m t vres m'),
     Mem.unchanged_on (fun b z => free_Effect vargs m b z = false) m m'.
Proof. intros. inv FR.
  eapply Mem.free_unchanged_on. eassumption.
  intros. unfold free_Effect. rewrite H.
    destruct (eq_block b b); simpl.
      clear e. destruct (zlt 0 (Int.unsigned sz)); simpl; try omega.
      clear l. destruct (zlt 0 (Int.unsigned sz)); simpl; try omega.
      clear l. destruct (zle (Int.unsigned lo - 4) i); simpl; try omega.
      clear l. destruct (zlt i (Int.unsigned lo + Int.unsigned sz)); simpl; try omega.
      discriminate.
   elim n; trivial.
Qed.

Lemma freeEffect_valid_block vargs m: forall b z
        (FR: free_Effect vargs m b z = true),
      Mem.valid_block m b.
Proof. intros.
  destruct vargs; inv FR.
  destruct v; inv H0.
  destruct vargs; inv H1.
  remember (Mem.load Mint32 m b0 (Int.unsigned i - 4)) as d.
  destruct d; apply eq_sym in Heqd.
    destruct v; inv H0.
    destruct (eq_block b b0); subst; simpl in *.
      apply Mem.load_valid_access in Heqd.
      eapply Mem.valid_access_valid_block.
      eapply Mem.valid_access_implies; try eassumption. constructor.
    inv H1.
  inv H0.
Qed.

Definition BuiltinEffect  {F V: Type} (ge: Genv.t F V) (ef: external_function)
          (vargs:list val) (m:mem): block -> Z -> bool :=
  match ef with
    EF_malloc => EmptyEffect
  | EF_free => free_Effect vargs m
  | EF_memcpy sz a => memcpy_Effect sz vargs m
  | _ => fun b z => false
  end.

Lemma malloc_Effect_unchOn: forall {F V : Type} (g : Genv.t F V)
         vargs m t vres m' (EF: external_call EF_malloc g vargs m t vres m'),
     Mem.unchanged_on
      (fun b z => BuiltinEffect g EF_malloc vargs m b z = false) m m'.
Proof. intros.
       simpl. inv EF.
       split; intros.
          unfold Mem.perm. rewrite (Mem.store_access _ _ _ _ _ _ H0).
          split; intros.
            eapply Mem.perm_alloc_1; eassumption.
            eapply Mem.perm_alloc_4; try eassumption.
              intros N. subst. eapply Mem.fresh_block_alloc; eassumption.
        rewrite <- (AllocContentsOther _ _ _ _ _ H).
                rewrite (Mem.store_mem_contents _ _ _ _ _ _ H0).
                rewrite PMap.gso. trivial.
                intros N; subst. apply Mem.perm_valid_block in H2.
                    eapply Mem.fresh_block_alloc; eassumption.
              intros N; subst. apply Mem.perm_valid_block in H2.
                    eapply Mem.fresh_block_alloc; eassumption.
Qed.

Section BUILTINS.

Context {F V: Type} (ge: Genv.t (AST.fundef F) V).
Variable hf : helper_functions.

Definition builtin_implements (id: ident) (sg: signature)
      (vargs: list val) (vres: val) : Prop :=
  forall m, external_call (EF_builtin id sg) ge vargs m E0 vres m.

Definition observableEF (ef: external_function): Prop :=
  match ef with
    EF_malloc => False (*somewhat arbitrary*)
  | EF_free => False (*somewhat arbitrary*)
  | EF_memcpy _ _ => False
  | EF_builtin x sg => ~ is_I64_helper hf x sg
  | EF_external x sg => ~ is_I64_helper hf x sg
  | _ => True
  end.

Lemma observableEF_dec ef: {observableEF ef} + {~observableEF ef}.
Proof.
destruct ef; simpl; try solve[left; trivial].
  destruct (is_I64_helper_dec hf name sg).
    right. intros N. apply (N i).
    left; trivial.
  destruct (is_I64_helper_dec hf name sg).
    right. intros N. apply (N i).
    left; trivial.
  right; intros N. trivial.
  right; intros N. trivial.
  right; intros N. trivial.
Qed.

Definition EFisHelper ef :=
match ef with
    EF_builtin name sg => is_I64_helper hf name sg
  | EF_external name sg => is_I64_helper hf name sg
  | _ => False
end.

Lemma EFhelpers ef: EFisHelper ef -> ~ observableEF ef.
Proof. unfold observableEF; intros. intros N.
destruct ef; simpl in H; trivial. apply (N H). apply (N H).
Qed.

Lemma EFhelpersE name sg:
  ~ observableEF (EF_external name sg) ->
  is_I64_helper hf name sg.
Proof.
unfold observableEF. intros.
destruct (is_I64_helper_dec hf name sg).
  trivial.
  elim (H n).
Qed.

Lemma EFhelpersB name sg:
  ~observableEF (EF_builtin name sg) ->
  is_I64_helper hf name sg.
Proof.
unfold observableEF. intros.
destruct (is_I64_helper_dec hf name sg).
  trivial.
  elim (H n).
Qed.

Lemma obs_efB name sg : is_I64_helper hf name sg ->
     ~ observableEF (EF_builtin name sg).
Proof. intros. unfold observableEF.
  intros N. apply (N H).
Qed.

Lemma obs_efE name sg : is_I64_helper hf name sg ->
     ~ observableEF (EF_external name sg).
Proof. intros. unfold observableEF.
  intros N. apply (N H).
Qed.

Definition helper_implements
     (id: ident) (sg: signature) (vargs: list val) (vres: val) : Prop :=
  exists b, exists ef,
     Genv.find_symbol ge id = Some b
  /\ Genv.find_funct_ptr ge b = Some (External ef)
  /\ ef_sig ef = sg
  /\ (forall m, external_call ef ge vargs m E0 vres m)
  (*NEW*) /\ ~ observableEF ef.

Definition i64_helpers_correct: Prop :=
    (forall x z, Val.longoffloat x = Some z -> helper_implements hf.(i64_dtos) sig_f_l (x::nil) z)
  /\(forall x z, Val.longuoffloat x = Some z -> helper_implements hf.(i64_dtou) sig_f_l (x::nil) z)
  /\(forall x z, Val.floatoflong x = Some z -> helper_implements hf.(i64_stod) sig_l_f (x::nil) z)
  /\(forall x z, Val.floatoflongu x = Some z -> helper_implements hf.(i64_utod) sig_l_f (x::nil) z)
  /\(forall x z, Val.singleoflong x = Some z -> helper_implements hf.(i64_stof) sig_l_s (x::nil) z)
  /\(forall x z, Val.singleoflongu x = Some z -> helper_implements hf.(i64_utof) sig_l_s (x::nil) z)
  /\(forall x, builtin_implements hf.(i64_neg) sig_l_l (x::nil) (Val.negl x))
  /\(forall x y, builtin_implements hf.(i64_add) sig_ll_l (x::y::nil) (Val.addl x y))
  /\(forall x y, builtin_implements hf.(i64_sub) sig_ll_l (x::y::nil) (Val.subl x y))
  /\(forall x y, builtin_implements hf.(i64_mul) sig_ii_l (x::y::nil) (Val.mull' x y)) (*LENB: Compcert had sig_ii here*)
  /\(forall x y z, Val.divls x y = Some z -> helper_implements hf.(i64_sdiv) sig_ll_l (x::y::nil) z)
  /\(forall x y z, Val.divlu x y = Some z -> helper_implements hf.(i64_udiv) sig_ll_l (x::y::nil) z)
  /\(forall x y z, Val.modls x y = Some z -> helper_implements hf.(i64_smod) sig_ll_l (x::y::nil) z)
  /\(forall x y z, Val.modlu x y = Some z -> helper_implements hf.(i64_umod) sig_ll_l (x::y::nil) z)
  /\(forall x y, helper_implements hf.(i64_shl) sig_li_l (x::y::nil) (Val.shll x y))
  /\(forall x y, helper_implements hf.(i64_shr) sig_li_l (x::y::nil) (Val.shrlu x y))
  /\(forall x y, helper_implements hf.(i64_sar) sig_li_l (x::y::nil) (Val.shrl x y)).

End BUILTINS.

Require Import Errors.

(*Moved here from Selection phase. We removed the dependence of
get_helpers on ge since the implementation actually does not look at
it.*)

Axiom get_helpers_correct:
  forall F V (ge:Genv.t (AST.fundef F) V) (hf : helper_functions),
  get_helpers = OK hf ->  i64_helpers_correct ge hf.

Lemma BuiltinEffect_unchOn:
    forall {F V:Type} hf ef (g : Genv.t F V) vargs m t vres m'
    (OBS: ~ observableEF hf ef),
    external_call ef g vargs m t vres m' ->
    Mem.unchanged_on
      (fun b z=> BuiltinEffect g ef vargs m b z = false) m m'.
Proof. intros.
  destruct ef.
    (*EF_external*)
       inv H. apply Mem.unchanged_on_refl.
    (*EF_builtin - same proof as previous case*)
       inv H. apply Mem.unchanged_on_refl.
    simpl in OBS. intuition.
    simpl in OBS. intuition.
    simpl in OBS. intuition.
    simpl in OBS. intuition.
    (*case EF_malloc*)
       eapply  malloc_Effect_unchOn. eassumption.
    (*case EF_free*)
       eapply free_Effect_unchOn; eassumption.
    (*case EE_memcpy*)
       inv H. clear - H1 H6 H7.
       eapply memcpy_Effect_unchOn; try eassumption. omega.
    simpl in OBS. intuition.
    simpl in OBS. intuition.
    simpl in OBS. intuition.
Qed.

Lemma BuiltinEffect_valid_block:
    forall {F V:Type} ef (g : Genv.t F V) vargs m b z,
     BuiltinEffect g ef vargs m b z = true -> Mem.valid_block m b.
Proof. intros. unfold BuiltinEffect in H.
  destruct ef; try discriminate.
    eapply freeEffect_valid_block; eassumption.
    eapply memcpy_Effect_validblock; eassumption.
Qed.

(*takes the role of external_call_mem_inject
  Since inlinables write at most to vis, we use the
  Mem-Unchanged_on condition loc_out_of_reach, rather than
  local_out_of_reach as in external calls.*)
Lemma inlineable_extern_inject: forall {F V TF TV:Type}
       (ge:Genv.t F V) (tge:Genv.t TF TV) (GDE: genvs_domain_eq ge tge)
       (SymbPres: forall s, Genv.find_symbol tge s = Genv.find_symbol ge s)
       hf ef vargs m t vres m1 mu tm vargs'
       (WD: SM_wd mu) (SMV: sm_valid mu m tm) (RC: REACH_closed m (vis mu))
       (Glob: forall b, isGlobalBlock ge b = true ->
              frgnBlocksSrc mu b = true)
       (OBS: ~ observableEF hf ef),
       meminj_preserves_globals ge (as_inj mu) ->
       external_call ef ge vargs m t vres m1 ->
       Mem.inject (as_inj mu) m tm ->
       val_list_inject (restrict (as_inj mu) (vis mu)) vargs vargs' ->
       exists mu' vres' tm1,
         external_call ef tge vargs' tm t vres' tm1 /\
         val_inject (restrict (as_inj mu') (vis mu')) vres vres' /\
         Mem.inject (as_inj mu') m1 tm1 /\
         Mem.unchanged_on (loc_unmapped (restrict (as_inj mu) (vis mu))) m m1 /\
         Mem.unchanged_on (loc_out_of_reach (restrict (as_inj mu) (vis mu)) m) tm tm1 /\
         intern_incr mu mu' /\
         sm_inject_separated mu mu' m tm /\
         globals_separate ge mu mu' /\
         sm_locally_allocated mu mu' m tm m1 tm1 /\
         SM_wd mu' /\ sm_valid mu' m1 tm1 /\
         REACH_closed m1 (vis mu').
Proof. intros.
destruct ef; simpl in H0.
(*EFexternal*)
      eapply helpers_inject; try eassumption.
      apply EFhelpersE; eassumption.
    (*EF_builtin*)
      eapply helpers_inject; try eassumption.
      apply EFhelpersE; eassumption.
    simpl in OBS; intuition.
    simpl in OBS; intuition.
    simpl in OBS; intuition.
    simpl in OBS; intuition.
    (*case EF_malloc*)
    inv H0. inv H2. inv H8. inv H6. clear OBS.
    exploit alloc_parallel_intern; eauto. apply Zle_refl. apply Zle_refl.
    intros [mu' [tm' [tb [TALLOC [INJ' [INC [AI1 [AI2 [SEP [LOCALLOC [WD' [SMV' RC']]]]]]]]]]]].
    exploit Mem.store_mapped_inject. eexact INJ'. eauto. eauto.
    instantiate (1 := Vint n). auto.
    intros [tm1 [ST' INJ1]].
    assert (visb': vis mu' b = true).
        apply sm_locally_allocatedChar in LOCALLOC.
        unfold vis. destruct LOCALLOC as [_ [_ [LOC _]]]. rewrite LOC.
        rewrite (freshloc_alloc _ _ _ _ _ H3).
        destruct (eq_block b b); subst; simpl. intuition. elim n0; trivial.
    exists mu'; exists (Vptr tb Int.zero); exists tm1; intuition.
      econstructor; eauto.
      econstructor. eapply restrictI_Some; eassumption.
      rewrite Int.add_zero. trivial.
    split; unfold loc_unmapped; intros. unfold Mem.perm.
         rewrite (Mem.store_access _ _ _ _ _ _ H4).
         split; intros.
         eapply Mem.perm_alloc_1; eassumption.
         eapply Mem.perm_alloc_4; try eassumption.
         intros N; subst; eapply (Mem.fresh_block_alloc _ _ _ _ _ H3 H5).
      rewrite (Mem.store_mem_contents _ _ _ _ _ _ H4).
        apply Mem.perm_valid_block in H5.
        rewrite PMap.gso.
          rewrite (AllocContentsOther1 _ _ _ _ _ H3). trivial.
          intros N; subst; eapply (Mem.fresh_block_alloc _ _ _ _ _ H3 H5).
        intros N; subst; eapply (Mem.fresh_block_alloc _ _ _ _ _ H3 H5).
    split; unfold loc_out_of_reach; intros.
         unfold Mem.perm.
         rewrite (Mem.store_access _ _ _ _ _ _ ST').
         split; intros.
         eapply Mem.perm_alloc_1; eassumption.
         eapply Mem.perm_alloc_4; try eassumption.
         intros N; subst. eapply (Mem.fresh_block_alloc _ _ _ _ _ TALLOC H5).
      rewrite (Mem.store_mem_contents _ _ _ _ _ _ ST').
        apply Mem.perm_valid_block in H5.
        rewrite PMap.gso.
          rewrite (AllocContentsOther1 _ _ _ _ _ TALLOC). trivial.
          intros N; subst; eapply (Mem.fresh_block_alloc _ _ _ _ _ TALLOC H5).
          intros N; subst; eapply (Mem.fresh_block_alloc _ _ _ _ _ TALLOC H5).
          eapply intern_incr_globals_separate; eauto.
    rewrite sm_locally_allocatedChar.
      rewrite sm_locally_allocatedChar in LOCALLOC.
      destruct LOCALLOC as [LAC1 [LAC2 [LAC3 [LAC4 [LAC5 LOC6]]]]].
      rewrite LAC1, LAC2, LAC3, LAC4, LAC5, LOC6; clear LAC1 LAC2 LAC3 LAC4 LAC5 LOC6.
           repeat split; extensionality bb.
             rewrite (freshloc_alloc _ _ _ _ _ H3).
             rewrite <- (freshloc_trans m m'), (freshloc_alloc _ _ _ _ _ H3), (store_freshloc _ _ _ _ _ _ H4).
             rewrite orb_false_r. trivial.
             eapply alloc_forward; eassumption. eapply store_forward; eassumption.

             rewrite (freshloc_alloc _ _ _ _ _ TALLOC).
             rewrite <- (freshloc_trans tm tm'), (freshloc_alloc _ _ _ _ _ TALLOC), (store_freshloc _ _ _ _ _ _ ST').
             rewrite orb_false_r. trivial.
             eapply alloc_forward; eassumption. eapply store_forward; eassumption.

             rewrite (freshloc_alloc _ _ _ _ _ H3).
             rewrite <- (freshloc_trans m m'), (freshloc_alloc _ _ _ _ _ H3), (store_freshloc _ _ _ _ _ _ H4).
             rewrite orb_false_r. trivial.
             eapply alloc_forward; eassumption. eapply store_forward; eassumption.

             rewrite (freshloc_alloc _ _ _ _ _ TALLOC).
             rewrite <- (freshloc_trans tm tm'), (freshloc_alloc _ _ _ _ _ TALLOC), (store_freshloc _ _ _ _ _ _ ST').
             rewrite orb_false_r. trivial.
             eapply alloc_forward; eassumption. eapply store_forward; eassumption.

        split; intros; eapply store_forward; try eassumption.
          rewrite sm_locally_allocatedChar in LOCALLOC.
          destruct LOCALLOC as [LAC1 _]. unfold DOM in H2; rewrite LAC1 in H2; clear LAC1.
          rewrite (freshloc_alloc _ _ _ _ _ H3) in H2.
          destruct (eq_block b1 b); subst; simpl in *.
            eapply Mem.valid_new_block; eassumption.
          rewrite orb_false_r in H2.
            eapply Mem.valid_block_alloc; try eassumption.
            eapply SMV; eassumption.

          rewrite sm_locally_allocatedChar in LOCALLOC.
          destruct LOCALLOC as [_ [LAC2 _]]. unfold RNG in H2; rewrite LAC2 in H2; clear LAC2.
          rewrite (freshloc_alloc _ _ _ _ _ TALLOC) in H2.
          destruct (eq_block b2 tb); subst; simpl in *.
            eapply Mem.valid_new_block; eassumption.
          rewrite orb_false_r in H2.
            eapply Mem.valid_block_alloc; try eassumption.
            eapply SMV; eassumption.
      eapply (REACH_Store m'); try eassumption.
      intros ? getBl. rewrite getBlocks_char in getBl.
         destruct getBl as [zz [ZZ | ZZ]]; inv ZZ.
  (*case EF_free*)
    inv H0. inv H2. inv H9. inv H7.
    destruct (restrictD_Some _ _ _ _ _ H6) as [AIb VISb].
    exploit free_parallel_inject; try eassumption.
    intros [tm1 [TFR Inj1]].
    exploit (Mem.load_inject (as_inj mu) m); try eassumption.
    intros [v [TLD Vinj]]. inv Vinj.
    assert (Mem.range_perm m b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) Cur Freeable).
      eapply Mem.free_range_perm; eauto.
    exploit Mem.address_inject. eapply H1.
      apply Mem.perm_implies with Freeable; auto with mem.
      apply H0. instantiate (1 := lo). omega.
      eassumption.
    intro EQ.
    assert (Mem.range_perm tm b2 (Int.unsigned lo + delta - 4) (Int.unsigned lo + delta + Int.unsigned sz) Cur Freeable).
      red; intros.
      replace ofs with ((ofs - delta) + delta) by omega.
      eapply Mem.perm_inject. eassumption. eassumption. eapply H0. omega.
(*    destruct (Mem.range_perm_free _ _ _ _ H2) as [m2' FREE].*)
    exists mu; eexists; exists tm1; split.
      simpl. econstructor.
       rewrite EQ. replace (Int.unsigned lo + delta - 4) with (Int.unsigned lo - 4 + delta) by omega.
       eauto. auto.
      rewrite EQ. clear - TFR.
        assert (Int.unsigned lo + delta - 4 = Int.unsigned lo - 4 + delta). omega. rewrite H; clear H.
        assert (Int.unsigned lo + delta + Int.unsigned sz = Int.unsigned lo + Int.unsigned sz + delta). omega. rewrite H; clear H.
        assumption.
     intuition.

     eapply Mem.free_unchanged_on; eauto.
       unfold loc_unmapped; intros. congruence.

     eapply Mem.free_unchanged_on; eauto.
       unfold loc_out_of_reach; intros. red; intros. eelim H8; eauto.
       apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
       apply H0. omega.

       apply intern_incr_refl.
       apply sm_inject_separated_same_sminj.
       apply gsep_refl.
     apply sm_locally_allocatedChar.
       repeat split; try extensionality bb; simpl.
       rewrite (freshloc_free _ _ _ _ _ H5). clear. intuition.
       rewrite (freshloc_free _ _ _ _ _ TFR). clear. intuition.
       rewrite (freshloc_free _ _ _ _ _ H5). clear. intuition.
       rewrite (freshloc_free _ _ _ _ _ TFR). clear. intuition.
     split; intros; eapply Mem.valid_block_free_1; try eassumption.
       eapply SMV; assumption. eapply SMV; assumption.
     eapply REACH_closed_free; eassumption.
  (*memcpy*)
     clear OBS.
     inv H0.
  exploit Mem.loadbytes_length; eauto. intros LEN.
  assert (RPSRC: Mem.range_perm m bsrc (Int.unsigned osrc) (Int.unsigned osrc + sz) Cur Nonempty).
    eapply Mem.range_perm_implies. eapply Mem.loadbytes_range_perm; eauto. auto with mem.
  assert (RPDST: Mem.range_perm m bdst (Int.unsigned odst) (Int.unsigned odst + sz) Cur Nonempty).
    replace sz with (Z_of_nat (length bytes)).
    eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem.
    rewrite LEN. apply nat_of_Z_eq. omega.
  assert (PSRC: Mem.perm m bsrc (Int.unsigned osrc) Cur Nonempty).
    apply RPSRC. omega.
  assert (PDST: Mem.perm m bdst (Int.unsigned odst) Cur Nonempty).
    apply RPDST. omega.
  inv H2. inv H12. inv H14. inv H15. inv H12.
  destruct (restrictD_Some _ _ _ _ _ H11).
  destruct (restrictD_Some _ _ _ _ _ H13).
  exploit Mem.address_inject.  eauto. eexact PSRC. eauto. intros EQ1.
  exploit Mem.address_inject.  eauto. eexact PDST. eauto. intros EQ2.
  exploit Mem.loadbytes_inject; eauto. intros [bytes2 [A B]].
  exploit Mem.storebytes_mapped_inject; eauto. intros [m2' [C D]].
  exists mu; exists Vundef; exists m2'.
  split. econstructor; try rewrite EQ1; try rewrite EQ2; eauto.
  eapply Mem.aligned_area_inject with (m := m); eauto.
  eapply Mem.aligned_area_inject with (m := m); eauto.
  eapply Mem.disjoint_or_equal_inject with (m := m); eauto.
  apply Mem.range_perm_max with Cur; auto.
  apply Mem.range_perm_max with Cur; auto.
  split. constructor.
  split. auto.
  split. eapply Mem.storebytes_unchanged_on; eauto.
         unfold loc_unmapped; intros. rewrite H11. congruence.
  split. eapply Mem.storebytes_unchanged_on; eauto.
         unfold loc_out_of_reach; intros. red; intros.
         eapply (H16 _ _ H11).
             apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem.
             eapply Mem.storebytes_range_perm; eauto.
             erewrite list_forall2_length; eauto.
             omega.
  split. apply intern_incr_refl.
  split. apply sm_inject_separated_same_sminj.
  split. apply gsep_refl.
  split. apply sm_locally_allocatedChar.
       repeat split; try extensionality bb; simpl.
       rewrite (storebytes_freshloc _ _ _ _ _ H10). clear. intuition.
       rewrite (storebytes_freshloc _ _ _ _ _ C). clear. intuition.
       rewrite (storebytes_freshloc _ _ _ _ _ H10). clear. intuition.
       rewrite (storebytes_freshloc _ _ _ _ _ C). clear. intuition.
  split; trivial.
  split. split; intros.
       eapply storebytes_forward; try eassumption.
          eapply SMV; trivial.
       eapply storebytes_forward; try eassumption.
          eapply SMV; trivial.
  destruct (loadbytes_D _ _ _ _ _ H9); clear A C.
   clear RPSRC RPDST PSRC PDST H8 H11 H3 H5 H6 H7 EQ1 EQ2 B D.
  intros. eapply REACH_Storebytes; try eassumption.
          intros. eapply RC. subst bytes.
          destruct (in_split _ _ H3) as [bts1 [bts2 Bytes]]; clear H3.
          specialize (getN_range _ _ _ _ _ _ Bytes). intros.
          apply getN_aux in Bytes.
          eapply REACH_cons. instantiate(1:=bsrc).
            eapply REACH_nil. assumption.
            Focus 2. apply eq_sym. eassumption.
            eapply H15. clear - H3 H4.
            split. specialize (Zle_0_nat (length bts1)). intros. omega.
                   apply inj_lt in H3. rewrite nat_of_Z_eq in H3; omega.
    simpl in OBS; intuition.
    simpl in OBS; intuition.
    simpl in OBS; intuition.
Qed.

Lemma BuiltinEffect_Propagate: forall {F V TF TV:Type}
       (ge:Genv.t F V) (tge:Genv.t TF TV) ef m vargs t vres m'
       (EC : external_call ef ge vargs m t vres m') mu m2 tvargs
       (ArgsInj : val_list_inject (restrict (as_inj mu) (vis mu)) vargs tvargs)
       (WD : SM_wd mu) (MINJ : Mem.inject (as_inj mu) m m2),
     forall b ofs, BuiltinEffect tge ef tvargs m2 b ofs = true ->
       visTgt mu b = true /\
       (locBlocksTgt mu b = false ->
        exists b1 delta1,
           foreign_of mu b1 = Some (b, delta1) /\
           BuiltinEffect ge ef vargs m b1 (ofs - delta1) = true /\
           Mem.perm m b1 (ofs - delta1) Max Nonempty).
Proof.
 intros. destruct ef; try inv H.
  (*free*)
    simpl in EC. inv EC.
    inv ArgsInj. inv H7. inv H5.
    rewrite H1. unfold free_Effect in H1.
    destruct (restrictD_Some _ _ _ _ _ H6) as [AIb VISb].
    exploit (Mem.load_inject (as_inj mu) m); try eassumption.
    intros [v [TLD Vinj]]. inv Vinj.
    assert (RP: Mem.range_perm m b0 (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz) Cur Freeable).
      eapply Mem.free_range_perm; eauto.
    exploit Mem.address_inject. eapply MINJ.
      apply Mem.perm_implies with Freeable; auto with mem.
      apply RP. instantiate (1 := lo). omega.
      eassumption.
    intro EQ.
    rewrite EQ in *.
    assert (Arith4: Int.unsigned lo - 4 + delta = Int.unsigned lo + delta - 4) by omega.
    rewrite Arith4, TLD in *.
    destruct (eq_block b b2); subst; simpl in *; try inv H1.
    rewrite H, H4.
    split. eapply visPropagateR; eassumption.
    intros. exists b0, delta.
    rewrite restrict_vis_foreign_local in H6; trivial.
    destruct (joinD_Some _ _ _ _ _ H6) as [FRG | [FRG LOC]]; clear H6.
    Focus 2. destruct (local_DomRng _ WD _ _ _ LOC). rewrite H5 in H1; discriminate.
    split; trivial.
    destruct (eq_block b0 b0); simpl in *.
    Focus 2. elim n; trivial.
    clear e.
        destruct (zlt 0 (Int.unsigned sz)); simpl in *; try inv H4.
        destruct (zle (Int.unsigned lo + delta - 4) ofs); simpl in *; try inv H5.
        destruct (zlt ofs (Int.unsigned lo + delta + Int.unsigned sz)); simpl in *; try inv H4.
        destruct (zle (Int.unsigned lo - 4) (ofs - delta)); simpl in *; try omega.
        split. destruct (zlt (ofs - delta) (Int.unsigned lo + Int.unsigned sz)); trivial.
                 omega.
        eapply Mem.perm_implies.
          eapply Mem.perm_max. eapply RP. split; trivial. omega.
          constructor.
     (*memcpy*)
        simpl in EC. inv EC.
        inv ArgsInj. inv H12. inv H10. inv H11. inv H14.
        rewrite H1. unfold memcpy_Effect in H1.
        destruct (eq_block b b2); subst; simpl in *; try inv H1.
        destruct (zle (Int.unsigned (Int.add odst (Int.repr delta))) ofs); simpl in *; try inv H9.
        destruct (zlt ofs (Int.unsigned (Int.add odst (Int.repr delta)) + sz)); simpl in *; try inv H1.
        destruct (valid_block_dec m2 b2); simpl in *; try inv H9.
        split. eapply visPropagateR; eassumption.
        intros. exists bdst, delta.
        destruct (restrictD_Some _ _ _ _ _ H12).
        exploit Mem.address_inject.
           eapply MINJ.
           eapply Mem.storebytes_range_perm. eassumption.
           split. apply Z.le_refl.
             rewrite (Mem.loadbytes_length _ _ _ _ _ H6).
               rewrite nat_of_Z_eq; omega.
           eassumption.
        intros UNSIG; rewrite UNSIG in *.
        assert (MP: Mem.perm m bdst (ofs - delta) Max Nonempty).
           eapply Mem.perm_implies.
             eapply Mem.perm_max.
             eapply Mem.storebytes_range_perm. eassumption.
             rewrite (Mem.loadbytes_length _ _ _ _ _ H6).
             rewrite nat_of_Z_eq; omega.
           constructor.
        rewrite (restrict_vis_foreign_local _ WD) in H12.
        destruct (joinD_Some _ _ _ _ _ H12) as [FRG | [FRG LOC]]; clear H12.
          split; trivial. split; trivial.
          destruct (eq_block bdst bdst); simpl. clear e.
            destruct (zle (Int.unsigned odst) (ofs - delta)); simpl.
              destruct (zlt (ofs - delta) (Int.unsigned odst + sz)); simpl.
                destruct (valid_block_dec m bdst); trivial.
                elim n. eapply Mem.perm_valid_block; eassumption.
              omega.
            omega.
          elim n; trivial.
        destruct (local_DomRng _ WD _ _ _ LOC).
          rewrite H13 in H1. discriminate.
  inv H8.
  inv H8.
Qed.

Lemma BuiltinEffect_Propagate': forall {F V TF TV:Type}
       (ge:Genv.t F V) (tge:Genv.t TF TV) ef m vargs t vres m'
       (EC : external_call' ef ge vargs m t vres m') mu m2 tvargs
       (ArgsInj : val_list_inject (restrict (as_inj mu) (vis mu)) vargs tvargs)
       (WD : SM_wd mu) (MINJ : Mem.inject (as_inj mu) m m2),
     forall b ofs, BuiltinEffect tge ef tvargs m2 b ofs = true ->
       visTgt mu b = true /\
       (locBlocksTgt mu b = false ->
        exists b1 delta1,
           foreign_of mu b1 = Some (b, delta1) /\
           BuiltinEffect ge ef vargs m b1 (ofs - delta1) = true /\
           Mem.perm m b1 (ofs - delta1) Max Nonempty).
Proof.
 intros.
 destruct ef; try inv H.
  (*free*)
  { simpl in EC. inv EC.
    inv ArgsInj. inv H. inv H. inv H0.
    rewrite H1. unfold free_Effect in H1.
    destruct (restrictD_Some _ _ _ _ _ H7) as [AIb VISb].
    exploit (Mem.load_inject (as_inj mu) m); try eassumption.
    intros [v [TLD Vinj]]. inv Vinj.
    assert (RP: Mem.range_perm m b0 (Int.unsigned lo - 4)
                               (Int.unsigned lo + Int.unsigned sz) Cur Freeable).
    { eapply Mem.free_range_perm; eauto. }
    exploit Mem.address_inject. eapply MINJ.
    { apply Mem.perm_implies with Freeable; auto with mem.
      apply RP. instantiate (1 := lo). omega. }
    eassumption.
    intro EQ.
    rewrite EQ in *.
    assert (Arith4: Int.unsigned lo - 4 + delta = Int.unsigned lo + delta - 4) by omega.
    rewrite Arith4, TLD in *.
    destruct (eq_block b b2); subst; simpl in *; try inv H1.
    { rewrite H0,H4.
      split. eapply visPropagateR; eassumption.
      intros. exists b0, delta.
      rewrite restrict_vis_foreign_local in H7; trivial.
      destruct (joinD_Some _ _ _ _ _ H7) as [FRG | [FRG LOC]]; clear H7.
      Focus 2. destruct (local_DomRng _ WD _ _ _ LOC). solve[rewrite H3 in H; discriminate].
      split; trivial.
      inv H2.
      destruct (eq_block b0 b0); simpl in *.
      Focus 2. elim n; trivial.
      clear e.
      rewrite !andb_true_iff in H0.
      destruct H0 as [[[? ?] ?] ?].
      destruct (zlt 0 (Int.unsigned sz)); simpl in *; try inv H1.
      destruct (zle (Int.unsigned lo + delta - 4) ofs); simpl in *; try inv H2.
      destruct (zlt ofs (Int.unsigned lo + delta + Int.unsigned sz)); simpl in *; try inv H3.
      destruct (zle (Int.unsigned lo - 4) (ofs - delta)); simpl in *; try omega.
      split. destruct (zlt (ofs - delta) (Int.unsigned lo + Int.unsigned sz)); trivial.
      omega.
      eapply Mem.perm_implies.
      eapply Mem.perm_max. eapply RP. split; trivial. omega.
      constructor.
      congruence. }
    { (*b<>b2*)
      destruct vl'; try congruence.
      rewrite !andb_true_iff in H0.
      destruct H0 as [[[? ?] ?] ?].
      destruct (eq_block b b2). subst. congruence. simpl in H. congruence. }}
  { (*memcpy*)
    simpl in EC. inv EC.
    inv ArgsInj. inv H. inv H2. inv H.
    rewrite H1. unfold memcpy_Effect in H1. inv H.
    inv H0; try congruence.
    inv H3; try congruence.
    inv H4; try congruence.
    destruct (eq_block b b2); subst; simpl in *; try inv H1.
    destruct (zle (Int.unsigned (Int.add odst (Int.repr delta))) ofs); simpl in *; try inv H4.
    destruct (zlt ofs (Int.unsigned (Int.add odst (Int.repr delta)) + sz)); simpl in *; try inv H3.
    destruct (valid_block_dec m2 b2); simpl in *; try inv H4.
    split. eapply visPropagateR; eassumption.
    intros. exists bdst, delta.
    destruct (restrictD_Some _ _ _ _ _ H5).
    exploit Mem.address_inject.
    eapply MINJ.
    eapply Mem.storebytes_range_perm; eauto.
    split. apply Z.le_refl.
    rewrite (Mem.loadbytes_length _ _ _ _ _ H12).
    rewrite nat_of_Z_eq; omega.
    eassumption.
    intros UNSIG; rewrite UNSIG in *.
    assert (MP: Mem.perm m bdst (ofs - delta) Max Nonempty).
    { eapply Mem.perm_implies.
      eapply Mem.perm_max.
      eapply Mem.storebytes_range_perm. eassumption.
      rewrite (Mem.loadbytes_length _ _ _ _ _ H12).
      rewrite nat_of_Z_eq; omega.
      constructor. }
    rewrite (restrict_vis_foreign_local _ WD) in H5.
    destruct (joinD_Some _ _ _ _ _ H5) as [FRG | [FRG LOC]]; clear H5.
    split; trivial. split; trivial.
    destruct (eq_block bdst bdst); simpl. clear e.
    destruct (zle (Int.unsigned odst) (ofs - delta)); simpl.
    destruct (zlt (ofs - delta) (Int.unsigned odst + sz)); simpl.
    destruct (valid_block_dec m bdst); trivial.
    elim n. eapply Mem.perm_valid_block; eassumption.
    omega.
    omega.
    elim n; trivial.
    destruct (local_DomRng _ WD _ _ _ LOC).
    rewrite H5 in H. discriminate.
  inv H8.
  congruence.
  congruence.
  congruence. }
Qed.

Lemma helpers_EmptyEffect: forall {F V:Type} (ge: Genv.t F V)
   hf ef args m,
   EFisHelper hf ef -> (BuiltinEffect ge ef args m = EmptyEffect).
Proof. intros.
destruct ef; simpl in *; try reflexivity.
contradiction. contradiction.
Qed.

Require Import Conventions.
Lemma BuiltinEffect_decode: forall F V (ge: Genv.t F V) ef tls,
 BuiltinEffect ge ef (map tls (loc_arguments (ef_sig ef))) =
 BuiltinEffect ge ef (decode_longs (sig_args (ef_sig ef))
           (map tls (loc_arguments (ef_sig ef)))).
Proof. intros.
  unfold BuiltinEffect. extensionality m.
  destruct ef; trivial.
Qed.

Section EC_DET.

Context (hf : helper_functions)
        {F V : Type} (ge : Genv.t F V) (t1 t2: trace) (m m1 m2:mem).

Definition is_I64_helper' hf ef :=
  match ef with
    | EF_external nm sg => is_I64_helper hf nm sg
    | EF_builtin nm sg => is_I64_helper hf nm sg
    | _ => False
  end.

Lemma is_I64_helper'_dec ef : {is_I64_helper' hf ef}+{~is_I64_helper' hf ef}.
Proof.
destruct ef; simpl; auto.
destruct (is_I64_helper_dec hf name sg); auto.
destruct (is_I64_helper_dec hf name sg); auto.
Qed.

Lemma EC'_determ: forall ef args res1 res2,
      external_call' ef ge args m t1 res1 m1 ->
      external_call' ef ge args m t2 res2 m2 ->
      ~ is_I64_helper' hf ef ->
      ~ observableEF hf ef -> t1=t2.
Proof. intros.
destruct ef; simpl in H2; intuition.
(*EF_malloc*)
inv H; inv H0. simpl in *. destruct args. inv H; inv H2.
    inv H; inv H3. trivial.
(*EF_free*)
inv H; inv H0. simpl in *. destruct args. inv H; inv H2.
    inv H; inv H3. trivial.
(*EF_memcpy*)
inv H; inv H0. simpl in *. destruct args. inv H; inv H2.
   destruct args. inv H; inv H2. inv H; inv H3. trivial.
Qed.

(** i64_helpers_correct axiomatizes the helpers with empty trace (E0).
  Elsewhere in standard CompCert, these functions are give the
  Event_syscall trace (by extcall_io_sem). Here, we just impose
  determinism on the traces (which is consistent with the E0
  axiomatization used, e.g., in Selectlongproof.v). *)

Axiom EC'_i64_helper_determ: forall ef args res1 res2,  (*SEE NOTE ABOVE*)
      external_call' ef ge args m t1 res1 m1 ->
      external_call' ef ge args m t2 res2 m2 ->
      is_I64_helper' hf ef ->
      ~ observableEF hf ef -> t1=t2.

End EC_DET.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Arith.
Require Export Wf_nat.
Require Export Compare_dec.

Require Import Term_const.

Fixpoint div2 (n : nat) : nat :=
  match n with
  | S (S p) => S (div2 p)
  | _ => 0
  end.

Parameter div2_lt : forall x : nat, div2 (S x) < S x.

Recursive Definition log (nat -> nat) lt lt_wf div2_lt
 (forall x : nat,
  log x =
  match x with
  | O => 0
  | S O => 0
  | S (S y) => S (log (div2 (S (S y))))
  end).

Inspect 5.
(* Pour tester pas-à-pas:

Definition log_nat :=
    [log:nat -> nat] [x:nat]
    (Cases x of
        O => (0)
      | (S O) => (O)
      | (S (S y)) => (S (log (div2 (S (S y)))))
     end).

L_Terminate log_nat nat lt lt_wf log_term div2_lt.

Define_from_terminate log nat log_term.

Make_equation log_equation log_nat log log_term
  (x:nat)(log x)=
	(Case (le_gt_dec x (1)) of [h:?] O [h:?] (S (log (div2 x))) end).

 *)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

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

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export per_props_cequiv.
Require Export per_props_function.
Require Export per_props_uni.

Lemma equality_in_mkc_requality {p} :
  forall lib (t1 t2 T a b : @CTerm p),
    equality lib a b (mkc_requality t1 t2 T)
    <=>
    { x1 , x2  : CTerm
    , a ===>(lib) (mkc_refl x1)
    # b ===>(lib) (mkc_refl x2)
    # equality lib t1 t2 T
    # equality lib t1 x1 T
    # equality lib t2 x2 T }.
Proof.
  introv; split; intro i.

  - unfold equality in i; exrepnd.
    inversion i1; subst; try not_univ.

    match goal with
    | [ H : per_req _ _ _ _ _ |- _ ] => rename H into h
    end.

    unfold per_req in h; exrepnd; spcast; computes_to_value_isvalue.
    fold (nuprl lib) in *.
    apply h0 in i0.
    unfold per_req_eq in i0; exrepnd.
    exists x1 x2; dands; auto;
      try (complete (eapply eq_equality1;eauto)).

  - exrepnd.
    unfold equality in i3; exrepnd.
    exists (per_req_eq lib t1 t2 eq).
    dands; auto.

    + apply CL_req.
      exists T T t1 t2 t1 t2 eq; dands; spcast; eauto 3 with slow;
        right; spcast; auto.

    + exists x1 x2; dands; auto; try (complete (eapply equality_eq1; eauto)).
Qed.

(* !!MOVE *)
Hint Resolve tequality_if_nuprl : slow.

(* !!MOVE *)
Lemma tequality_implies_type_left {p} :
  forall lib (A B : @CTerm p),
    tequality lib A B -> type lib A.
Proof.
  introv teq.
  unfold type.
  eapply tequality_refl; eauto.
Qed.
Hint Resolve tequality_implies_type_left : slow.

(* !!MOVE *)
Lemma tequality_implies_type_right {p} :
  forall lib (A B : @CTerm p),
    tequality lib A B -> type lib B.
Proof.
  introv teq.
  unfold type.
  apply tequality_sym in teq.
  eapply tequality_refl; eauto.
Qed.
Hint Resolve tequality_implies_type_right : slow.

(* !!MOVE *)
Hint Resolve eq_equality1 : slow.

Lemma tequality_mkc_requality {p} :
  forall lib (a1 a2 b1 b2 A B : @CTerm p),
    tequality lib (mkc_requality a1 a2 A) (mkc_requality b1 b2 B)
    <=>
    (
      tequality lib A B
      # equorsq lib a1 b1 A
      # equorsq lib a2 b2 A
    ).
Proof.
  introv; split; intro h.

  - unfold tequality in h; exrepnd.
    inversion h0; subst; try not_univ.

    match goal with
    | [ H : per_req _ _ _ _ _ |- _ ] => rename H into h
    end.

    unfold per_req in h; exrepnd; spcast; computes_to_value_isvalue.
    fold (nuprl lib) in *.
    dands; eauto 3 with slow; eapply eqorceq_iff_equorsq; eauto.

  - repnd.
    unfold tequality in h0; exrepnd.
    rename eq into eqa.
    exists (per_req_eq lib a1 a2 eqa).
    apply CL_req.
    exists A B a1 a2 b1 b2 eqa; dands; spcast; eauto 3 with slow;
      eapply eqorceq_iff_equorsq; eauto.
Qed.

Lemma equality_in_mkc_rmember {p} :
  forall lib (t T a b : @CTerm p),
    equality lib a b (mkc_rmember t T)
    <=>
    { x1 , x2  : CTerm
    , a ===>(lib) (mkc_refl x1)
    # b ===>(lib) (mkc_refl x2)
    # equality lib t x1 T
    # equality lib t x2 T }.
Proof.
  introv.
  allrw <- @fold_mkc_rmember.
  rw @equality_in_mkc_requality.
  split; intro h; exrepnd; exists x1 x2; dands; auto.
  eapply equality_refl; eauto.
Qed.

Lemma tequality_mkc_rmember {p} :
  forall lib (a b A B : @CTerm p),
    tequality lib (mkc_rmember a A) (mkc_rmember b B)
    <=>
    (
      tequality lib A B
      # equorsq lib a b A
    ).
Proof.
  introv.
  allrw <- @fold_mkc_rmember.
  rw @tequality_mkc_requality; split; tcsp.
Qed.


From iris Require Import invariants.
From iris.algebra Require Import gmap frac agree frac_auth.
From iris.base_logic Require Export gen_heap.
From iris.base_logic.lib Require Export own saved_prop.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Import tactics.
From stdpp Require Import base.
From distris Require Import lifting tactics proofmode notation adequacy.
From distris.examples.library Require Import code.
From iris.proofmode Require Import coq_tactics.
From iris.proofmode Require Export tactics.

Set Default Proof Using "Type".

Import Network.
Import String.
Import uPred.

Section strings.

  Lemma append_nil_l s :
    "" +:+ s = s.
  Proof. done. Qed.

  Lemma append_cons s1 :
    ∀ s2 a, String a (s1 +:+ s2) = (String a s1) +:+ s2.
  Proof.
    induction s1; intros.
    - by rewrite append_nil_l.
    - rewrite -IHs1. done.
  Qed.

  Lemma append_assoc s1 s2 s3 :
    s1 +:+ s2 +:+ s3 = (s1 +:+ s2) +:+ s3.
  Proof.
    induction s1.
    - by rewrite !append_nil_l.
    - by rewrite -append_cons IHs1 append_cons.
  Qed.

  Lemma length_Sn a s :
    length (String a s) = S (length s).
  Proof. by cbn. Qed.

  Lemma length_app s1 :
    ∀ s2, length (s1 +:+ s2) = length s1 + length s2.
  Proof.
   induction s1; intros.
    - by rewrite append_nil_l.
    - by rewrite -append_cons !length_Sn IHs1.
  Qed.

  Lemma prefix_empty_true s :
    prefix "" s = true.
  Proof. destruct s; cbn; auto. Qed.

  Lemma index_0_empty s :
    index 0 "" s = Some 0.
  Proof. destruct s; by cbn. Qed.

  Lemma index_prefix_true s s' :
    index 0 s s' = Some 0 →
    prefix s s' = true.
  Proof.
    destruct s,s'; simpl; cbn; auto.
    - intro; inversion H.
    - intro; destruct ascii_dec.
      + destruct (prefix s s'); auto; destruct (index 0 _ s'); inversion H.
      + destruct (index 0 _ s'); inversion H.
  Qed.

  Lemma index_cons_0_eq a s s' :
    index 0 s s' = Some 0 → index 0 (String a s) (String a s') = Some 0.
  Proof.
    intros Hindex.
    cbn. destruct ascii_dec.
    - assert (Hprefix: prefix s s' = true).
      { by apply index_prefix_true. }
        by rewrite Hprefix.
    - by destruct n.
  Qed.

  Lemma index_append_here s t :
    index 0 s (s +:+ t) = Some 0.
  Proof.
    induction s.
    - apply index_0_empty.
    - apply index_cons_0_eq.
      apply IHs.
  Qed.

  Lemma index_0_append_char a t v s :
    s = String a "" →
    index 0 s t = None →
    index 0 s (t +:+ s +:+ v) = Some (length t).
  Proof.
    induction t; intros.
    - rewrite append_nil_l. apply index_append_here.
    - rewrite H. rewrite -append_cons. cbn.
      destruct ascii_dec; subst. cbn in H0. destruct ascii_dec.
      rewrite prefix_empty_true in H0. inversion H0.
      by destruct n.
      rewrite IHt; auto. cbn in H0. destruct ascii_dec. by destruct n.
      destruct index; auto. inversion H0.
  Qed.

  Lemma substring_0_length s :
    substring 0 (length s) s = s.
  Proof. induction s; simpl; auto. by rewrite IHs. Qed.

  Lemma substring_Sn a n m s :
    substring (S n) m (String a s) = substring n m s.
  Proof. induction s; destruct n,m; simpl; auto. Qed.

  Lemma substring_add_length_app n m s1 :
    ∀ s2, substring (length s1 + n) m (s1 +:+ s2) = substring n m s2.
  Proof. induction s1; destruct n,m; simpl; auto. Qed.

  Lemma substring_0_length_append s1 s2 :
    substring 0 (length s1) (s1 +:+ s2) = s1.
  Proof. apply prefix_correct, index_prefix_true, index_append_here. Qed.

  Lemma substring_length_append s1 :
    ∀ s2, substring (length s1) (length s2) (s1 +:+ s2) = s2.
  Proof.
    induction s1; intros s2.
    - rewrite append_nil_l. apply substring_0_length.
    - rewrite length_Sn substring_Sn. apply IHs1.
  Qed.

End strings.

Section library.
  Context `{cG : ccounterG Σ}
          `{dG : distG Σ}
          `{siG : socketInterpG Σ}.

Lemma wp_assert n E (Φ : val → iProp Σ) e `{!Closed [] ⟨n;e⟩} :
  WP ⟨n;e⟩ @ E {{ v, ⌜v = 〈n;#true〉⌝ ∧ ▷ Φ 〈n;#()〉 }} -∗ WP ⟨n;assert: e⟩ @ E {{ Φ }}.
Proof.
  iIntros "HΦ". rewrite /assert /=.
  wp_lam. rewrite /ground_lang.subst.
  wp_let.
  wp_apply (wp_wand with "HΦ").
  iIntros (v) "[% ?]"; subst.  by wp_if.
Qed.

Lemma unSOME_spec n e v v' :
  IntoVal ⟨n;e⟩ 〈n;v〉 →
  {{{ ⌜v = SOMEV v'⌝ }}}
    ⟨n;unSOME e⟩
  {{{ RET 〈n;v'〉; True }}}.
Proof.
  iIntros (<-%to_base_val'%ground_lang.of_to_val Φ ->) "HΦ".
  wp_lam. wp_match. by iApply "HΦ".
Qed.

Lemma listen_spec P Q n (h : socket_handle) (s : socket) (a : socket_address)
        (rm : message_soup)
        (handler : ground_lang.expr) :
  AsVal ⟨n;handler⟩ →
  saddress s = Some a →
  (∀ mId m φ,
      {{{ ⌜received_message_info a m⌝ ∗ P ∗ h s↦[n] s ∗ a r↦{½} (<[mId:=m]>rm) ∗
           mId m↦{¾} m ∗ a ⤇ φ ∗ φ (message_stable_from_message m) }}}
        ⟨n;handler #(m_body m) #(m_sender m)⟩
      {{{ v, RET 〈n;v〉; Q v }}}) -∗
  {{{ P ∗ h s↦[n] s ∗ a r↦{½} rm }}}
     ⟨ n; listen (Lit $ LitSocket h) handler ⟩
  {{{ v, RET 〈n;v〉; Q v }}}.
Proof.
  iIntros ([[m handlerV] Hval%of_to_val] Haddr) "#Hhandler";
    inversion Hval;simplify_eq.
  iLöb as "IH".
  iAlways. iIntros (Φ) "(HP & Hsocket & Hrecs) HΦ".
  wp_rec.
  wp_let.
  wp_apply (wp_receive_from _ _ a with "[$Hsocket $Hrecs]"); first done.
  iIntros (r) "HQ".
  iDestruct "HQ" as (rm') "(Hsocket & Hrecs & [HQ | [% %]])".
  - iDestruct "HQ" as (mId message φ) "(Hrec & % & % & Hm & Hsi)"; subst.
    wp_match. wp_proj.
    wp_let. wp_proj.
    wp_apply ("Hhandler" with "[-HΦ] [HΦ]"); last iFrame. iFrame.
  - subst. wp_match.
    iApply ("IH" with "[-HΦ]"). iFrame. iFrame.
Qed.

Lemma listen_wait_spec n (h : socket_handle) (s : socket) (a : socket_address)
        (rm : message_soup) φ :
  saddress s = Some a →
  {{{ h s↦[n] s ∗ a r↦{½} rm ∗ a ⤇ φ}}}
     ⟨ n; listen_wait (Lit $ LitSocket h) ⟩
  {{{ m mId, RET 〈n;(#(m_body m), #(m_sender m))〉;
      ⌜received_message_info a m⌝ ∗ h s↦[n] s ∗ a r↦{½} (<[mId:=m]>rm) ∗
      mId m↦{¾} m ∗ φ (message_stable_from_message m)
  }}}.
Proof.
  iIntros (Haddr Φ) "(Hs & Hrec & Hφ) HΦ".
  iLöb as "IH".
  wp_rec.
  wp_apply (wp_receive_from with "[$Hs $Hrec]"); first done.
  iIntros (r) "HQ"; iDestruct "HQ" as (rm') "(Hs & Hrec & [HQ | [-> ->]])"; simpl.
  - iDestruct "HQ" as (mId message φ' Hri Hm Hrecs) "(Hm & Hφ' & HP)"; subst.
    iDestruct (si_pred_agree _ _ _ (message_stable_from_message message) with "Hφ Hφ'") as "#Heqv".
    wp_match. iApply "HΦ". iRewrite -"Heqv" in "HP". by iFrame.
  - wp_match. iApply ("IH" with "Hs Hrec Hφ"). iFrame.
Qed.

Definition valid_tag t := index 0 "_" t = None.

Lemma tag_of_message_spec n m (s : string) t v:
  IntoVal ⟨n;m⟩ 〈n;#s〉 →
  valid_tag t →
  {{{ ⌜s = t +:+ "_" +:+ v⌝ }}}
    ⟨n;tag_of_message m⟩
  {{{ v, RET 〈n;#v〉; ⌜v = t⌝ }}}.
Proof.
  iIntros (Hv%to_base_val' Htag Φ HP) "HΦ".
  apply ground_lang.of_to_val in Hv; simplify_eq.
  wp_let. wp_find_from. split; eauto.
    by instantiate (1:=0%nat).
  rewrite (index_0_append_char "_"); auto. simpl. wp_match.
  wp_substring. repeat split; eauto. by instantiate (1:=0%nat).
  rewrite substring_0_length_append. by iApply "HΦ".
Qed.

Lemma value_of_message_spec n m (s : string) t v :
  IntoVal ⟨n;m⟩ 〈n;#s〉 →
  valid_tag t →
  {{{ ⌜s = t +:+ "_" +:+ v⌝ }}}
    ⟨n;value_of_message m⟩
  {{{ r, RET 〈n;#r〉; ⌜r = v⌝ }}}.
Proof.
  iIntros (Hv%to_base_val' Htag Φ HP) "HΦ".
  apply ground_lang.of_to_val in Hv; simplify_eq.
  wp_let. wp_find_from; simpl. split; eauto.
  { by instantiate (1:=0%nat). }
  rewrite (index_0_append_char "_"); auto; simpl; wp_match.
  wp_op. wp_let.
  wp_op. wp_let.
  wp_op.
  wp_substring. repeat split; eauto.
  instantiate (1:=(length t + 1)%nat). apply Nat2Z.inj_add.
  instantiate (1:=(length v)%nat).
  { rewrite !length_app plus_assoc length_Sn /= !Nat2Z.inj_add. ring. }
  rewrite substring_add_length_app substring_Sn substring_0_length.
  by iApply "HΦ".
Qed.

Fixpoint list_coh l v :=
  match l with
  | [] => v = NONEV
  | a::l' => ∃ lv : ground_lang.val, v = SOMEV (a,lv) ∧ list_coh l' lv
  end.

Lemma list_make_spec n :
  {{{ True }}}
       ⟨n;list_make #()⟩
  {{{ v, RET 〈n;v〉; ⌜list_coh [] v⌝}}}.
Proof.
  iIntros (Φ) "H HΦ". rewrite /list_make /=.
  wp_lam. by iApply "HΦ".
Qed.

Lemma list_cons_spec n (e1 e2 : ground_lang.expr) a lv l :
  IntoVal ⟨n;e1⟩ 〈n;a〉 →
  IntoVal ⟨n;e2⟩ 〈n;lv〉 →
  {{{ ⌜list_coh l lv⌝ }}}
       ⟨n;list_cons e1 e2⟩
  {{{ v, RET 〈n;v〉; ⌜list_coh (a::l) v⌝}}}.
Proof.
  iIntros (<-%to_base_val'%ground_lang.of_to_val
              <-%to_base_val'%ground_lang.of_to_val Φ) "% HΦ".
  wp_lam.
  wp_let.
  iApply "HΦ".
  iPureIntro. by exists lv.
Qed.

Lemma list_head_spec n e lv l :
  IntoVal ⟨n;e⟩ 〈n;lv〉 →
  {{{ ⌜list_coh l lv⌝ }}}
       ⟨n;list_head e⟩
  {{{ v, RET 〈n;v〉; ⌜(l = [] ∧ v = NONEV) ∨
                      (∃ v' l', l = v' :: l' ∧ v = SOMEV v')⌝}}}.
Proof.
  iIntros (<-%to_base_val'%ground_lang.of_to_val Φ) "% HΦ".
  wp_lam. destruct l; simpl in *; subst.
  - wp_match. iApply "HΦ". iPureIntro. by left.
  - destruct a as [lv' [Hhead Htail]] eqn:Heq; subst.
    wp_match. wp_proj. iApply "HΦ". iPureIntro. right. by exists v,l.
Qed.

Lemma list_tail_spec n e lv l :
  IntoVal ⟨n;e⟩ 〈n;lv〉 →
  {{{ ⌜list_coh l lv⌝ }}}
       ⟨n;list_tail e⟩
  {{{ v, RET 〈n;v〉; ⌜list_coh (tail l) v⌝}}}.
Proof.
  iIntros (<-%to_base_val'%ground_lang.of_to_val Φ) "% HΦ".
  wp_lam. destruct l; simpl in *; subst.
  - wp_match. by iApply "HΦ".
  - destruct a as [lv' [Hhead Htail]] eqn:Heq; subst.
    wp_match. wp_proj. by iApply "HΦ".
Qed.

Lemma list_length_spec n e l lv :
  IntoVal ⟨n;e⟩ 〈n;lv〉 →
  {{{ ⌜list_coh l lv⌝ }}}
    ⟨n;list_length lv⟩
  {{{ v, RET 〈n;#v〉; ⌜v = List.length l⌝ }}}.
Proof.
  iIntros (<-%to_base_val'%ground_lang.of_to_val Φ) "Ha HΦ".
  iInduction l as [|a l'] "IH" forall (lv Φ);
  iDestruct "Ha" as %Ha; simpl in Ha; subst; wp_rec.
  - wp_match. iApply ("HΦ" $! 0 : nat). auto.
  - destruct Ha as [lv' [Hlv Hlcoh]]; subst.
    wp_match. wp_proj. wp_bind (list_length _).
    iApply ("IH" $! _ _ Hlcoh). iNext. iIntros; simpl.
    wp_op. iSpecialize ("HΦ" $! (1 + v)). rewrite Nat2Z.inj_add. iApply "HΦ".
    eauto.
Qed.

Lemma list_iter_spec {A} n e (l : list A) lv handler P Φ Ψ
      (toval : A -> ground_lang.val) :
  AsVal ⟨n;handler⟩ →
  IntoVal ⟨n;e⟩ 〈n;lv〉 →
  (∀ (a : A),
  {{{ ⌜a ∈ l⌝ ∗ P ∗ Φ a }}}
     ⟨n;handler (toval a)⟩
  {{{v, RET 〈n;v〉; P ∗ Ψ a }}}) -∗
  {{{ ⌜list_coh (map (λ a, toval a) l) lv⌝ ∗ P ∗ [∗ list] a∈l, Φ a }}}
    ⟨n;list_iter handler lv⟩
  {{{ RET 〈n;#()〉; P ∗ [∗ list] a∈l, Ψ a }}}.
Proof.
  iIntros ([[m handlerV] Hval%of_to_val] <-%to_base_val'%ground_lang.of_to_val).
  inversion Hval; simplify_eq.
  iInduction l as [|a l'] "IH" forall (lv);
  iIntros "#Helem"; iIntros (Φ') "!# (Ha & HP & Hl) HΦ";
  iDestruct "Ha" as %Ha; simpl in Ha; subst; wp_rec; wp_let.
  - wp_match. iApply "HΦ"; eauto.
  - assert (Helemof: a ∈ a :: l').
    { apply elem_of_list_here. }
    destruct Ha as [lv' [Hlv Hlcoh]]; subst.
    wp_match. wp_proj. wp_let. wp_proj.
    iDestruct (big_sepL_cons with "Hl") as "[Ha Hl']".
    wp_apply ("Helem" with "[HP Ha]"); iFrame; eauto.
    iIntros (v) "[HP Ha]". simpl. wp_seq.
    iApply ("IH" with "[] [$HP $Hl']"); eauto.
    { iIntros (a' HΦ'') "!# (% & HP & Ha) HΦ''".
      wp_apply ("Helem" with "[HP Ha]"); iFrame.
      iPureIntro. by apply elem_of_list_further.
    }
    iNext. iIntros "(HP & Hl)". iApply "HΦ". iFrame.
Qed.

Lemma list_fold_spec {A} n handler (l : list A) e1 e2 acc lv P Φ Ψ
      (toval : A -> ground_lang.val) :
  AsVal ⟨n;handler⟩ →
  IntoVal ⟨n;e1⟩ 〈n;acc〉 →
  IntoVal ⟨n;e2⟩ 〈n;lv〉 →
  (∀ (a : A) acc lacc lrem,
  {{{ ⌜l = lacc ++ a :: lrem⌝ ∗ P lacc acc ∗ Φ a }}}
     ⟨n;handler acc (toval a)⟩
  {{{v, RET 〈n;v〉; P (lacc ++ [a]) v ∗ Ψ a }}}) -∗
  {{{ ⌜list_coh (map (λ a, toval a) l) lv⌝ ∗ P [] acc ∗ [∗ list] a∈l, Φ a }}}
    ⟨n; list_fold handler acc lv⟩
  {{{v, RET 〈n;v〉; P l v ∗ [∗ list] a∈l, Ψ a }}}.
Proof.
  iIntros ([[m handlerV] Hval%of_to_val]
             <-%to_base_val'%ground_lang.of_to_val
             <-%to_base_val'%ground_lang.of_to_val
          ).
  iIntros "#Hcl". iIntros (Ξ) "!# (Hl & Hacc & HΦ) HΞ".
  change l with ([] ++ l) at 1 4.
  generalize (@nil A) at 1 3 4 as lproc => lproc.
  inversion Hval; simplify_eq.
  iInduction l as [|x l] "IHl" forall (Ξ lproc acc lv) "Hacc Hl HΞ".
  - iDestruct "Hl" as %?; simpl in *; simplify_eq.
    repeat wp_rec.
    wp_match. iApply "HΞ".
    rewrite app_nil_r; iFrame.
  - iDestruct "Hl" as %[lw [? Hlw]]; subst.
    iDestruct "HΦ" as "[Hx HΦ]".
    repeat wp_rec. wp_match.
    wp_proj. wp_let. wp_proj. wp_let.
    wp_apply ("Hcl" with "[$Hacc $Hx] [-]"); auto.
    iNext. iIntros (w) "[Hacc HΨ]"; simpl.
    wp_let.
    iApply ("IHl" with "[] [$HΦ] [$Hacc] [] [HΨ HΞ]"); [|auto|].
    { rewrite -app_assoc; auto. }
    iNext. iIntros (v) "[HP HΨs]".
    rewrite -app_assoc.
    iApply "HΞ"; iFrame.
Qed.

Lemma list_fold_spec'_generalized {A} n handler (l lp : list A) e1 e2 acc lv P Φ Ψ
      (toval : A -> ground_lang.val) :
  AsVal ⟨n;handler⟩ →
  IntoVal ⟨n;e1⟩ 〈n;acc〉 →
  IntoVal ⟨n;e2⟩ 〈n;lv〉 →
  □ (∀ (a : A) acc lacc lrem, (P lacc acc None (a::lrem) -∗ P lacc acc (Some a) lrem))%I -∗
  (∀ (a : A) acc lacc lrem,
  {{{ ⌜lp ++ l = lacc ++ a :: lrem⌝ ∗ P lacc acc (Some a) lrem ∗ Φ a }}}
     ⟨n;handler acc (toval a)⟩
  {{{v, RET 〈n;v〉; P (lacc ++ [a]) v None lrem ∗ Ψ a }}}) -∗
  {{{ ⌜list_coh (map (λ a, toval a) l) lv⌝ ∗ P lp acc None l ∗ [∗ list] a∈l, Φ a }}}
    ⟨n; list_fold handler acc lv⟩
  {{{v, RET 〈n;v〉; P (lp ++ l) v None [] ∗ [∗ list] a∈l, Ψ a }}}.
Proof.
  iIntros ([[m handlerV] Hval%of_to_val]
             <-%to_base_val'%ground_lang.of_to_val
             <-%to_base_val'%ground_lang.of_to_val
          ).
  iIntros "#Hvs #Hcl". iIntros (Ξ) "!# (Hl & Hacc & HΦ) HΞ".
  (* change l with ([] ++ l) at 1. *)
  (* generalize (@nil A) at 1 as lproc => lproc. *)
  inversion Hval; simplify_eq.
  iInduction l as [|x l] "IHl" forall (Ξ lp acc lv) "Hacc Hl HΞ".
  - iDestruct "Hl" as %?; simpl in *; simplify_eq.
    repeat wp_rec.
    wp_match. iApply "HΞ".
    rewrite app_nil_r; iFrame.
  - iDestruct "Hl" as %[lw [? Hlw]]; subst.
    iDestruct "HΦ" as "[Hx HΦ]".
    repeat wp_rec. wp_match.
    wp_proj. wp_let. wp_proj. wp_let.
    iPoseProof ("Hvs" with "Hacc") as "Hacc".
    wp_apply ("Hcl" with "[$Hacc $Hx] [-]"); auto.
    iNext. iIntros (w) "[Hacc HΨ]"; simpl.
    wp_let.
    iApply ("IHl" with "[] [$HΦ] [$Hacc] [] [HΨ HΞ]"); [|auto|].
    { rewrite -app_assoc; auto. }
    iNext. iIntros (v) "[HP HΨs]".
    rewrite -app_assoc.
    iApply "HΞ"; iFrame.
Qed.

Lemma list_fold_spec' {A} n handler (l : list A) e1 e2 acc lv P Φ Ψ
      (toval : A -> ground_lang.val) :
  AsVal ⟨n;handler⟩ →
  IntoVal ⟨n;e1⟩ 〈n;acc〉 →
  IntoVal ⟨n;e2⟩ 〈n;lv〉 →
  □ (∀ (a : A) acc lacc lrem, (P lacc acc None (a::lrem) -∗ P lacc acc (Some a) lrem))%I -∗
  (∀ (a : A) acc lacc lrem,
  {{{ ⌜l = lacc ++ a :: lrem⌝ ∗ P lacc acc (Some a) lrem ∗ Φ a }}}
     ⟨n;handler acc (toval a)⟩
  {{{v, RET 〈n;v〉; P (lacc ++ [a]) v None lrem ∗ Ψ a }}}) -∗
  {{{ ⌜list_coh (map (λ a, toval a) l) lv⌝ ∗ P [] acc None l ∗ [∗ list] a∈l, Φ a }}}
    ⟨n; list_fold handler acc lv⟩
  {{{v, RET 〈n;v〉; P l v None [] ∗ [∗ list] a∈l, Ψ a }}}.
Proof.
  iIntros (? ? ?) "#Hvs #Hcl".
  iApply (list_fold_spec'_generalized _ handler l [] with "[-]"); eauto.
Qed.

End library.