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

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

(** Value analysis for PowerPC operators *)

Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
  | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
  | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
  | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
  | Cmaskzero n, v1 :: nil => maskzero v1 n
  | Cmasknotzero n, v1 :: nil => cnot (maskzero v1 n)
  | _, _ => Bnone
  end.

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

Definition eval_static_operation (op: operation) (vl: list aval): aval :=
  match op, vl with
  | Omove, v1::nil => v1
  | Ointconst n, nil => I n
  | Ofloatconst n, nil => if propagate_float_constants tt then F n else ftop
  | Osingleconst n, nil => if propagate_float_constants tt then FS n else ftop
  | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
  | Oaddrstack ofs, nil => Ptr (Stk ofs)
  | Ocast8signed, v1 :: nil => sign_ext 8 v1
  | Ocast16signed, v1 :: nil => sign_ext 16 v1
  | Oadd, v1::v2::nil => add v1 v2
  | Oaddimm n, v1::nil => add v1 (I n)
  | Oaddsymbol id ofs, v1::nil => add (Ptr (Gl id ofs)) v1
  | Osub, v1::v2::nil => sub v1 v2
  | Osubimm n, v1::nil => sub (I n) v1
  | Omul, v1::v2::nil => mul v1 v2
  | Omulimm n, v1::nil => mul v1 (I n)
  | Omulhs, v1::v2::nil => mulhs v1 v2
  | Omulhu, v1::v2::nil => mulhu v1 v2
  | Odiv, v1::v2::nil => divs v1 v2
  | Odivu, v1::v2::nil => divu v1 v2
  | Oand, v1::v2::nil => and v1 v2
  | Oandimm n, v1::nil => and v1 (I n)
  | Oor, v1::v2::nil => or v1 v2
  | Oorimm n, v1::nil => or v1 (I n)
  | Oxor, v1::v2::nil => xor v1 v2
  | Oxorimm n, v1::nil => xor v1 (I n)
  | Onot, v1::nil => notint v1
  | Onand, v1::v2::nil => notint(and v1 v2)
  | Onor, v1::v2::nil => notint(or v1 v2)
  | Onxor, v1::v2::nil => notint(xor v1 v2)
  | Oandc, v1::v2::nil => and v1 (notint v2)
  | Oorc, v1::v2::nil => or v1 (notint v2)
  | Oshl, v1::v2::nil => shl v1 v2
  | Oshr, v1::v2::nil => shr v1 v2
  | Oshrimm n, v1::nil => shr v1 (I n)
  | Oshrximm n, v1::nil => shrx v1 (I n)
  | Oshru, v1::v2::nil => shru v1 v2
  | Orolm amount mask, v1::nil => rolm v1 amount mask
  | Oroli amount mask, v1::v2::nil => or (and v1 (I (Int.not mask))) (rolm v2 amount mask)
  | Onegf, v1::nil => negf v1
  | Oabsf, v1::nil => absf v1
  | Oaddf, v1::v2::nil => addf v1 v2
  | Osubf, v1::v2::nil => subf v1 v2
  | Omulf, v1::v2::nil => mulf v1 v2
  | Odivf, v1::v2::nil => divf v1 v2
  | Onegfs, v1::nil => negfs v1
  | Oabsfs, v1::nil => absfs v1
  | Oaddfs, v1::v2::nil => addfs v1 v2
  | Osubfs, v1::v2::nil => subfs v1 v2
  | Omulfs, v1::v2::nil => mulfs v1 v2
  | Odivfs, v1::v2::nil => divfs v1 v2
  | Osingleoffloat, v1::nil => singleoffloat v1
  | Ofloatofsingle, v1::nil => floatofsingle v1
  | Ointoffloat, v1::nil => intoffloat v1
  | Ofloatofwords, v1::v2::nil => floatofwords v1 v2
  | Omakelong, v1::v2::nil => longofwords v1 v2
  | Olowlong, v1::nil => loword v1
  | Ohighlong, v1::nil => hiword v1
  | Ocmp c, _ => of_optbool (eval_static_condition c vl)
  | _, _ => Vbot
  end.

Section SOUNDNESS.

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

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

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

Hint Resolve symbol_address_sound: va.

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

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

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

End SOUNDNESS.


(*
 * Copyright (c) Meta Platforms, Inc. and affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)
From stdpp Require Import base strings gmap stringmap fin_maps.
From iris.base_logic Require Import upred derived.
From iris.base_logic.lib Require Import iprop own.
From iris.algebra Require Import ofe cmra gmap_view.
From iris.proofmode Require Import tactics.

From shack Require Import lang progdef subtype ok.
From shack Require Import eval heap modality interp typing.

Section proofs.
  (* assume a given set of class definitions and their SDT annotations. *)
  Context `{SDTCVS: SDTClassVarianceSpec}.

  (* Iris semantic context *)
  Context `{!sem_heapGS Θ}.
  Notation γ := sem_heap_name.

  Notation "X ≡≡ Y" := (∀ (w: value), X w ∗-∗ Y w)%I (at level 50, no associativity).

  Lemma interp_local_tys_update Σthis Σ v Γ Ω ty val :
    interp_local_tys Σthis Σ Γ Ω -∗
    interp_type ty Σthis Σ val -∗
    interp_local_tys Σthis Σ (<[v:=ty]>Γ) (<[v:=val]>Ω).
  Proof.
    iIntros "#[Hthis Hi] #?".
    iSplit; first done.
    iIntros (v' ty') "H".
    rewrite lookup_insert_Some.
    iDestruct "H" as %[[<- <-]|[??]].
    - iExists _. rewrite lookup_insert. by iSplit.
    - rewrite lookup_insert_ne; last done. by iApply "Hi".
  Qed.

  (* heap models relation; the semantic heap does
     not appear because it is hidden in iProp  *)
  (* Helper defintion to state that fields are correctly modeled *)
  Definition heap_models_fields
    (iFs: gmapO string (sem_typeO Θ)) (vs: stringmap value) : iProp Θ :=
    ⌜dom vs ≡ dom iFs⌝  ∗
    ∀ f (iF: sem_typeO Θ),
    iFs !! f ≡ Some iF -∗ ∃ v, (⌜vs !! f = Some v⌝ ∗ iF v).

  Definition heap_models (h : heap) : iProp Θ :=
    ∃ (sh: gmap loc (prodO tagO (laterO (gmapO string (sem_typeO Θ))))),
    own γ (gmap_view_auth (DfracOwn 1) sh) ∗ ⌜dom sh = dom h⌝ ∗
    □ ∀ (ℓ : loc) (t : tag) (vs : stringmap value),
    ⌜h !! ℓ = Some (t, vs)⌝ -∗
    ∃ (iFs : gmapO string (sem_typeO Θ)),
    sh !! ℓ ≡ Some (t, Next iFs) ∗ ▷ heap_models_fields iFs vs.

  (* TODO: try to refactor them up like before *)
  Lemma heap_models_update_pub Δ Σ h l t1 vs exact_ t σ  f fty orig v:
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _cname, wf_cdef_fields) pdefs →
    map_Forall (λ _cname, wf_cdef_fields_bounded) pdefs →
    map_Forall (λ _ : string, wf_cdef_fields_wf) pdefs →
    map_Forall (λ _cname, wf_field_mono) pdefs →
    map_Forall (λ _ : string, wf_cdef_mono) pdefs →
    map_Forall (λ _ : string, wf_cdef_constraints_wf) pdefs →
    Forall wf_constraint Δ →
    wf_ty (ClassT exact_ t σ) →
    h !! l = Some (t1, vs) →
    has_field f t Public fty orig →
    is_true exact_ ∨ no_this fty →
    ∀ t0 Σt0,
    let Σthis0 := interp_exact_tag interp_type t0 Σt0 in
    □ interp_env_as_mixed Σt0 -∗
    □ interp_env_as_mixed Σ -∗
    □ Σinterp Σthis0 Σ Δ -∗
    interp_type (ClassT exact_ t σ) Σthis0 Σ (LocV l) -∗
    interp_type (subst_fty exact_ t σ fty) Σthis0 Σ v -∗
    heap_models h -∗
    heap_models (<[l:=(t1, <[f:=v]> vs)]> h).
  Proof.
    move => ???????? hwf hheap hf hex.
    move => t0 Σt0 Σthis0.
    iIntros "#hΣt0 #hΣ #hΣΔ #hrecv #hv Hh".
    assert (hh : ∃ tdef, pdefs !! t = Some tdef ∧
      length σ = length tdef.(generics)).
    { apply wf_tyI in hwf as (? & ? & ? & ?).
      by eauto.
    }
    destruct hh as (tdef & htdef & hlenσ).
    destruct exact_.
    - (* Public access on exact type *)
      rewrite interp_exact_tag_unfold interp_exact_tag_unseal /interp_exact_tag_def /=.
      iDestruct "hrecv" as (? tdef' fields ifields hpure) "(#hconstr & #hfields & hl)".
      destruct hpure as ([= <-] & htdef' & hfields & hdomfields); simplify_eq.
      iDestruct "Hh" as (sh) "(hown & %hdom & #h)".
      iExists sh.
      iDestruct (sem_heap_own_valid_2 with "hown hl") as "#Hv".
      iSplitL "hown"; first by iFrame.
      iSplitR.
      { iPureIntro.
        by rewrite hdom dom_insert_lookup_L.
      }
      iModIntro.
      iIntros (l'' t'' vs'') "%Heq".
      rewrite lookup_insert_Some in Heq.
      destruct Heq as [[<- [= <- <-]] | [hne hl]]; last first.
      { iApply "h".
        by iPureIntro.
      }
      iSpecialize ("h" $! l t1 vs with "[//]").
      iDestruct "h" as (iFs) "[#hsh hmodels]".
      iExists iFs; iSplit; first done.
      iRewrite "Hv" in "hsh".
      rewrite !option_equivI prod_equivI /=.
      iDestruct "hsh" as "[%ht #hifs]".
      fold_leibniz; subst.
      iSpecialize ("hfields" $! f Public fty orig hf).
      rewrite later_equivI.
      iNext.
      iDestruct "hfields" as (iF) "(#hiF & #hiff)".
      iAssert (⌜is_Some (iFs !! f)⌝)%I as "%hiFs".
      { iRewrite -"hifs".
        by iRewrite "hiF".
      }
      rewrite /heap_models_fields.
      iDestruct "hmodels" as "[%hdomv #hmodfs]".
      iSplit.
      { iPureIntro.
        by rewrite -hdomv dom_insert_lookup // -elem_of_dom hdomv elem_of_dom.
      }
      iIntros (f' iF') "#hf'".
      destruct (decide (f = f')) as [-> | hne]; last first.
      { rewrite lookup_insert_ne //.
        by iApply "hmodfs".
      }
      rewrite lookup_insert.
      iExists v; iSplitR; first done.
      iRewrite -"hifs" in "hf'".
      iRewrite "hiF" in "hf'".
      rewrite !option_equivI discrete_fun_equivI.
      iSpecialize ("hf'" $! v).
      iRewrite -"hf'".
      iApply "hiff".
      rewrite interp_type_subst; last first.
      { apply bounded_subst_this; last by (constructor; by apply bounded_gen_targs).
        apply has_field_bounded in hf => //.
        destruct hf as (def' & hdef' & hfty).
        apply wf_tyI in hwf as (? & ? & hlen & ?); simplify_eq.
        by rewrite hlen.
      }
      iClear "hconstr hiF hiff hl hifs hmodfs hf' Hv".
      rewrite /subst_gen hlenσ.
      rewrite (interp_type_no_this _ _ _ Σthis0 interp_nothing); first done.
      apply subst_this_has_no_this => /=.
      apply forallb_True.
      by apply gen_targs_has_no_this.
    - (* property doesn't have `this` *)
      case: hex => // hnothis.
      rewrite interp_tag_unfold interp_tag_equiv //; last first.
      { by rewrite /interp_list fmap_length. }
      rewrite /interp_tag_alt /=.
      iDestruct "hrecv" as (? t2 tdef' t2def σin Σt2 fields ifields hpure)
        "(#hΣt2 & #hconstr & #hinst & #hfields & hl)".
      destruct hpure as ([= <-] & htdef' & ht2def & hlenΣt2 & hin & hfields & hdomfields); simplify_eq.
      iDestruct "Hh" as (sh) "(hown & %hdom & #h)".
      iExists sh.
      iDestruct (sem_heap_own_valid_2 with "hown hl") as "#Hv".
      iSplitL "hown"; first by iFrame.
      iSplitR.
      { iPureIntro.
        by rewrite hdom dom_insert_lookup_L.
      }
      iModIntro.
      iIntros (l'' t'' vs'') "%Heq".
      rewrite lookup_insert_Some in Heq.
      destruct Heq as [[<- [= <- <-]] | [hne hl]]; last first.
      { iApply "h".
        by iPureIntro.
      }
      iSpecialize ("h" $! l t1 vs with "[//]").
      iDestruct "h" as (iFs) "[#hsh hmodels]".
      iExists iFs; iSplit; first done.
      iRewrite "Hv" in "hsh".
      rewrite !option_equivI prod_equivI /=.
      iDestruct "hsh" as "[%ht #hifs]".
      fold_leibniz; subst.
      (* NEW *)
      assert (hfield2 : has_field f t1 Public (subst_ty σin fty) orig)
      by (by eapply has_field_inherits_using).
      iSpecialize ("hfields" $! f Public (subst_ty σin fty) orig hfield2).
      (* NEW *)
      rewrite later_equivI.
      iNext.
      iDestruct "hfields" as (iF) "(#hiF & #hiff)".
      iAssert (⌜is_Some (iFs !! f)⌝)%I as "%hiFs".
      { iRewrite -"hifs".
        by iRewrite "hiF".
      }
      rewrite /heap_models_fields.
      iDestruct "hmodels" as "[%hdomv #hmodfs]".
      iSplit.
      { iPureIntro.
        by rewrite -hdomv dom_insert_lookup // -elem_of_dom hdomv elem_of_dom.
      }
      iIntros (f' iF') "#hf'".
      destruct (decide (f = f')) as [-> | hne]; last first.
      { rewrite lookup_insert_ne //.
        by iApply "hmodfs".
      }
      rewrite lookup_insert.
      iExists v; iSplitR; first done.
      iRewrite -"hifs" in "hf'".
      iRewrite "hiF" in "hf'".
      rewrite !option_equivI discrete_fun_equivI.
      iSpecialize ("hf'" $! v).
      iRewrite -"hf'".
      rewrite interp_type_subst; last first.
      { apply bounded_subst_this; last by (constructor; by apply bounded_gen_targs).
        apply has_field_bounded in hf => //.
        destruct hf as (def' & hdef' & hfty).
        apply wf_tyI in hwf as (? & ? & hlen & ?); simplify_eq.
        by rewrite hlen.
      }
      iApply "hiff".
      iClear "hconstr hiF hiff hl hifs hmodfs hf' Hv".
      (* NEW *)
      rewrite /subst_gen -hlenΣt2.
      iAssert (
        interp_type (subst_ty σin fty) (interp_exact_tag interp_type t1 Σt2) Σt2 v -∗
        interp_type
          (subst_this (ClassT true t1 (gen_targs (length Σt2))) (subst_ty σin fty)) interp_nothing Σt2 v)%I as "HH".
      { iIntros "HH".
        by rewrite -(interp_type_subst_this _ _ interp_nothing).
      }
      iApply "HH"; iClear "HH".
      rewrite subst_this_no_this_id; last done.
      rewrite (interp_type_no_this _ _ _ Σthis0 (interp_exact_tag interp_type t1 Σt2)); last done.
      iDestruct (neg_interp_variance with "hinst") as "hinst2".
      iDestruct (interp_with_mono with "hinst2 hv") as "hv2" => //.
      { apply has_field_mono in hf => //.
        destruct hf as (? & ? & []); by simplify_eq.
      }
      { by apply has_field_wf in hf. }
      assert (heq:
        interp_list interp_nothing Σt2 σin ≡
        interp_list (interp_exact_tag interp_type t1 Σt2) Σt2 σin).
      { apply interp_list_no_this.
        apply inherits_using_wf in hin => //.
        by destruct hin as (? & ? & ? & ? & ?).
      }
      rewrite (interp_type_equivI _ _ _ heq).
      rewrite interp_type_subst; first done.
      apply has_field_bounded in hf => //.
      destruct hf as (? & ? & hf); simplify_eq.
      apply inherits_using_wf in hin => //.
      destruct hin as (? & ? & ? & hwfσin & ?); simplify_eq.
      apply wf_tyI in hwfσin as (? & ? & hlen & ?); simplify_eq.
      by rewrite hlen.
  Qed.

  Lemma heap_models_update_priv Δ Σ h l t1 C σ0 cdef vs f fty v:
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _cname, wf_cdef_fields) pdefs →
    map_Forall (λ _cname, wf_cdef_fields_bounded) pdefs →
    map_Forall (λ _ : string, wf_cdef_fields_wf) pdefs →
    map_Forall (λ _cname, wf_field_mono) pdefs →
    map_Forall (λ _ : string, wf_cdef_mono) pdefs →
    map_Forall (λ _ : string, wf_cdef_constraints_wf) pdefs →
    Forall wf_constraint Δ →
    h !! l = Some (t1, vs) →
    (* TODO: maybe turn this one into a has_field to share more proof ? *)
    pdefs !! C = Some cdef →
    cdef.(classfields) !! f = Some (Private, fty) →
    ∀ t0 Σt0 tdef0,
    pdefs !! t0 = Some tdef0 →
    inherits_using t0 C σ0 →
    length Σt0 = length tdef0.(generics) →
    length Σ ≥ length cdef.(generics) →
    let Σthis0 := interp_exact_tag interp_type t0 Σt0 in
    ⌜interp_list interp_nothing Σt0 σ0 ≡ take (length cdef.(generics)) Σ⌝ -∗
    □ interp_env_as_mixed Σt0 -∗
    □ interp_env_as_mixed Σ -∗
    □ Σinterp Σthis0 Σ Δ -∗
    Σthis0 (LocV l) -∗
    interp_type fty Σthis0 Σ v -∗
    heap_models h -∗
    heap_models (<[l:=(t1, <[f:=v]> vs)]> h).
  Proof.
    move => ?? hwfb ????? hheap hcdef hf.
    move => t0 Σt0 tdef0 hdef0 hin hlenΣt0 hge Σthis0.
    iIntros "%heqΣ #hΣt0 #hΣ #hΣΔ #hrecv #hv Hh".
    rewrite {2}/Σthis0 interp_exact_tag_unseal /interp_exact_tag_def /=.
    iDestruct "hrecv" as (? tdef' fields ifields hpure) "(#hconstr & #hfields & hl)".
    destruct hpure as ([= <-] & htdef' & hfields & hdomfields); simplify_eq.
    iDestruct "Hh" as (sh) "(hown & %hdom & #h)".
    iExists sh.
    iDestruct (sem_heap_own_valid_2 with "hown hl") as "#Hv".
    iSplitL "hown"; first by iFrame.
    iSplitR.
    { iPureIntro.
      by rewrite hdom dom_insert_lookup_L.
    }
    iModIntro.
    iIntros (l'' t'' vs'') "%Heq".
    rewrite lookup_insert_Some in Heq.
    destruct Heq as [[<- [= <- <-]] | [hne hl]]; last first.
    { iApply "h".
      by iPureIntro.
    }
    iSpecialize ("h" $! l t1 vs with "[//]").
    iDestruct "h" as (iFs) "[#hsh hmodels]".
    iExists iFs; iSplit; first done.
    iRewrite "Hv" in "hsh".
    rewrite !option_equivI prod_equivI /=.
    iDestruct "hsh" as "[%ht #hifs]".
    fold_leibniz; subst.
    assert (hf0: has_field f t1 Private (subst_ty σ0 fty) C).
    { eapply has_field_inherits_using => //.
      change Private with (Private, fty).1.
      by eapply HasField.
    }
    iSpecialize ("hfields" $! f Private _ C hf0).
    rewrite later_equivI.
    iNext.
    iDestruct "hfields" as (iF) "(#hiF & #hiff)".
    iAssert (⌜is_Some (iFs !! f)⌝)%I as "%hiFs".
    { iRewrite -"hifs".
      by iRewrite "hiF".
    }
    rewrite /heap_models_fields.
    iDestruct "hmodels" as "[%hdomv #hmodfs]".
    iSplit.
    { iPureIntro.
      by rewrite -hdomv dom_insert_lookup // -elem_of_dom hdomv elem_of_dom.
    }
    iIntros (f' iF') "#hf'".
    destruct (decide (f = f')) as [-> | hne]; last first.
    { rewrite lookup_insert_ne //.
      by iApply "hmodfs".
    }
    rewrite lookup_insert.
    iExists v; iSplitR; first done.
    iRewrite -"hifs" in "hf'".
    iRewrite "hiF" in "hf'".
    rewrite !option_equivI discrete_fun_equivI.
    iSpecialize ("hf'" $! v).
    iRewrite -"hf'".
    iApply "hiff".
    (* NEW *)
    rewrite /subst_gen -hlenΣt0.
    iAssert (
      interp_type (subst_ty σ0 fty) (interp_exact_tag interp_type t1 Σt0) Σt0 v -∗
      interp_type
        (subst_this (ClassT true t1 (gen_targs (length Σt0))) (subst_ty σ0 fty)) interp_nothing Σt0 v)%I as "HH".
    { iIntros "HH".
      by rewrite -(interp_type_subst_this _ _ interp_nothing).
    }
    iApply "HH"; iClear "HH".
    iClear "hconstr hiF hiff hl hifs hmodfs hf' Hv".
    apply inherits_using_wf in hin => //.
    destruct hin as (? & ? & ? & hwf & ?); simplify_eq.
    rewrite -(interp_type_take fty _ Σ (length cdef.(generics))); first last.
    { done. }
    { apply hwfb in hcdef.
      by apply hcdef in hf.
    }
    rewrite (interp_type_equivI _ (take (length cdef.(generics)) Σ) (interp_list interp_nothing Σt0 σ0)); last done.
    rewrite interp_type_subst; last first.
    { assert (h0 := hcdef).
      apply hwfb in h0.
      apply h0 in hf.
      apply wf_tyI in hwf as (? & ? & hlen & ?); simplify_eq.
      by rewrite hlen.
    }
    assert (heq_ : interp_list interp_nothing Σt0 σ0 ≡ interp_list Σthis0 Σt0 σ0).
    { by apply interp_list_no_this. }
    by rewrite (interp_type_equivI _ _ _ heq_).
  Qed.

  (* This is dynamic related. Once a [| dynamic |] is open,
   * we want to use facts about the Σt and Σdyn to show that
   * Σt models the SDT constraints of the runtime type.
   *)
  (* Show that Σt |= Δt ∧ Δsdt^t *)
  Lemma Σt_models_sdt t A tdef adef σ Σthis  (Σt ΣA: list (interp Θ)):
    wf_cdefs →
    pdefs !! t = Some tdef →
    pdefs !! A = Some adef →
    length Σt = length tdef.(generics) →
    length ΣA = length adef.(generics) →
    inherits_using t A σ →
    □ interp_as_mixed Σthis -∗
    □iForall3 interp_variance adef.(generics) (interp_list Σthis Σt σ) ΣA -∗
    □ interp_env_as_mixed ΣA -∗
    □ Σinterp Σthis ΣA adef.(constraints) -∗
    □ Σinterp Σthis ΣA (Δsdt A) -∗
    □ interp_env_as_mixed Σt -∗
    □ Σinterp Σthis Σt tdef.(constraints) -∗
    □ Σinterp Σthis Σt (Δsdt t).
  Proof.
    move => wfpdefs htdef hadef hlt htA hin.
    iIntros "#hΣthis #hF #hmA #hΣΔA #hΣΔsdtA #hmt #ΣΔt".
    assert (hh: Forall wf_ty σ ∧ length adef.(generics) = length σ).
    { apply inherits_using_wf in hin; try (by apply wfpdefs).
      destruct hin as (?&?&?&hh&?).
      split; first by apply wf_ty_classI in hh.
      apply wf_tyI in hh as (? & ? & ? & ?); by simplify_eq.
    }
    destruct hh as [hwfσ hl].
    assert (hwfc: Forall wf_constraint tdef.(constraints)) by by apply wf_constraints_wf in htdef.
    pose (Δsdt_A := subst_constraints σ (Δsdt A)).
    iAssert (□ Σinterp Σthis Σt Δsdt_A)%I as "#hΣt_sdt_A".
    { iAssert (interp_env_as_mixed (interp_list Σthis Σt σ)) as "hmixed0".
      { iIntros (k phi hk w) "hphi".
        apply list_lookup_fmap_inv in hk as [ty0 [-> hty0]].
        rewrite -(interp_type_unfold _ Σt MixedT w).
        iApply (submixed_is_inclusion_aux _ Σt ty0 w) => //.
        rewrite Forall_lookup in hwfσ.
        by apply hwfσ in hty0.
      }
      iAssert (□ Σinterp Σthis (interp_list Σthis Σt σ) adef.(constraints))%I as "#hΣ0".
      { iModIntro.
        apply inherits_using_ok in hin => //; try by apply wfpdefs.
        destruct hin as (? & ? & hok); simplify_eq.
        apply ok_tyI in hok as (? & ? & ? & hok); simplify_eq.
        iIntros (i c hc w) "#h".
        assert (hb : bounded_constraint (length σ) c).
        { apply wf_constraints_bounded in hadef => //.
          rewrite /wf_cdef_constraints_bounded Forall_lookup in hadef.
          apply hadef in hc.
          by rewrite -hl.
        }
        destruct hb as [].
        assert (hwf: wf_ty (subst_ty σ c.1)).
        { apply wf_ty_subst => //.
          apply wf_constraints_wf in hadef => //.
          rewrite /wf_cdef_constraints_wf Forall_lookup in hadef.
          apply hadef in hc.
          by destruct hc.
        }
        apply hok in hc.
        rewrite -!interp_type_subst //.
        iApply (subtype_is_inclusion tdef.(constraints)) => //; by apply wfpdefs.
      }
      iModIntro; iIntros (i c0 hc w) "#h".
      apply list_lookup_fmap_inv in hc as [c [-> hc]] => /=.
      assert (hbc : bounded_constraint (length σ) c).
      { rewrite -hl.
        by eapply Δsdt_bounded in hc.
      }
      destruct hbc as [].
      rewrite !interp_type_subst //.
      destruct wfpdefs.
      by iApply ((Δsdt_variance_interp _ _ _ _ _
        wf_mono wf_parent wf_constraints_no_this wf_constraints_bounded
        wf_constraints_wf wf_fields_wf hadef)
      with "hΣthis hmixed0 hmA hF hΣ0 hΣΔA hΣΔsdtA").
    }
    iAssert (□ Σinterp Σthis Σt (constraints tdef ++ Δsdt_A))%I as "#hconstr_".
    { iModIntro.
      by iApply Σinterp_app.
    }
    iModIntro.
    assert (hnewcond: Δentails Aware (tdef.(constraints) ++ Δsdt_A) (Δsdt t)).
    { apply inherits_using_extends_dyn in hin => //; try by apply wfpdefs.
      destruct hin as (? & ? & hwf); simplify_eq.
      move => k c hc.
      by apply hwf with k.
    }
    assert (Forall wf_constraint Δsdt_A).
    { rewrite Forall_lookup => k c hc.
      apply list_lookup_fmap_inv in hc as [c0 [-> hc]].
      apply Δsdt_wf in hc as [].
      split; by apply wf_ty_subst.
    }
    assert (hwf_ : Forall wf_constraint (tdef.(constraints) ++ Δsdt_A)).
    { apply Forall_app; by split.  }
    assert (hwfΔ0: Forall wf_constraint (Δsdt t)).
    { rewrite Forall_lookup; by apply Δsdt_wf. }
    iIntros (i c hc w) "#h".
    assert (h0 := hc).
    apply hnewcond in h0.
    assert (wf_ty c.1).
    { rewrite Forall_lookup in hwfΔ0.
      by apply hwfΔ0 in hc as [].
    }
    iApply (subtype_is_inclusion with "hΣthis hmt hconstr_ h") => //; by apply wfpdefs.
  Qed.
End proofs.


(**  Mathematical model of the causal memory implementation
     from "Causal memory: definitions, implementation, and programming"
     (https://link.springer.com/article/10.1007/BF01784241).*)

From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.rcb.spec Require Import base.
From aneris.examples.rcb.model Require Export model_lsec.

Section Local_history_valid.
  Context `{!anerisG Mdl Σ, !RCB_params}.

  Definition RCBM_lhst_ext (s : gset local_event) :=
    ∀ e e', e ∈ s → e' ∈ s → le_time e = le_time e' → e = e'.

  Definition RCBM_lhst_times (s : gset local_event) :=
    ∀ e, e ∈ s → length e.(le_time) = length RCB_addresses.

  Definition RCBM_lhst_origs (i : nat) (s : gset local_event) :=
    (∀ e, e ∈ s → e.(le_orig) < length RCB_addresses).

  Definition RCBM_lhst_lsec_valid (i : nat) (s : gset local_event) :=
    (∀ j, j < length RCB_addresses → RCBM_lsec_valid i j s).

  Definition RCBM_lhst_seqids (s : gset local_event) :=
    ∀ e, e ∈ s → e.(le_seqid) <= size s.

  Record RCBM_lhst_valid (i : nat) (s : gset local_event) : Prop := {
    RCBM_LHV_bound_at: i < length RCB_addresses;
    RCBM_LHV_times: RCBM_lhst_times s;
    RCBM_LHV_ext: RCBM_lhst_ext s;
    RCBM_LHV_origs: RCBM_lhst_origs i s;
    RCBM_LHV_secs_valid: RCBM_lhst_lsec_valid i s;
    RCBM_LHV_seqids: RCBM_lhst_seqids s;
  }.

  Global Arguments RCBM_LHV_bound_at {_ _} _.
  Global Arguments RCBM_LHV_times {_ _} _.
  Global Arguments RCBM_LHV_ext {_ _} _.
  Global Arguments RCBM_LHV_origs {_ _} _.
  Global Arguments RCBM_LHV_secs_valid {_ _} _.
  Global Arguments RCBM_LHV_seqids {_ _} _.

  Lemma in_lhs_time_component e k i s :
    RCBM_lhst_valid i s →
    k < length RCB_addresses →
    e ∈ s →
    is_Some (e.(le_time) !! k).
  Proof.
    intros ???; eapply lookup_lt_is_Some_2; erewrite RCBM_LHV_times; eauto.
  Qed.

  Lemma RCBM_lsec_empty i s:
    RCBM_lhst_valid i s →
    ∀ j', j' < length RCB_addresses →
          RCBM_lsec j' s = ∅ ↔ ∀ e, e ∈ s → e.(le_time) !! j' = Some 0.
  Proof.
    intros Hvli j' Hj'lt.
    split.
    - intros Hjs e Hes.
      pose proof (in_lsec_orig e s Hes) as Hesec.
      pose proof (RCBM_LHV_origs Hvli e Hes) as Heorig.
      destruct (lookup_lt_is_Some_2 (le_time e) j') as [k Hk].
      { rewrite (RCBM_LHV_times Hvli) //. }
      rewrite Hk.
      destruct (decide (j' = e.(le_orig))) as [->|].
      { by rewrite Hjs in Hesec. }
      pose proof (RCBM_LHV_secs_valid Hvli e.(le_orig) Heorig) as Hesecvl.
      destruct (decide (i = e.(le_orig))) as [->|].
      { pose proof (RCBM_LSV_caus_refl Hesecvl j' e Hj'lt) as Hvlrefl.
        rewrite Hk /= in Hvlrefl.
        rewrite RCBM_lsec_latest_in_frame_empty in Hvlrefl; last done.
        apply Hvlrefl; auto. }
      pose proof (RCBM_LSV_caus Hesecvl j' e Hj'lt) as Hvlirrefl.
      rewrite Hk /= in Hvlirrefl.
      rewrite RCBM_lsec_latest_in_frame_empty in Hvlirrefl; last done.
      f_equal; symmetry; apply le_n_0_eq.
      apply Hvlirrefl; auto.
    - destruct (decide (RCBM_lsec j' s = ∅)) as [|Hne]; first done.
      apply set_choose_L in Hne as [x Hx].
      pose proof (RCBM_LHV_secs_valid Hvli j' Hj'lt) as Hesecvl.
      intros He.
      pose proof (in_lsec_in_lhst _ _ _ Hx) as Hxs.
      apply He in Hxs.
      destruct (RCBM_LSV_strongly_complete (RCBM_LHV_times Hvli) Hj'lt Hesecvl 0)
        as [_ []]; eauto with lia.
  Qed.

  Definition lsec_sup (j : nat) (s: gset local_event) : nat :=
    nat_sup (omap (λ e, e.(le_time) !! j) (elements (RCBM_lsec j s))).

  Lemma lsec_sup_empty j : lsec_sup j ∅ = 0.
  Proof. by rewrite /lsec_sup RCBM_lsec_of_empty elements_empty /=. Qed.

  Lemma elem_of_lsec_lsec_sup_length e i j s :
    RCBM_lhst_valid i s →
    j < length RCB_addresses →
    e ∈ RCBM_lsec j s → length (elements (RCBM_lsec j s)) = lsec_sup j s.
  Proof.
    intros Hvl Hj He.
    assert (∃ e', e' ∈ RCBM_lsec j s ∧
                  (e'.(le_time) !! j = Some (lsec_sup j s))) as
        (e' & He'1 & He'2).
    { assert
        (lsec_sup j s ∈ (omap (λ e, e.(le_time) !! j)
                              (elements (RCBM_lsec j s)))) as Hsup.
      { edestruct (in_lhs_time_component e j) as [p Hp];
          eauto using in_lsec_in_lhst.
        eapply (nat_sup_elem_of p).
        apply elem_of_list_omap.
          by exists e; split; first apply elem_of_elements. }
      apply elem_of_list_omap in Hsup as (?&?%elem_of_elements&?); eauto. }
    apply Nat.le_antisymm.
    - edestruct le_lt_dec as [Hle|Hlt]; first exact Hle.
      destruct (RCBM_LSV_comp (RCBM_LHV_secs_valid Hvl j Hj) (S (lsec_sup j s))) as
          (e'' & He''1 & He''2); first lia.
      assert (S (lsec_sup j s) ≤ lsec_sup j s); last lia.
      apply nat_sup_UB.
      apply elem_of_list_omap.
        by eexists; split; first apply elem_of_elements.
    - apply (RCBM_LSV_strongly_complete
               (RCBM_LHV_times Hvl) Hj (RCBM_LHV_secs_valid Hvl j Hj)); eauto.
  Qed.

Lemma lsec_lsup_length i j s :
    RCBM_lhst_valid i s →
    j < length RCB_addresses →
    length (elements (RCBM_lsec j s)) = lsec_sup j s.
  Proof.
    intros Hvl Hj.
    destruct (decide (RCBM_lsec j s ≡ ∅)) as [Hempty| Hex].
    - rewrite /lsec_sup. simplify_eq. rewrite Hempty. set_solver.
    - apply set_choose in Hex as (e' & He').
      eapply (elem_of_lsec_lsec_sup_length e'); eauto.
  Qed.

  Lemma RCBM_lsec_causality_lemma i s e p q r :
    r < length RCB_addresses →
    RCBM_lhst_valid i s →
    e ∈ s →
    0 < p →
    p ≤ q →
    e.(le_time) !! r = Some q →
    ∃ e', e' ∈ RCBM_lsec r s ∧ e'.(le_time) !! r = Some p.
  Proof.
    intros Hr His He Hp Hpq Herq.
    destruct (decide (r = e.(le_orig))) as [Heq|Hreor].
    { apply (RCBM_LSV_comp (RCBM_LHV_secs_valid His r Hr)).
      split; first lia.
      apply (Nat.le_trans _ q); first done.
      apply (RCBM_LSV_strongly_complete
               (RCBM_LHV_times His) Hr (RCBM_LHV_secs_valid His r Hr)).
      exists e; split; last done.
        by rewrite Heq; apply in_lsec_orig. }
    assert (RCBM_lsec r s ≠ ∅) as Hrs.
    { rewrite (RCBM_lsec_empty i); auto.
      intros Hz.
      specialize (Hz e He); rewrite Herq in Hz; simplify_eq; lia. }
    assert (∃ e' p', e' ∈ RCBM_lsec r s ∧ e'.(le_time) !! r = Some p')
      as (e' & p' & He' & Hp').
    { apply set_choose_L in Hrs as (e' & He').
      edestruct (in_lhs_time_component e') as [p' Hp'];
        eauto using in_lsec_in_lhst. }
    assert (1 ≤ p').
    { eapply RCBM_LSV_strongly_complete; [|done| |by eauto].
      - by eapply RCBM_LHV_times; eauto.
      - by eapply RCBM_LHV_secs_valid; eauto. }
    assert (p' ≤ lsec_sup r s).
    { apply nat_sup_UB.
      apply elem_of_list_omap.
      exists e'; split; first apply elem_of_elements; eauto. }
    destruct (decide (p <= lsec_sup r s)).
    - assert (1 ≤ p ∧ p <= strings.length (elements (RCBM_lsec r s)))
        as Hpbounds.
      { split; first lia.
        erewrite elem_of_lsec_lsec_sup_length; eauto with lia. }
      apply (RCBM_LSV_comp (RCBM_LHV_secs_valid His r Hr)); eauto.
    - assert (lsec_sup r s < p) as HpSup by lia.
      assert (q <= lsec_sup r s); last lia.
      pose proof (RCBM_LHV_origs His e He) as Helsec.
      pose proof (RCBM_LSV_caus (RCBM_LHV_secs_valid His e.(le_orig) Helsec)
                               r e Hr Hreor) as Hq.
      rewrite Herq /= in Hq.
      etrans; first by apply Hq, in_lsec_orig.
      apply nat_sup_mono.
      intros a; rewrite !elem_of_list_omap;
        intros (?&[? ?]%elem_of_list_filter&?); eauto.
  Qed.

  Lemma empty_lhst_valid i :
    i < length RCB_addresses →
    RCBM_lhst_valid i ∅.
  Proof.
    split; [done|done|done|done| |done].
    intros ? ?; apply sections_empty_valid; done.
  Qed.

End Local_history_valid.


(*
 * Vericert: Verified high-level synthesis.
 * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
 *
 * This program 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.
 *
 * 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 General Public License
 * along with this program.  If not, see <https://www.gnu.org/licenses/>.
 *)

(* begin hide *)
From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia.
From compcert Require Export lib.Integers common.Values.
From vericert Require Import Vericertlib.
(* end hide *)

(** * Value

A [value] is a bitvector with a specific size. We are using the implementation
of the bitvector by mit-plv/bbv, because it has many theorems that we can reuse.
However, we need to wrap it with an [Inductive] so that we can specify and match
on the size of the [value]. This is necessary so that we can easily store
[value]s of different sizes in a list or in a map.

Using the default [word], this would not be possible, as the size is part of the type. *)

(* Definition value : Type := val.

(** ** Value conversions

Various conversions to different number types such as [N], [Z], [positive] and
[int], where the last one is a theory of integers of powers of 2 in CompCert. *)

Definition valueToNat (v : value) : nat :=
  match v with
  | value_bool b => Nat.b2n b
  | value_int i => Z.to_nat (Int.unsigned i)
  | value_int64 i => Z.to_nat (Int64.unsigned i)
  end.

Definition natToValue (n : nat) : value :=
  value_int (Int.repr (Z.of_nat n)).

Definition natToValue64 (n : nat) : value :=
  value_int64 (Int64.repr (Z.of_nat n)).

Definition valueToN (v : value) : N :=
  match v with
  | value_bool b => N.b2n b
  | value_int i => Z.to_N (Int.unsigned i)
  | value_int64 i => Z.to_N (Int64.unsigned i)
  end.

Definition NToValue (n : N) : value :=
  value_int (Int.repr (Z.of_N n)).

Definition NToValue64 (n : N) : value :=
  value_int64 (Int64.repr (Z.of_N n)).

Definition ZToValue (z : Z) : value :=
  value_int (Int.repr z).

Definition ZToValue64 (z : Z) : value :=
  value_int64 (Int64.repr z).

Definition valueToZ (v : value) : Z :=
  match v with
  | value_bool b => Z.b2z b
  | value_int i => Int.signed i
  | value_int64 i => Int64.signed i
  end.

Definition uvalueToZ (v : value) : Z :=
  match v with
  | value_bool b => Z.b2z b
  | value_int i => Int.unsigned i
  | value_int64 i => Int64.unsigned i
  end.

Definition posToValue (p : positive) : value :=
  value_int (Int.repr (Z.pos p)).

Definition posToValue64 (p : positive) : value :=
  value_int64 (Int64.repr (Z.pos p)).

Definition valueToPos (v : value) : positive :=
  match v with
  | value_bool b => 1%positive
  | value_int i => Z.to_pos (Int.unsigned i)
  | value_int64 i => Z.to_pos (Int64.unsigned i)
  end.

Definition intToValue (i : Integers.int) : value := value_int i.

Definition int64ToValue (i : Integers.int64) : value := value_int64 i.

Definition valueToInt (v : value) : Integers.int :=
  match v with
  | value_bool b => Int.repr (if b then 1 else 0)
  | value_int i => i
  | value_int64 i => Int.repr (Int64.unsigned i)
  end.

(*Definition ptrToValue (i : ptrofs) : value :=
  value_int (Ptrofs.to_int i).

Definition valueToPtr (i : value) : Integers.ptrofs :=
  Ptrofs.of_int i.

Definition valToValue (v : Values.val) : option value :=
  match v with
  | Values.Vint i => Some (intToValue i)
  | Values.Vint64 i => Some (intToValue i)
  | Values.Vptr b off => Some (ptrToValue off)
  | Values.Vundef => Some (ZToValue 0%Z)
  | _ => None
  end.

(** Convert a [value] to a [bool], so that choices can be made based on the
result. This is also because comparison operators will give back [value] instead
of [bool], so if they are in a condition, they will have to be converted before
they can be used. *)

Definition valueToBool (v : value) : bool :=
  if Z.eqb (uvalueToZ v) 0 then false else true.

Definition boolToValue (b : bool) : value :=
  natToValue (if b then 1 else 0).

(** ** Arithmetic operations *)

Definition unify_word (sz1 sz2 : nat) (w1 : word sz2): sz1 = sz2 -> word sz1.
intros; subst; assumption. Defined.

Lemma unify_word_unfold :
  forall sz w,
  unify_word sz sz w eq_refl = w.
Proof. auto. Qed.

Inductive val_value_lessdef: val -> value -> Prop :=
| val_value_lessdef_int:
    forall i v',
    i = valueToInt v' ->
    val_value_lessdef (Vint i) v'
| val_value_lessdef_ptr:
    forall b off v',
    off = valueToPtr v' ->
    val_value_lessdef (Vptr b off) v'
| lessdef_undef: forall v, val_value_lessdef Vundef v.

Inductive opt_val_value_lessdef: option val -> value -> Prop :=
| opt_lessdef_some:
    forall v v', val_value_lessdef v v' -> opt_val_value_lessdef (Some v) v'
| opt_lessdef_none: forall v, opt_val_value_lessdef None v.

Lemma valueToZ_ZToValue :
  forall z,
  (Int.min_signed <= z <= Int.max_signed)%Z ->
  valueToZ (ZToValue z) = z.
Proof. auto using Int.signed_repr. Qed.

Lemma uvalueToZ_ZToValue :
  forall z,
  (0 <= z <= Int.max_unsigned)%Z ->
  uvalueToZ (ZToValue z) = z.
Proof. auto using Int.unsigned_repr. Qed.

Lemma valueToPos_posToValue :
  forall v,
  0 <= Z.pos v <= Int.max_unsigned ->
  valueToPos (posToValue v) = v.
Proof.
  unfold valueToPos, posToValue.
  intros. rewrite Int.unsigned_repr.
  apply Pos2Z.id. assumption.
Qed.

Lemma valueToInt_intToValue :
  forall v,
  valueToInt (intToValue v) = v.
Proof. auto. Qed.

Lemma valToValue_lessdef :
  forall v v',
    valToValue v = Some v' ->
    val_value_lessdef v v'.
Proof.
  intros.
  destruct v; try discriminate; constructor.
  unfold valToValue in H. inversion H.
  unfold valueToInt. unfold intToValue in H1. auto.
  inv H. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial.
Qed.

Ltac simplify_val := repeat (simplify; unfold uvalueToZ, valueToPtr, Ptrofs.of_int, valueToInt, intToValue,
                                       ptrToValue in *)

(*Ltac crush_val := simplify_val; try discriminate; try congruence; try lia; liapp; try assumption.*)
*)


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

Lemma eq_sym : forall {A: Type} (n m : A), n = m -> m = n.
Proof.
Admitted.
Implicit Arguments eq_sym [A n m].

(* deprecated, use "neq_sym" instead *)
Lemma neq_refl : forall n m : nat, n <> m -> m <> n.
Proof.
Admitted.
Implicit Arguments neq_refl [n m].

Lemma neq_sym : forall {A: Type} (n m : A), n <> m -> m <> n.
Proof.
Admitted.
Implicit Arguments neq_sym [n m].


(**

This file describes the representation of modeling language.

Author: Bowen Zhang.

Date : 2021.07.24
*)

From SLF (* TLC *) Require Export LibCore.
From SLF (* Sep *) Require Export TLCbuffer Var Fmap.

(* ###################### Syntax ###################### *)

Definition loc : Type := nat.
Definition bloc : Type := nat.
Definition floc : Type := nat.

Definition listint : Type := list int.
Definition listbloc : Type := list bloc.

Definition fnull : floc := 0%nat.
Definition bnull : bloc := 0%nat.

(*---------- the block primitive operations ----------*)
Inductive bval : Type :=
  | bval_create : bval
  | bval_append : bval
  | bval_get : bval
  | bval_delete : bval
  | bval_bsize : bval.

(*---------- the file primitive operations ----------*)
Inductive fval : Type :=
  | fval_create : fval
  | fval_attach : fval
  | fval_fsize : fval
  | fval_get : fval
  | fval_get_nth_blk : fval
  | fval_set_nth_blk : fval
  | fval_delete : fval
  (* some aux file operation *)
  | fval_buffer: fval
  | fval_buffer_list : fval
  | fval_rev_blist : fval.

(*-------- some auxiliary primitive operations (not important) --------*)
Inductive prim : Type :=
  | val_eq : prim        (*a ?= b*)
  | val_add : prim       (*a + b*)
  | val_list_rev : prim    (*reverse a list*)
  | val_list_app : prim.   (*append a list*)

(*---------- the val and the term ----------*)
Inductive val : Type :=
  | val_unit : val
  | val_prim : prim -> val
  | val_bool : bool -> val
  | val_int : int -> val
  | val_listint : list int -> val
  | val_listbloc : list bloc -> val
  | val_floc : floc -> val
  | val_bloc : bloc -> val
  | val_bval : bval -> val
  | val_fval : fval -> val
  | val_fun : var -> trm -> val
  | val_fix : var -> var -> trm -> val

with trm : Type :=
  | trm_val : val -> trm
  | trm_var : var -> trm
  | trm_fun : var -> trm -> trm
  | trm_fix : var -> var -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_seq : trm -> trm -> trm
  | trm_let : var -> trm -> trm -> trm
  | trm_if : trm -> trm -> trm -> trm.

(* ##################### The Definition of CBS heap ##################### *)
(*------- the entire corresponding state -------*)
Definition stateb : Type := fmap bloc listint.
Definition statef : Type := fmap floc listbloc.
Definition state : Type := statef * stateb.

(*------- the part of corresponding state -------*)
Definition heapb : Type := stateb.
Definition heapf : Type := statef.
Definition heap : Type := state.

Notation "'hb_empty'" := (@Fmap.empty bloc listint)
  (at level 0).
Notation "'hf_empty'" := (@Fmap.empty floc listbloc)
  (at level 0).
Notation "h1 \u h2" := (Fmap.union h1 h2)
  (at level 37, right associativity).

(*** Implicit Types and coercions (to improve the readability) ***)

Implicit Types bp : bloc.
Implicit Types fp : floc.
Implicit Types ln : list int.
Implicit Types n : int.
Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : bool.
Implicit Types hb : heapb.
Implicit Types sb : stateb.
Implicit Types hf : heapf.
Implicit Types sf : statef.

Coercion val_bool : bool >-> val.
Coercion val_floc : floc >-> val.
Coercion val_bloc : bloc >-> val.
Coercion val_prim : prim >-> val.
Coercion val_int : Z >-> val.
Coercion val_bval : bval >-> val.
Coercion val_fval : fval >-> val.

Coercion trm_val : val >-> trm.
Coercion trm_var : var >-> trm.
Coercion trm_app : trm >-> Funclass.

(*** The substitution function ***)
(* -- subst var to val directly -- *)
Fixpoint subst (y:var) (w:val) (t:trm) : trm :=
  let aux t := subst y w t in
  let if_y_eq x t1 t2 := if var_eq x y then t1 else t2 in
  match t with
  | trm_val v => trm_val v
  | trm_var x => if_y_eq x (trm_val w) t
  | trm_fun x t1 => trm_fun x (if_y_eq x t1 (aux t1))
  | trm_fix f x t1 => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (aux t1)))
  | trm_app t1 t2 => trm_app (aux t1) (aux t2)
  | trm_seq t1 t2 => trm_seq  (aux t1) (aux t2)
  | trm_let x t1 t2 => trm_let x (aux t1) (if_y_eq x t2 (aux t2))
  | trm_if t0 t1 t2 => trm_if (aux t0) (aux t1) (aux t2)
  end.

Definition trm_is_val (t:trm) : Prop :=
  match t with trm_val v => True | _ => False end.

(* ########################### The Evaluation Rules ########################### *)
Open Scope liblist_scope.

Inductive eval : heap -> trm -> heap -> val -> Prop :=
  (*------ trm eval to its value ------*)
  | eval_val_refine : forall sf sb v,
      eval (sf, sb) (trm_val v) (sf, sb) v
  | eval_val : forall s v,
      eval s (trm_val v) s v
  | eval_fun : forall s x t1,
      eval s (trm_fun x t1) s (val_fun x t1)
  | eval_fix : forall s f x t1,
      eval s (trm_fix f x t1) s (val_fix f x t1)

  (*------   aux prim operation    ------*)
  | eval_add : forall s n1 n2,
      eval s (val_add n1 n2) s (n1 + n2)
  | eval_eq : forall s n1 n2,
      eval s (val_eq n1 n2) s (val_bool (n1 =? n2))
  | eval_list_rev : forall s l1,
      eval s (val_list_rev (val_listint l1)) s (val_listint (rev l1))
  | eval_list_app : forall s l1 l2,
      eval s (val_list_app (val_listint l1) (val_listint l2))
           s (val_listint (l1 ++ l2))

  (*--------- block prim operation ---------*)
  | eval_bcreate_list : forall sf sb bp ll,
      ~ Fmap.indom sb bp ->
      eval (sf, sb) (bval_create (val_listint ll))
        (sf, (Fmap.update sb bp ll)) (val_bloc bp)

  | eval_bget : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_get (val_bloc bp)) (sf, sb) (val_listint (Fmap.read sb bp))

  | eval_bdelete : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_delete (val_bloc bp)) (sf, (Fmap.remove sb bp)) val_unit

  | eval_bsize : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_bsize (val_bloc bp))
           (sf, sb) (val_int (List.length (Fmap.read sb bp)))

  | eval_bappend_list : forall sf sb bp ll,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_append (val_bloc bp) (val_listint ll))
        (sf, (Fmap.update sb bp ((Fmap.read sb bp) ++ ll) ))  val_unit

 (*----------- file prim operation -----------*)
  | eval_fcreate_list : forall sf sb fp bll,
      ~ Fmap.indom sf fp ->
      noduplicates bll ->
      eval (sf, sb) (fval_create (val_listbloc bll))
        ((Fmap.update sf fp bll), sb) (val_floc fp)

  | eval_fget : forall sf sb fp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_get (val_floc fp)) (sf, sb) (val_listbloc (Fmap.read sf fp))

  | eval_fsize : forall sf sb fp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_fsize (val_floc fp))
           (sf, sb) (val_int (List.length (Fmap.read sf fp)))

  | eval_fget_nth_blk : forall sf sb fp n,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_get_nth_blk (val_floc fp) n) (sf, sb)
           (val_bloc (nth_default bnull (Z.to_nat n) (Fmap.read sf fp)))

  | eval_fset_nth_blk : forall sf sb fp n bp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_set_nth_blk (val_floc fp) n (val_bloc bp))
           (Fmap.update sf fp (LibList.update (to_nat n) bp (Fmap.read sf fp)), sb) val_unit

  | eval_fattach: forall sf sb fp lb,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_attach (val_floc fp) (val_listbloc lb))
       ((Fmap.update sf fp ( (Fmap.read sf fp) ++ lb )), sb) val_unit

  | eval_fdelete : forall sf sb fp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_delete (val_floc fp)) ( (Fmap.remove sf fp), sb) val_unit

  | eval_frev_blist : forall sf sb bl,
      eval (sf, sb) (fval_rev_blist (val_listbloc bl)) (sf, sb) (val_listbloc (LibList.rev bl))

  | eval_fbuffer : forall sf sb bp,
      eval (sf, sb) (fval_buffer (val_bloc bp)) (sf, sb) (val_listbloc (bp::nil))

  | eval_fbuffer_list : forall sf sb bp bl,
      eval (sf, sb) (fval_buffer_list (val_bloc bp) (val_listbloc bl)) (sf, sb) (val_listbloc (bp::bl))

  (*------------ trm rules ------------*)
   | eval_app_args : forall s1 s2 s3 s4 t1 t2 v1 v2 r,
      (~ trm_is_val t1 \/ ~trm_is_val t2) ->
      eval s1 t1 s2 v1 ->
      eval s2 t2 s3 v2 ->
      eval s3 (trm_app v1 v2) s4 r ->
      eval s1 (trm_app t1 t2) s4 r
   | eval_app_fun : forall s1 s2 v1 v2 x t1 v,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) s2 v ->
      eval s1 (trm_app v1 v2) s2 v
   | eval_app_fix : forall s1 s2 v1 v2 f x t1 v,
      v1 = val_fix f x t1 ->
      eval s1 (subst x v2 (subst f v1 t1)) s2 v ->
      eval s1 (trm_app v1 v2) s2 v
   | eval_seq : forall s1 s2 s3 t1 t2 v1 v,
      eval s1 t1 s2 v1 ->
      eval s2 t2 s3 v ->
      eval s1 (trm_seq t1 t2) s3 v
   | eval_let : forall s1 s2 s3 x t1 t2 v1 r,
      eval s1 t1 s2 v1 ->
      eval s2 (subst x v1 t2) s3 r ->
      eval s1 (trm_let x t1 t2) s3 r
   | eval_if : forall s1 s2 b v t1 t2,
      eval s1 (if b then t1 else t2) s2 v ->
      eval s1 (trm_if (val_bool b) t1 t2) s2 v.

(*  --------------- some relation about terms --------------- *)
Definition eval_like (t1 t2:trm) : Prop :=
  forall s s' v, eval s t1 s' v -> eval s t2 s' v.

Definition trm_equiv (t1 t2:trm) : Prop :=
  forall s s' v, eval s t1 s' v <-> eval s t2 s' v.

Lemma eval_like_eta_reduction : forall (t:trm) (x:var),
  eval_like t (trm_let x t x).
Proof using.
  introv R. applys eval_let R.
  simpl. rewrite var_eq_spec. case_if. apply eval_val.
Qed.

Lemma eval_like_eta_expansion : forall (t:trm) (x:var),
  eval_like (trm_let x t x) t.
Proof using.
  introv R. inverts R as. introv R1 R2.
  simpl in R2. rewrite var_eq_spec in R2. case_if.
  inverts R2; apply R1.
Qed.

Lemma trm_equiv_eta : forall (t:trm) (x:var),
  trm_equiv t (trm_let x t x).
Proof using.
  intros. intros s s' v. iff M.
  { applys eval_like_eta_reduction M. }
  { applys eval_like_eta_expansion M. }
Qed.

(* ################### evaluation rule in SL style ############################## *)

(*----------- block prim operations -----------*)

Lemma eval_bcreate_sep : forall sf sb1 sb2 l bp,
  sb2 = Fmap.single bp l ->
  Fmap.disjoint sb2 sb1 ->
  eval (sf, sb1) (bval_create (val_listint l))
       (sf, (Fmap.union sb2 sb1)) (val_bloc bp).
Proof.
  introv -> M. forwards Db: Fmap.indom_single bp l.
  rewrite <- Fmap.update_eq_union_single.
  apply~ eval_bcreate_list.
  { intros N. applys~ Fmap.disjoint_inv_not_indom_both M N. }
Qed.

Lemma eval_bget_sep : forall sf sb sb2 bp l,
  sb = Fmap.union (Fmap.single bp l) sb2 ->
  eval (sf, sb) (bval_get (val_bloc bp))
       (sf, sb) (val_listint l).
Proof.
  introv ->. forwards Dv: Fmap.indom_single bp l.
  applys_eq eval_bget 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_bsize_sep : forall sf sb sb2 bp l,
  sb = Fmap.union (Fmap.single bp l) sb2 ->
  eval (sf, sb) (bval_bsize (val_bloc bp))
       (sf, sb) (List.length l).
Proof.
  introv ->. forwards Dv: Fmap.indom_single bp l.
  applys_eq eval_bsize 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_bdelete_sep : forall sf sb1 sb2 bp l,
  sb1 = Fmap.union (Fmap.single bp l) sb2 ->
  Fmap.disjoint (Fmap.single bp l) sb2 ->
  eval (sf, sb1) (bval_delete (val_bloc bp))
       (sf, sb2) val_unit.
Proof.
  introv -> D. forwards Db: Fmap.indom_single bp l.
  applys_eq eval_bdelete 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.remove_union_single_l.
    intros D1. applys~ Fmap.disjoint_inv_not_indom_both D D1. }
Qed.

Lemma eval_bappend_sep : forall sf sb1 sb2 sb bp l1 l2,
  sb1 = Fmap.union (Fmap.single bp l1) sb ->
  sb2 = Fmap.union (Fmap.single bp (l1++l2)) sb ->
  Fmap.disjoint (Fmap.single bp l1) sb ->
  eval (sf, sb1) (bval_append (val_bloc bp) (val_listint l2))
       (sf, sb2) val_unit.
Proof.
  introv -> -> D. forwards Db: Fmap.indom_single bp l1.
  applys_eq eval_bappend_list 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite Fmap.read_union_l, Fmap.read_single; auto.
    rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single. }
Qed.

(*--------- file prim operations ---------*)

Lemma eval_fcreate_sep : forall sf1 sb sf2 bll fp,
  sf2 = Fmap.single fp bll ->
  Fmap.disjoint sf2 sf1 ->
  noduplicates bll ->
  eval (sf1, sb) (fval_create (val_listbloc bll))
       ((Fmap.union sf2 sf1), sb) (val_floc fp).
Proof.
  introv -> D. forwards Db: Fmap.indom_single fp bll.
  rewrite <- Fmap.update_eq_union_single.
  apply eval_fcreate_list.
  { intros N. applys~ Fmap.disjoint_inv_not_indom_both D N. }
Qed.

Lemma eval_fsize_sep : forall sf sb sf2 fp l,
  sf = Fmap.union (Fmap.single fp l) sf2 ->
  eval (sf, sb) (fval_fsize (val_floc fp))
       (sf, sb) (List.length l).
Proof.
  introv ->. forwards Dv: Fmap.indom_single fp l.
  applys_eq eval_fsize 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fget_sep : forall sf sb sf2 bll fp,
  sf = Fmap.union (Fmap.single fp bll) sf2 ->
  eval (sf, sb) (fval_get (val_floc fp))
       (sf, sb) (val_listbloc bll).
Proof.
  introv ->. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fget 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fget_nth_blk_sep : forall sf sb sf2 bll fp n,
  sf = Fmap.union (Fmap.single fp bll) sf2 ->
  eval (sf, sb) (fval_get_nth_blk (val_floc fp) n)
       (sf, sb) (val_bloc (nth_default bnull (Z.to_nat n) bll)).
Proof.
  introv ->. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fget_nth_blk 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fset_nth_blk_sep : forall sf sb sf1 sf2 bll fp n bp,
  sf1 = Fmap.union (Fmap.single fp bll) sf ->
  sf2 = Fmap.union (Fmap.single fp (LibList.update (to_nat n) bp bll)) sf ->
  Fmap.disjoint (Fmap.single fp bll) sf ->
  eval (sf1, sb) (fval_set_nth_blk (val_floc fp) n (val_bloc bp))
       (sf2, sb) (val_unit).
Proof.
  introv -> -> D. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fset_nth_blk 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single.
    rewrite~ Fmap.read_union_l.
    rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fdelete_sep : forall sf1 sb sf2 bll fp,
  sf1 = Fmap.union (Fmap.single fp bll) sf2 ->
  Fmap.disjoint (Fmap.single fp bll) sf2 ->
  eval (sf1, sb) (fval_delete (val_floc fp))
       (sf2, sb) val_unit.
Proof.
  introv -> D. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fdelete 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.remove_union_single_l. intros D1.
    applys~  Fmap.disjoint_inv_not_indom_both D D1. }
Qed.

Lemma eval_fattach_sep : forall sf sf1 sf2 sb fp bl1 bl2,
  sf1 = Fmap.union (Fmap.single fp bl1) sf ->
  sf2 = Fmap.union (Fmap.single fp (bl1++bl2)) sf ->
  Fmap.disjoint (Fmap.single fp bl1) sf ->
  eval (sf1, sb) (fval_attach (val_floc fp) (val_listbloc bl2))
       (sf2, sb) val_unit.
Proof.
  introv -> -> D. forwards Db: Fmap.indom_single fp bl1.
  applys_eq eval_fattach 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite Fmap.read_union_l, Fmap.read_single; auto.
    rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single. }
Qed.

(*==============================================================*)
(* ############ Notations of the language (to improve the readability) #################### *)
Module NotationForTrm.

(** ** Notation for terms *)
Notation "'If_' t0 'Then' t1 'Else' t2" :=
  (trm_if t0 t1 t2)
  (at level 69, t0 at level 0) : trm_scope.

Notation "'If_' t0 'Then' t1 'End'" :=
  (trm_if t0 t1 val_unit)
  (at level 69, t0 at level 0) : trm_scope.

Notation "'Let' x ':=' t1 'in' t2" :=
  (trm_let x t1 t2)
  (at level 69, x at level 0, right associativity,
  format "'[v' '[' 'Let'  x  ':='  t1  'in' ']'  '/'  '[' t2 ']' ']'") : trm_scope.

Notation "t1 '';' t2" :=
  (trm_seq t1 t2)
  (at level 68, right associativity,
   format "'[v' '[' t1 ']'  '';'  '/'  '[' t2 ']' ']'") : trm_scope.

Notation "'Fix' f x1 ':=' t" :=
  (val_fix f x1 t)
  (at level 69, f, x1 at level 0, format "'Fix'  f  x1  ':='  t") : val_scope.

Notation "'Fix' f x1 x2 ':=' t" :=
  (val_fix f x1 (trm_fun x2 t))
  (at level 69, f,x1, x2 at level 0, format "'Fix'  f x1 x2 ':=' t") : val_scope.

Notation "'Fix' f x1 x2 x3 ':=' t" :=
  (val_fix f x1 (trm_fun x2 (trm_fun x3 t)))
  (at level 69, f,x1, x2, x3 at level 0, format "'Fix'  f x1 x2 x3 ':=' t") : val_scope.

Notation "'Fix_' f x1 ':=' t" :=
  (trm_fix f x1 t)
  (at level 69, f, x1 at level 0, format "'Fix_'  f  x1  ':='  t") : trm_scope.

Notation "'Fun' x1 ':=' t" :=
  (val_fun x1 t)
  (at level 69, x1 at level 0, format "'Fun'  x1  ':='  t") : val_scope.

Notation "'Fun' x1 x2 ':=' t" :=
  (val_fun x1 (trm_fun x2 t))
  (at level 69, x1, x2 at level 0, format "'Fun' x1 x2 ':=' t") : val_scope.

Notation "'Fun' x1 x2 x3 ':=' t" :=
  (val_fun x1 (trm_fun x2 (trm_fun x3 t)))
  (at level 69, x1, x2, x3 at level 0, format "'Fun' x1 x2 x3 ':=' t") : val_scope.

Notation "'Fun_' x1 ':=' t" :=
  (trm_fun x1 t)
  (at level 69, x1 at level 0, format "'Fun_'  x1  ':='  t") : trm_scope.

Notation "'Fun_' x1 x2 ':=' t" :=
  (trm_fun x1 (trm_fun x2 t))
  (at level 69, x1, x2 at level 0, format "'Fun_' x1 x2 ':=' t") : trm_scope.

Notation "'Fun_' x1 x2 x3 ':=' t" :=
  (trm_fun x1 (trm_fun x2 (trm_fun x3 t)))
  (at level 69, x1, x2, x3 at level 0, format "'Fun_' x1 x2 x3 ':=' t") : trm_scope.

(* ----------Notations of file prim---------------- *)
Notation "'fcreate ll" :=
  (fval_create ll)
  (at level 67) : trm_scope.

Notation "'frev bl" :=
  (fval_rev_blist bl)
  (at level 67) : trm_scope.

Notation "'fbuffer p" :=
  (fval_buffer p)
  (at level 67) : trm_scope.

Notation "'fatt bp l" :=
  (fval_attach bp l)
  (at level 67,bp at level 0,format "''fatt' bp l").

Notation "'set_nth_blk fp n 'As bp" :=
  (fval_set_nth_blk fp n bp)
  (at level 67, fp,bp at level 0,format "''set_nth_blk' fp n ''As' bp") : trm_scope.

Notation "'fsize p" :=
  (fval_fsize p)
  (at level 67) : trm_scope.

Notation "'fdelete fp" :=
  (fval_delete fp)
  (at level 67) : trm_scope.

Notation "'nth_blk fp n" :=
  (fval_get_nth_blk fp n)
  (at level 67, fp at level 0,format "''nth_blk' fp n") : trm_scope.

Notation "bp 'b+ bl" :=
  (fval_buffer_list bp bl)
  (at level 67) : trm_scope.

(* ----------Notations of block prim---------------- *)
Notation "'bcreate ll" :=
  (bval_create ll)
  (at level 67) : trm_scope.

Notation "'bapp bp l" :=
  (bval_append bp l)
  (at level 67,bp at level 0,format "''bapp' bp l") : trm_scope.

Notation "'bsize p" :=
  (bval_bsize p)
  (at level 67) : trm_scope.

Notation "'bget bp" :=
  (bval_get bp)
  (at level 67) : trm_scope.

Notation "'bsize bp" :=
  (bval_bsize bp)
  (at level 67) : trm_scope.

Notation "'bdelete bp" :=
  (bval_delete bp)
  (at level 67) : trm_scope.

(* ----------Notations of aux prim---------------- *)
Notation "n1 '= n2" :=
  (val_eq n1 n2)
  (at level 67) : trm_scope.

Notation "n1 '+ n2" :=
  (val_add n1 n2)
  (at level 67) : trm_scope.

Notation "l1 '++ l2" :=
  (val_list_app l1 l2)
  (at level 67) : trm_scope.

Notation "'rev l1" :=
  (val_list_rev l1)
  (at level 67) : trm_scope.

Notation "'()" := val_unit : trm_scope.

End NotationForTrm.


Set Implicit Arguments.

Require Import Bedrock.Platform.Cito.GoodModuleDec.

Section TopSection.

  Notation MName := SyntaxModule.Name.
  Notation FName := SyntaxFunc.Name.
  Notation Funcs := SyntaxModule.Functions.

  Require Import Bedrock.Platform.Cito.IsGoodModule.
  Require Import Bedrock.Platform.Cito.GoodModule.

  Require Import Bedrock.Platform.Cito.ListFacts4.
  Require Import Coq.Lists.List.

  Require Import Coq.Bool.Bool.
  Require Import Bedrock.Platform.Cito.GeneralTactics.
  Require Import Bedrock.Platform.Cito.GeneralTactics2.

  Require Import Coq.Program.Basics.
  Require Import Bedrock.Platform.Cito.GoodFunc.

  Require Import Bedrock.Platform.Cito.WellFormed.

  Lemma is_good_size_sound : forall n, is_good_size n = true -> goodSize n.
    intros.
    unfold is_good_size in *.
    Local Open Scope N_scope.
    destruct (ZArith_dec.Dcompare_inf (N.of_nat n ?= Npow2 32)) as [ [Hc | Hc] | Hc ]; rewrite Hc in *.
    discriminate.
    eapply N.compare_lt_iff in Hc; eauto.
    discriminate.
  Qed.

  Hint Constructors args_not_too_long.

  Lemma is_arg_len_ok_sound : forall s, is_arg_len_ok s = true -> wellformed s.
    unfold wellformed.
    induction s; simpl; intuition eauto.
    eapply andb_true_iff in H; openhyp; eauto.
    eapply andb_true_iff in H; openhyp; eauto.
    econstructor.
    eapply is_good_size_sound; eauto.
  Qed.
  Require Import Bedrock.Platform.Cito.ListFacts3.
  Require Import Bedrock.Platform.Cito.NoUninitDecFacts.

  Lemma is_good_func_sound : forall f, is_good_func f = true -> GoodFunc f.
    unfold is_good_func.
    intros.
    repeat (eapply andb_true_iff in H; openhyp).
    econstructor.
    eauto.
    split.
    eapply is_no_uninited_sound; eauto.
    split.
    eapply is_arg_len_ok_sound; eauto.
    eapply is_good_size_sound; eauto.
  Qed.

  Lemma is_good_funcs_sound : forall ls, is_good_funcs (map Core ls) = true -> Forall (compose GoodFunc Core) ls.
    intros.
    unfold is_good_funcs in *.
    eapply Forall_forall.
    intros.
    eapply forallb_forall in H.
    2 : eapply in_map; eauto.
    unfold compose.
    eapply is_good_func_sound; eauto.
  Qed.
  Require Import Bedrock.Platform.Cito.NameDecoration.

  Lemma is_good_module_sound : forall m, is_good_module m = true -> IsGoodModule m.
    intros.
    unfold is_good_module in *.
    destruct m; simpl in *.
    eapply andb_true_iff in H.
    openhyp.
    eapply andb_true_iff in H.
    openhyp.
    econstructor; simpl.
    eapply is_good_module_name_sound; eauto.
    split.
    eapply is_good_funcs_sound; eauto.
    eapply is_no_dup_sound; eauto.
  Qed.

End TopSection.