From Coq Require Import String Arith NArith ZArith Eqdep_dec.
From Vyper Require Import Config Calldag.
From Vyper.L10 Require Import AST Base Callset Descend Expr Stmt.
From Vyper Require FSet Map UInt256.

Local Open Scope list_scope.
Local Open Scope string_scope.

Section Interpret.
Context {C: VyperConfig}.

(** Initialize a map of local variables with argument names and argument values. *)
Fixpoint bind_args (names: list string) (values: list uint256)
: string + string_map uint256
:= let _ := string_map_impl in
   match names with
   | nil => match values with
            | nil => inr Map.empty
            | _ => inl "function called with too many arguments"
            end
   | hn :: tn => match values with
                 | nil => inl "function called with too few arguments"
                 | hv :: tv =>
                     match bind_args tn tv with
                     | inl err => inl err
                     | inr bindings =>
                        match Map.lookup bindings hn with
                        | Some _ => inl "duplicate argument name"
                        | None => inr (Map.insert bindings hn hv)
                        end
                     end
                 end
   end.

Local Lemma interpret_call_helper {this_decl: decl}
                                  {fun_name: string}
                                  {arg_names: list string}
                                  {body: list stmt}
                                  (E: this_decl = FunDecl fun_name arg_names body):
  let _ := string_set_impl in FSet.is_subset (stmt_list_callset body) (decl_callset this_decl) = true.
Proof.
subst this_decl. unfold decl_callset. apply FSet.is_subset_refl.
Qed.

Fixpoint interpret_call {call_depth_bound: nat}
                        {cd: calldag}
                        (builtins: string -> option builtin)
                        (fc: fun_ctx cd call_depth_bound)
                        (world: world_state)
                        (arg_values: list uint256)
{struct call_depth_bound}
: world_state * expr_result uint256
:= match call_depth_bound as call_depth_bound' return _ = call_depth_bound' -> _ with
   | O => fun Ebound => False_rect _ (Nat.nlt_0_r (fun_depth fc)
                                                  (eq_ind _ _
                                                          (proj1 (Nat.ltb_lt _ _) (fun_bound_ok fc))
                                                          _ Ebound))
   | S new_call_depth_bound => fun Ebound =>
      match fun_decl fc as d return _ = d -> _ with
      | FunDecl _ arg_names body => fun E =>
          match bind_args arg_names arg_values with
          | inl err => (world, expr_error err)
          | inr loc =>
              let '(world', loc', result) := interpret_stmt_list Ebound fc (interpret_call builtins)
                                                                 builtins world loc body
                                                                 (interpret_call_helper E)
              in (world', match result with
                          | StmtSuccess => ExprSuccess zero256
                          | StmtReturnFromFunction x => ExprSuccess x
                          | StmtAbort AbortBreak
                          | StmtAbort AbortContinue => expr_error "break and continue not allowed"
                          | StmtAbort a => ExprAbort a
                          end)
          end
      | _ => fun _ => (world, expr_error "declaration not found")
      end eq_refl
  end eq_refl.

(** This is a simplified interface to interpret_call that takes care of creating a function context. *)
Definition interpret (builtins: string -> option builtin)
                     (cd: calldag)
                     (function_name: string)
                     (world: world_state)
                     (arg_values: list uint256)
: world_state * expr_result uint256
:= match make_fun_ctx_and_bound cd function_name with
   | None => (world, expr_error "declaration not found")
   | Some (existT _ bound fc) => interpret_call builtins fc world arg_values
   end.

End Interpret.


Require Import UNIVERSE.
Require Import CoqlibC.
Require Import Simulation.
Require Import LinkingC.
Require Import Smallstep.

Require Import ModSem Mod Sem.
Require Import SimSymb SimMem SimMod SimModSem SimProg (* SimLoad *) SimProg.
Require Import SemProps Ord.
Require Import Sound Preservation.

Set Implicit Arguments.

Section ADQSOUND.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Hypothesis SIMPROG: ProgPair.sim pp.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).
  Hypothesis (WFSKSRC: forall md (IN: In md p_src), <<WF: Sk.wf md>>).
  Hypothesis (WFSKTGT: forall md (IN: In md p_tgt), <<WF: Sk.wf md>>).

  Variable sk_link_src sk_link_tgt: Sk.t.
  Hypothesis LINKSRC: (link_sk p_src) = Some sk_link_src.
  Hypothesis LINKTGT: (link_sk p_tgt) = Some sk_link_tgt.
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Let skenv_link_src := (Sk.load_skenv sk_link_src).
  Let skenv_link_tgt := (Sk.load_skenv sk_link_tgt).

  Variable ss_link: SimSymb.t.
  Hypothesis (SIMSKENV: exists sm, SimSymb.sim_skenv sm ss_link skenv_link_src skenv_link_tgt).

  Hypothesis INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src)).
  Hypothesis INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt)).
  Hypothesis SSLE: forall mp (IN: In mp pp), SimSymb.le mp.(ModPair.ss) ss_link.

  Let WFSKLINKSRC: Sk.wf sk_link_src. eapply link_list_preserves_wf_sk; et. Qed.
  Let WFSKLINKTGT: Sk.wf sk_link_tgt. eapply link_list_preserves_wf_sk; et. Qed.

  (* Let ge: Ge.t := sem_src.(Smallstep.globalenv). *)

  Inductive sound_ge (su0: Sound.t) (m0: mem): Prop :=
  | sound_ge_intro
      (GE: Forall (fun ms => su0.(Sound.skenv) m0 ms.(ModSem.skenv) /\ su0.(Sound.skenv) m0 ms.(ModSem.skenv_link))
                  (fst sem_src.(Smallstep.globalenv)))
  .

  Lemma lepriv_preserves_sound_ge
        m0 su0 su1
        (GE: sound_ge su0 m0)
        (LE: Sound.lepriv su0 su1):
      <<GE: sound_ge su1 m0>>.
  Proof.
    inv GE. econs; eauto. rewrite Forall_forall in *. ii. split; eapply Sound.skenv_lepriv; try apply GE0; eauto.
  Qed.

  Lemma hle_preserves_sound_ge
        m0 su0 su1
        (WF: Sound.wf su0)
        (GE: sound_ge su0 m0)
        (LE: Sound.hle su0 su1):
      <<GE: sound_ge su1 m0>>.
  Proof.
    eapply lepriv_preserves_sound_ge; eauto. eapply Sound.hle_lepriv; et.
  Qed.

  Lemma mle_preserves_sound_ge
        m0 m1 su0
        (GE: sound_ge su0 m0)
        (LE: Sound.mle su0 m0 m1):
      <<GE: sound_ge su0 m1>>.
  Proof.
    inv GE. econs; eauto. rewrite Forall_forall in *. ii. split; eapply Sound.skenv_mle; try apply GE0; eauto.
  Qed.

  (* stack can go preservation when su0 is given *)
  Inductive sound_stack (args: Args.t): list Frame.t -> Prop :=
  | sound_stack_nil
      (EXSU: exists su_ex, Sound.args su_ex args /\ sound_ge su_ex (Args.get_m args)):
      sound_stack args []
  | sound_stack_cons
      args_tail tail ms lst0
      (TL: sound_stack args_tail tail)
      (FORALLSU: forall su0
          (SUARGS: Sound.args su0 args_tail)
          (SUGE: sound_ge su0 (Args.get_m args_tail)),
          (<<HD: forall
                 sound_state_all
                 (PRSV: local_preservation_noguarantee ms sound_state_all),
                 <<SUST: sound_state_all su0 (Args.get_m args_tail) lst0>>>>)
          /\
          (<<K: forall
                 sound_state_all
                 (PRSV: local_preservation_noguarantee ms sound_state_all),
                 (* (<<SUST: sound_state_all su0 args.(Args.get_m) lst0>>) *)
                 (* /\ *)
                 exists su_gr,
                   (<<ARGS: Sound.args su_gr args>>) /\
                   (<<LE: Sound.lepriv su0 su_gr>>) /\
                   (<<K: forall retv lst1 su_ret
                       (LE: Sound.hle su_gr su_ret)
                       (SURETV: Sound.retv su_ret retv)
                       (MLE: Sound.mle su_gr (Args.get_m args) (Retv.get_m retv))
                       (AFTER: ms.(ModSem.after_external) lst0 retv lst1),
                       (* sound_state_all su0 args.(Args.get_m) lst1>>) *)
                       sound_state_all su0 (Args.get_m args_tail) lst1>>)
             >>)
          /\
          (<<MLE: Sound.mle su0 (Args.get_m args_tail) (Args.get_m args)>>)
      )
      (EXSU: exists su_ex, Sound.args su_ex args_tail /\ sound_ge su_ex (Args.get_m args_tail))
      (EX: exists sound_state_ex, local_preservation ms sound_state_ex):
      sound_stack args ((Frame.mk ms lst0) :: tail).

  Inductive sound_state: state -> Prop :=
  | sound_state_normal
      args_tail tail ms lst0 m_arg
      (TL: sound_stack args_tail tail)
      (EXSU: exists su_ex, Sound.args su_ex args_tail /\ sound_ge su_ex m_arg)
      (FORALLSU: forall su0
          (SUARGS: Sound.args su0 args_tail)
          (SUGE: sound_ge su0 (Args.get_m args_tail)),
          (<<HD: forall
              sound_state_all
              (PRSV: local_preservation_noguarantee ms sound_state_all),
              <<SUST: sound_state_all su0 m_arg lst0>>>>))
      (EX: exists sound_state_ex, local_preservation ms sound_state_ex)
      (ABCD: (Args.get_m args_tail) = m_arg)
    :
      sound_state (State ((Frame.mk ms lst0) :: tail))
  | sound_state_call
      m_tail frs args
      (* (ARGS: Sound.args su0 args) *)
      (STK: sound_stack args frs)
      (* (MLE: Sound.mle su0 m_tail args.(Args.get_m)) *)
      (EQ: (Args.get_m args) = m_tail)
      (EXSU: exists su_ex, Sound.args su_ex args /\ sound_ge su_ex m_tail):
      sound_state (Callstate args frs).

  Lemma sound_init
        st0
        (INIT: sem_src.(Smallstep.initial_state) st0):
    <<SU: sound_state st0>>.
  Proof.
    inv INIT. clarify. clear skenv_link_tgt p_tgt skenv_link_tgt sem_tgt LINKTGT INCLTGT WFSKTGT SIMSKENV.
    hexploit Sound.init_spec; eauto. i; des. esplits; eauto.
    assert(WFSKE: SkEnv.wf (Sk.load_skenv sk_link_src)).
    { eapply SkEnv.load_skenv_wf; et. }
    assert(GE: sound_ge su_init m_init).
    { econs. rewrite Forall_forall. intros ? IN. ss. des_ifs. u in IN.
      rewrite in_map_iff in IN. des; ss; clarify.
      + s. split; try eapply Sound.system_skenv; eauto.
      + assert(INCL: SkEnv.includes (Sk.load_skenv sk_link_src) (Mod.sk x0)).
        { unfold p_src in IN0. unfold ProgPair.src in *. rewrite in_map_iff in IN0. des. clarify. eapply INCLSRC; et. }
        split; ss.
        * eapply Sound.skenv_project; eauto.
          { eapply link_load_skenv_wf_mem; et. }
          rewrite <- Mod.get_modsem_skenv_spec; ss. eapply SkEnv.project_impl_spec; et.
        * rewrite Mod.get_modsem_skenv_link_spec. ss.
    }
    econs; eauto. econs; eauto.
    (* - eapply Sound.greatest_adq; eauto. *)
    (* - econs; eauto. *)
    (* - eapply vle_preserves_sound_ge; eauto. *)
    (*   eapply Sound.greatest_adq; eauto. *)
  Unshelve.
    all: ss.
  Qed.

  Lemma sound_progress
        st0 tr st1
        (SUST: sound_state st0)
        (STEP: Step sem_src st0 tr st1):
      <<SUST: sound_state st1>>.
  Proof.
    inv STEP.
    - (* CALL *)
      inv SUST. ss. des. exploit FORALLSU; eauto. { eapply local_preservation_noguarantee_weak; eauto. } intro T; des.
      inv EX. exploit CALL; eauto. i; des. esplits; eauto. econs; eauto; cycle 1.
      + esplits; eauto. eapply lepriv_preserves_sound_ge; eauto.
        { eapply mle_preserves_sound_ge; eauto. }
      + econs; eauto; cycle 1.
        { esplits; eauto. econs; eauto. }
        ii. esplits; eauto.
        * ii. exploit FORALLSU; try apply SUARGS; eauto.
        * ii. exploit FORALLSU; try apply SUARGS; eauto. intro U; des.
          inv PRSV. exploit CALL0; eauto. i; des. esplits; eauto. ii. eapply K0; eauto.
        * exploit FORALLSU; eauto.
          { eapply local_preservation_noguarantee_weak; eauto. econs; eauto. }
          i; des. exploit CALL; eauto. i; des. ss.
    - (* INIT *)
      inv SUST. ss. des_ifs. esplits; eauto. econs; eauto.
      + ii. esplits; eauto.
        * ii. inv PRSV. inv SUGE. rewrite Forall_forall in *.
          exploit GE; eauto. { ss. des_ifs. eapply MSFIND. } intro T; des. eapply INIT0; et.
      + inv MSFIND. ss. rr in SIMPROG. rewrite Forall_forall in *. des; clarify.
        { eapply system_local_preservation. }
        u in MODSEM. rewrite in_map_iff in MODSEM. des; clarify. rename x into md_src.
        assert(exists mp, In mp pp /\ mp.(ModPair.src) = md_src).
        { clear - MODSEM0. rr in pp. rr in p_src. subst p_src. rewrite in_map_iff in *. des. eauto. }
        des. exploit SIMPROG; eauto. intros MPSIM. inv MPSIM.
        destruct SIMSKENV. exploit SIMMS.
        { eapply INCLSRC; et. }
        { eapply INCLTGT; et. }
        { eapply SkEnv.load_skenv_wf; et. }
        { eapply SkEnv.load_skenv_wf; et. }
        { eapply SSLE; eauto. }
        { eauto. }
        intro SIM; des. inv SIM. ss. esplits; eauto.
    - (* INTERNAL *)
      inv SUST. ss. esplits; eauto. econs; eauto. i. des.
      exploit FORALLSU; eauto. { eapply local_preservation_noguarantee_weak; eauto. } intro U; des. esplits; eauto. i. ss. inv PRSV.
      eapply STEP; eauto.
      + eapply FORALLSU; eauto. econs; eauto.
      + split; ii; ModSem.tac.
    - (* RETURN *)
      inv SUST. ss. rename ms into ms_top. rename args_tail into args_tail_top.
      inv TL. ss. unfold Frame.update_st. s. des. esplits; eauto. econs; eauto. ii. esplits; eauto.
      + ii. exploit FORALLSU0; eauto. i; des. exploit K; eauto. i; des. inv EX.
        exploit RET; eauto.
        { eapply FORALLSU; eauto.
          { eapply lepriv_preserves_sound_ge. { eapply mle_preserves_sound_ge; eauto. } eauto. }
          { eapply local_preservation_noguarantee_weak; eauto. econs; et. } }
        i; des.
        eapply K0; eauto.
  Unshelve.
    all: ss.
  Qed.

  (* Lemma sound_progress_star *)
  (*       st0 tr st1 *)
  (*       (SUST: sound_state st0) *)
  (*       (STEP: Star sem_src st0 tr st1): *)
  (*     <<SUST: sound_state st1>>. *)
  (* Proof. *)
  (*   induction STEP. *)
  (*   - esplits; eauto. *)
  (*   - clarify. i. exploit sound_progress; eauto. *)
  (* Qed. *)

  (* Lemma sound_progress_plus *)
  (*       st0 tr st1 *)
  (*       (SUST: sound_state st0) *)
  (*       (STEP: Plus sem_src st0 tr st1): *)
  (*     <<SUST: sound_state st1>>. *)
  (* Proof. *)
  (*   eapply sound_progress_star; eauto. eapply plus_star; eauto. *)
  (* Qed. *)

  Theorem preservation: @preservation sem_src sound_state.
  Proof.
    econs.
    - eapply sound_init.
    - eapply sound_progress.
  Qed.

End ADQSOUND.


(* *********************************************************************)
(*                                                                     *)
(*              The L2C verified compiler                              *)
(*                                                                     *)
(*            L2C Group, Tsinghua University                           *)
(*                                                                     *)
(*  Copyright Tsinghua University.  All rights reserved.  This file is *)
(*  distributed under the terms of the GNU General Public License as   *)
(*  published by the Free Software Foundation, either version 2 of the *)
(*  License, or (at your option) any later version.  This file is also *)
(*  distributed under the terms of the INRIA Non-Commercial License    *)
(*  Agreement.                                                         *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import AST.
Require Import Errors.
Require Import Integers.
Require Import Floats.
Require Import Zwf.
Require Import Maps.
Require Import Memory.
Require Import Globalenvs.
Require Import Ctypes.
Require Import Cltypes.
Require Import ExtraList.
Require Import Streams.
Require Import Peano.
Require Import Lident.
Require Import Ltypes.
Require Import Lvalues.
Require Import Lustre.

Set Implicit Arguments.

Section PTREE.

Variable A: Type.

Lemma ptree_set_swap:
  forall e id1 id2 (a1 a2: A), id1 <> id2 ->
  PTree.set id2 a2 (PTree.set id1 a1 e) = PTree.set id1 a1 (PTree.set id2 a2 e).
Proof.
  induction e; induction id1; induction id2;
  simpl; intros; auto; try congruence.
  f_equal. apply IHid1. congruence.
  f_equal. apply IHid1. congruence.
  f_equal. apply IHe2. congruence.
  f_equal. apply IHe1. congruence.
Qed.

Lemma ptree_set_repeat_leaf:
  forall id (v: A) v1,
  PTree.set id v (PTree.set id v1 PTree.Leaf) = PTree.set id v PTree.Leaf.
Proof.
  induction id; simpl; intros; f_equal; auto.
Qed.

Lemma ptree_set_repeat:
  forall e id (v: A) v1,
  PTree.set id v (PTree.set id v1 e) = PTree.set id v e.
Proof.
  induction e, id; simpl; intros; f_equal; auto;
  apply ptree_set_repeat_leaf.
Qed.

Lemma ptree_set_same:
  forall e id (v: A),
  e ! id = Some v ->
  PTree.set id v e = e.
Proof.
  induction e, id; simpl; intros; try congruence; f_equal; auto.
Qed.

End PTREE.

Section ENV.

(** The local environment maps local variables to mvl and types. *)

Definition locenv:= PTree.t (mvl*type).

(** The tempo environment maps tempo variables to tree of locenv. *)

Inductive env: Type := mkenv {
  le: locenv;  (**r local tempo environment. *)
  sube: PTree.t (list env)  (**r subset tempo environment of the node call. *)
}.

(** Subset tempo environment of the node call。*)

Definition subenv := PTree.t (list env).

Definition empty_locenv := PTree.empty (mvl*type).
Definition empty_subenv := PTree.empty (list env).
Definition empty_env := mkenv empty_locenv empty_subenv.

Definition nat_of_int(i: int):= nat_of_Z (Int.unsigned i).

(** The chage of env state after the node call executed. *)

Inductive callnd_env(c: calldef)(i: int): subenv -> subenv -> env -> env -> Prop :=
  | callnd_env_: forall se1 se2 e1 e2 efs,
     se1 ! (instid c) = Some efs ->
     nth_error efs (nat_of_int i) = value e1 ->
     se2 = PTree.set (instid c) (replace_nth efs (nat_of_int i) e2) se1 ->
     Z_of_nat (length efs) = Int.unsigned (intof_opti (callnum c)) ->
     callnd_env c i se1 se2 e1 e2.

(** The chage of env state after the node or function call executed. *)

Inductive call_env(c: calldef)(i: int): subenv -> subenv -> env -> env -> Prop :=
  | call_env_: forall se1 se2 e1 e2,
     cakind c = true ->
     callnd_env c i se1 se2 e1 e2 ->
     call_env c i se1 se2 e1 e2
  | call_env_func_: forall se,
     cakind c = false ->
     call_env c i se se empty_env empty_env.

(** The property of variable in locenv after allocation. *)

Definition locenv_range_perm_var(eh: locenv)(id: ident)(ty: type) :=
  exists m, eh ! id = Some (m,ty)
    /\ Z_of_nat (length m) = sizeof ty
    /\ range_perm m 0 (sizeof ty).

(** The property of variables in locenv after allocation. *)

Definition locenv_range_perm_vars(eh: locenv)(al: list (ident*type)) :=
  forall id ty, In (id,ty) al -> locenv_range_perm_var eh id ty.

Inductive callnd_inst_env(c: calldef)(i: int)(se: subenv): env -> Prop :=
  | callnd_inst_env_node: forall efs ef,
     se ! (instid c) = Some efs ->
     nth_error efs (nat_of_int i) = value ef ->
     Z_of_nat (length efs) = Int.unsigned (intof_opti (callnum c)) ->
     callnd_inst_env c i se ef.

Lemma callnd_env_range_i:
  forall cdef i se se' ef ef',
  callnd_env cdef i se se' ef ef' ->
  (0 <= Int.unsigned i < Int.unsigned (intof_opti (callnum cdef)))%Z.
Proof.
  intros. inv H. rewrite <-H3. apply nth_error_value_lt in H1.
  apply Nat2Z.inj_lt in H1. unfold nat_of_int in H1.
  generalize (Int.unsigned_range i); intros.
  rewrite nat_of_Z_eq in H1; try omega.
Qed.

Lemma callnd_inst_env_eq:
  forall cdef i se se' ef ef',
  callnd_env cdef i se se' ef ef' ->
  callnd_inst_env cdef i se ef.
Proof.
  induction 1. constructor 1 with efs; auto.
Qed.

Lemma call_env_determ1:
  forall cdef i se se1 se2 ef1 ef2 ef1' ef2',
  call_env cdef i se se1 ef1 ef1' ->
  call_env cdef i se se2 ef2 ef2' ->
  ef1 = ef2.
Proof.
  intros. inv H; inv H0; try congruence.
  inv H2; inv H3. rewrite H2 in H0. inv H0.
  rewrite H4 in H5. inv H5; auto.
Qed.

Lemma call_env_determ2:
  forall cdef i se se1 se2 ef ef',
  call_env cdef i se se1 ef ef' ->
  call_env cdef i se se2 ef ef' ->
  se1 = se2.
Proof.
  intros. inv H; inv H0; try congruence.
  inv H2; inv H3. congruence.
Qed.

End ENV.

Section GLOBAL_ENV.

(** Global environment. *)

Definition store_init_data(m: mvl)(p: Z)(id: init_data): option mvl:=
  match id with
  | Init_int8 n => store Mint8unsigned m p (Vint n)
  | Init_int16 n => store Mint16unsigned m p (Vint n)
  | Init_int32 n => store Mint32 m p (Vint n)
  | Init_float32 n => store Mfloat32 m p (Vsingle n)
  | Init_float64 n => store Mfloat64 m p (Vfloat n)
  | Init_space n => Some m
  | _ => None
  end.

Fixpoint store_init_datas(m: mvl)(p: Z)(idl: init_datas): option mvl :=
  match idl with
  | nil => Some m
  | id :: idl' =>
      match store_init_data m p id with
      | None => None
      | Some m' => store_init_datas m' (p + Genv.init_data_size id) idl'
      end
  end.

Definition init_data_type(init: init_data): Prop :=
  match init with
  | Init_addrof _ _ => False
  | _ => True
  end.

Definition init_data_types(inits: list init_data): Prop :=
  Forall init_data_type inits.

Lemma store_init_data_length:
  forall a o mv mv',
  store_init_data mv o a = Some mv' ->
  length mv' = length mv.
Proof.
  destruct a; simpl; intros; try congruence;
  apply store_length in H; auto.
Qed.

Lemma store_init_datas_length:
  forall il o mv mv',
  store_init_datas mv o il = Some mv' ->
  length mv' = length mv.
Proof.
  induction il; simpl; intros.
  +inv H. auto.
  +destruct (store_init_data mv o a) eqn:?; try congruence.
   apply store_init_data_length in Heqo0. rewrite <-Heqo0.
   eapply IHil; eauto.
Qed.

Lemma store_init_datas_types:
  forall il o mv mv',
  store_init_datas mv o il = Some mv' ->
  init_data_types il.
Proof.
  induction il; simpl; intros.
  constructor.
  destruct (store_init_data _ _ _) eqn:?; try congruence.
  constructor 2.
  destruct a; simpl in *; auto; try congruence.
  eapply IHil; eauto.
Qed.

Fixpoint loadbytes_store_init_data (m: mvl)(p: Z) (il: list init_data) {struct il} : Prop :=
  match il with
  | nil => True
  | Init_int8 n :: il' =>
      loadbytes m p 1 = Some (Lvalues.encode_val Mint8unsigned (Lvalues.Vint n))
      /\ loadbytes_store_init_data m (p + 1) il'
  | Init_int16 n :: il' =>
      loadbytes m p 2 = Some (Lvalues.encode_val Mint16unsigned (Lvalues.Vint n))
      /\ loadbytes_store_init_data m (p + 2) il'
  | Init_int32 n :: il' =>
      loadbytes m p 4 = Some (Lvalues.encode_val Mint32 (Lvalues.Vint n))
      /\ loadbytes_store_init_data m (p + 4) il'
  | Init_float32 n :: il' =>
      loadbytes m p 4 = Some (Lvalues.encode_val Mfloat32 (Lvalues.Vsingle n))
      /\ loadbytes_store_init_data m (p + 4) il'
  | Init_float64 n :: il' =>
      loadbytes m p 8 = Some (Lvalues.encode_val Mfloat64 (Lvalues.Vfloat n))
      /\ loadbytes_store_init_data m (p + 8) il'
  | Init_space n :: il' =>
      if zle n 0 then
        loadbytes_store_init_data m (p + Zmax n 0) il'
      else
        loadbytes m p (Zmax n 0) = Some (list_repeat (nat_of_Z (Zmax n 0)) (Byte Byte.zero))
        /\ loadbytes_store_init_data m (p + Zmax n 0) il'
  | _ :: il' => False
  end.

Lemma store_init_data_outside_bytes:
  forall a m p m',
  store_init_data m p a = Some m' ->
  forall n q,
  (q + n <= p \/ p + Genv.init_data_size a <= q)%Z ->
  loadbytes m' q n = loadbytes m q n.
Proof.
  destruct a; simpl; intros; try congruence;
  try (eapply loadbytes_store_other; eauto; fail);
  try (right; simpl; omega).
Qed.

Lemma store_init_datas_outside_bytes:
  forall il m p m',
  store_init_datas m p il = Some m' ->
  forall n q,
  (q + n <= p \/ p + Genv.init_data_list_size il <= q)%Z ->
  loadbytes m' q n = loadbytes m q n.
Proof.
  induction il; simpl.
  intros; congruence.
  intros until m'. caseEq (store_init_data m p a); try congruence.
  intros m1 A B n q C.
  generalize (Genv.init_data_size_pos a) (Genv.init_data_list_size_pos il). intros.
  transitivity (loadbytes m1 q n).
  eapply IHil; eauto. omega.
  eapply store_init_data_outside_bytes; eauto. omega.
Qed.

Lemma store_init_datas_loadbytes_app:
  forall chunk v m p m1 il m',
  store chunk m p v = Some m1 ->
  store_init_datas m1 (p + size_chunk chunk) il = Some m' ->
  loadbytes m' p (size_chunk chunk) = Some (encode_val chunk v).
Proof.
  intros. transitivity (loadbytes m1 p (size_chunk chunk)).
  eapply store_init_datas_outside_bytes; eauto. omega.
  generalize H; intros. apply store_length in H.
  unfold store in *. destruct (valid_access_dec _ _ _); try congruence.
  destruct v0.
  unfold loadbytes. rewrite pred_dec_true; auto.
  inv H1.
  assert(nat_of_Z (size_chunk chunk) = length (encode_val chunk v)).
    rewrite encode_val_length; auto.
  rewrite H1. rewrite getN_setN_same; auto.
   rewrite encode_val_length.
  red in H2. unfold size_chunk_nat. rewrite <-Z2Nat.inj_add; try omega.
  apply Nat2Z.inj_le. rewrite nat_of_Z_eq; try omega.
  red. rewrite <-H. auto.
Qed.

Lemma loadbytes_list_repeat_incl:
  forall m p q n1 n2 a,
  loadbytes m p n1 = Some (list_repeat (nat_of_Z n1) a) ->
  (p <= q /\ q + n2 <= p + n1)%Z ->
  (0 < n2)%Z ->
  loadbytes m q n2  = Some (list_repeat (nat_of_Z n2) a).
Proof.
  unfold loadbytes. intros.
  destruct (range_perm_dec m p _) eqn:?; inv H.
  rewrite pred_dec_true.
  +f_equal. replace q with (p+(q - p))%Z; try omega.
   red in r. rewrite Z2Nat.inj_add; try omega.
   rewrite getN_app with (n1:=nat_of_Z n1).
   unfold nat_of_Z in *. rewrite H3.
   unfold getN, getn.
   replace n1 with ((q-p)+(n1-(q-p)))%Z; try omega.
   rewrite Z2Nat.inj_add; try omega.
   rewrite list_repeat_app.
   rewrite skipn_length_app; rewrite length_list_repeat; try omega.
   rewrite minus_diag. simpl.
   apply firstn_list_repeat; auto.
   apply Nat2Z.inj_le; try omega.
   rewrite nat_of_Z_eq; try omega.
   rewrite nat_of_Z_eq; try omega.
   rewrite <-Z2Nat.inj_add; try omega.
   apply Nat2Z.inj_le; try omega.
   rewrite nat_of_Z_eq; try omega.
   rewrite nat_of_Z_eq; try omega.
  +unfold range_perm in *. omega.
Qed.

Lemma init_data_list_size_zero_loadbytes_store:
  forall l mv p, Genv.init_data_list_size l = 0%Z ->
  loadbytes_store_init_data mv p l.
Proof.
  induction l; simpl; intros; auto.
  generalize (Genv.init_data_list_size_pos l). intros.
  destruct a; simpl Genv.init_data_size in *; try omega.
  destruct (zle _ _); auto.
  rewrite Z.max_r in *; try omega. apply IHl; auto.
  rewrite Z.max_l in H; try omega.
Qed.

Lemma store_init_datas_bytes:
  forall il m p m' n,
  store_init_datas m p il = Some m' ->
  (p + n = Z_of_nat (length m))%Z ->
  (Genv.init_data_list_size il <= n)%Z ->
  loadbytes m p n = Some (list_repeat (nat_of_Z n) (Byte Byte.zero)) ->
  loadbytes_store_init_data m' p il.
Proof.
  induction il; simpl.
  auto.
  intros until m'. caseEq (store_init_data m p a); try congruence.
  intros m1 B n C C1 C2 C3.
  generalize B (Genv.init_data_size_pos a) (Genv.init_data_list_size_pos il); intros.
  apply store_init_data_length in B0.

  assert(A2: (Genv.init_data_list_size il = 0 \/ Genv.init_data_list_size il > 0)%Z).
    omega.
  destruct A2 as [A2 | A2].
  +destruct a; simpl in B; intuition; try congruence;
   try apply init_data_list_size_zero_loadbytes_store; auto.
   -change 1%Z with (size_chunk Mint8unsigned).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 2%Z with (size_chunk Mint16unsigned).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 4%Z with (size_chunk Mint32).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 4%Z with (size_chunk Mfloat32).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 8%Z with (size_chunk Mfloat64).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -inv B. simpl in *.
    destruct (zle _ _); auto.
    apply init_data_list_size_zero_loadbytes_store; auto.
    split; auto.
    erewrite store_init_datas_outside_bytes; eauto.
    eapply loadbytes_list_repeat_incl; eauto.
    omega. rewrite Z.max_l; omega. omega.
    apply init_data_list_size_zero_loadbytes_store; auto.
  +exploit (IHil m1 (p+Genv.init_data_size a)%Z m' (n-Genv.init_data_size a)%Z); eauto.
   rewrite B0. rewrite <-C1. omega. omega.
   erewrite store_init_data_outside_bytes; eauto.

   eapply loadbytes_list_repeat_incl; eauto. omega.
   omega. omega.
   intro D.
   destruct a; simpl in B; intuition; try congruence.
   -change 1%Z with (size_chunk Mint8unsigned).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 2%Z with (size_chunk Mint16unsigned).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 4%Z with (size_chunk Mint32).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 4%Z with (size_chunk Mfloat32).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -change 8%Z with (size_chunk Mfloat64).
    erewrite store_init_datas_loadbytes_app; eauto. auto.
   -inv B. simpl in *.
    destruct (zle _ _); auto. split; auto.
    erewrite store_init_datas_outside_bytes; eauto.
    eapply loadbytes_list_repeat_incl; eauto.
    split; try omega. rewrite Z.max_l; try omega.
    left. omega.
Qed.

Function store_zeros (m: mvl)(n: Z){wf (Zwf 0) n}: option mvl :=
  if zle n 0 then Some m else
    let n' := (n - 1)%Z in
    match store Mint8unsigned m n' Vzero with
    | Some m' => store_zeros m' n'
    | None => None
    end.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Definition alloc_global(gc:locenv)(idl: (ident * globvar type)): option locenv :=
  match idl with
  | (id, (mkglobvar ty init _ _)) =>
    let sz := Genv.init_data_list_size init in
    match store_zeros (alloc sz) sz with
    | None => None
    | Some m1 =>
      match store_init_datas m1 0 init with
      | None => None
      | Some m2 => Some (PTree.set id (m2,ty) gc)
      end
    end
  end.

Fixpoint alloc_globals(gc: locenv)(gl: list (ident * globvar type)): option locenv :=
  match gl with
  | nil => Some gc
  | idl :: gl' =>
      match alloc_global gc idl with
      | None => None
      | Some gc' => alloc_globals gc' gl'
      end
  end.

Definition init_genvc(gl: list (ident * globvar type)): option locenv :=
  alloc_globals empty_locenv gl.

Lemma store_zeros_zero:
  forall m n, (n = 0)%Z ->
  store_zeros m n = Some m.
Proof.
  intros m n.
  functional induction (store_zeros m n); intros; auto.
  subst. omega.
  subst. omega.
Qed.

Lemma store_zeros_length:
  forall m n m',
  store_zeros m n = Some m' ->
  length m' = length m.
Proof.
  intros until n.
  functional induction (store_zeros m n); intros.
  +inv H. auto.
  +rewrite IHo; auto; try omega.
   eapply store_length in e0; eauto.
  +congruence.
Qed.

Lemma store_zeros_exists:
  forall m n, (n <= Z_of_nat (length m) <= Int.max_signed)%Z ->
  exists m', store_zeros m n = Some m'.
Proof.
  intros until n.
  functional induction (store_zeros m n); intros.
  +exists m; auto.
  +apply IHo; try omega.
   apply store_length in e0; auto. omega.
  +unfold store in *.
   destruct (valid_access_dec _ _ _); try congruence.
   unfold valid_access in *. simpl in *.
   assert(A: False).
     apply n0. split.
     red. split; try omega.
     red. exists (n-1)%Z. omega.
   tauto.
Qed.

Lemma encode_int_inj_bytes_zero:
  inj_bytes (encode_int 1 (Int.unsigned Int.zero)) = Byte Byte.zero :: nil.
Proof.
  rewrite Int.unsigned_zero. unfold setN, replace_map.
  unfold encode_int. simpl. unfold rev_if_be.
  destruct Archi.big_endian; simpl; auto.
Qed.

Lemma store_zero_outside:
  forall m n m',
  store Mint8unsigned m n Vzero = Some m' ->
  skipn (Z.to_nat (n+1)) m' = skipn (Z.to_nat (n+1)) m.
Proof.
  unfold store. intros.
  destruct (valid_access_dec _ _ _); inv H.
  rewrite encode_int_inj_bytes_zero.
  destruct v. red in H. simpl in *.
  unfold setN, replace_map.
  cut(nat_of_Z n <= length m). intros.
  rewrite skipn_length_app; rewrite firstn_length;
  rewrite min_l; try omega.
  rewrite <-Z2Nat.inj_sub; try omega.
  replace (n + 1 - n)%Z with 1%Z by omega.
  simpl. rewrite Z2Nat.inj_add; try omega. auto.
  apply Z2Nat.inj_le; try omega.
  apply Nat2Z.inj_le; try omega.
  rewrite nat_of_Z_eq; omega.
Qed.

Lemma store_zeros_outside:
  forall m n m',
  store_zeros m n = Some m' ->
  skipn (nat_of_Z n) m' = skipn (nat_of_Z n) m.
Proof.
  intros until n.
  functional induction (store_zeros m n); intros.
  +inv H. auto.
  +replace n with (n-1+1)%Z by omega.
   rewrite Z2Nat.inj_add; try omega.
   repeat rewrite skipn_add.
   rewrite IHo; auto.
   repeat rewrite <-skipn_add.
   repeat rewrite <-Z2Nat.inj_add; try omega.
   apply store_zero_outside; auto.
  +congruence.
Qed.

Lemma store_zeros_content:
  forall m z m',
  store_zeros m z = Some m' ->
  (0 < z)%Z ->
  loadbytes m' 0 z = Some (list_repeat (nat_of_Z z) (Byte Byte.zero)).
Proof.
  intros until z.
  functional induction (store_zeros m z); intros.
  +omega.
  +assert (n=1 \/ 1 < n)%Z.
    omega.
   destruct H1.
   -generalize e0. intros A.
    apply store_length in A.
    subst. simpl in *. unfold store in e0.
    destruct (valid_access_dec _ _ _); inv e0.
    destruct v. unfold loadbytes.
    rewrite pred_dec_true; auto.
    rewrite store_zeros_zero in H; auto. inv H.
    rewrite encode_int_inj_bytes_zero.
    unfold setN, replace_map. simpl.
    destruct m; auto.
    red. apply store_zeros_length in H; auto.
    rewrite H, <-A; auto.
   -generalize H e0. intros.
    apply store_length in e1.
    apply IHo in H; try omega.
    rewrite <-firstn_skipn with (l:=m'0) (n:=nat_of_Z (n-1)) in H.
    rewrite <-firstn_skipn with (l:=m'0) (n:=nat_of_Z (n-1)).
    assert (A: (n-1 = Z_of_nat (length (firstn (nat_of_Z (n - 1)) m'0)))%Z).
      rewrite firstn_length. erewrite store_zeros_length; eauto.
      erewrite <-store_length; eauto.
      apply store_valid_access in e0. destruct e0.
      red in H3. simpl in *. rewrite min_l; try omega.
      rewrite nat_of_Z_eq; try omega.
      apply Nat2Z.inj_le. rewrite nat_of_Z_eq; try omega.
    rewrite A in H at 3.
    apply loadbytes_first in H.
    rewrite H.
    erewrite store_zeros_outside; eauto.
    unfold store in e0. destruct (valid_access_dec _ _ _); try congruence.
    inversion e0. destruct v. red in H3. simpl in H3.
    rewrite encode_int_inj_bytes_zero in *.
    unfold setN. unfold replace_map in *.
    rewrite skipn_length_app.
    rewrite A at 2. rewrite nat_of_Z_of_nat.
    repeat rewrite firstn_length. rewrite e1.
    erewrite store_zeros_length; eauto.
    rewrite minus_diag. simpl.
    change (Byte Byte.zero :: skipn (nat_of_Z (n - 1) + 1) m)
      with ((Byte Byte.zero :: nil) ++ skipn (nat_of_Z (n - 1) + 1) m).
    change (Byte Byte.zero :: nil) with (list_repeat 1 (Byte Byte.zero)).
    rewrite <-app_ass. rewrite <-list_repeat_app.
    change 1%nat with (nat_of_Z 1).
    rewrite <-Z2Nat.inj_add; try omega.
    replace (n - 1 + 1)%Z with n in * by omega.
    unfold loadbytes. rewrite pred_dec_true.
    simpl. unfold getN, getn. simpl.
    rewrite firstn_length_app1.
    rewrite firstn_list_repeat; auto.
    rewrite length_list_repeat; auto.
    red. rewrite app_length. rewrite length_list_repeat.
    cut (Z.to_nat n <= length m). intros.
    rewrite skipn_length. rewrite min_l; auto.
    replace (Z.to_nat n + (length m - Z.to_nat n)) with (length m); omega.
    apply Nat2Z.inj_le. rewrite nat_of_Z_eq; try omega.
    rewrite firstn_length. rewrite min_l; try omega.
    apply Nat2Z.inj_le. rewrite nat_of_Z_eq; try omega.
  +congruence.
Qed.

Lemma alloc_globals_app:
  forall l1 l2 gc gc1 gc2,
  alloc_globals gc l1 = Some gc1 ->
  alloc_globals gc1 l2 = Some gc2 ->
  alloc_globals gc (l1++l2) = Some gc2.
Proof.
  induction l1; simpl; intros.
  congruence.
  destruct (alloc_global gc a) eqn:?; try congruence.
  eapply IHl1; eauto.
Qed.

Lemma alloc_globals_notin_eq:
  forall id l gc gc',
  alloc_globals gc l = Some gc'->
  ~ In id (List.map (@fst ident (globvar type)) l) ->
  gc' ! id =gc ! id.
Proof.
  induction l; simpl; intros.
  +inv H. auto.
  +remember (alloc_global gc a).
   destruct o; try congruence.
   rewrite IHl with l0 gc'; eauto.
   unfold alloc_global in Heqo. destruct a.
   destruct g. destruct (store_zeros _ _) eqn:?; try congruence.
   destruct (store_init_datas _ _ _) eqn:?; inv Heqo.
   rewrite PTree.gso; auto.
Qed.

Lemma init_genvc_notin_none:
  forall id l gc,
  init_genvc l = Some gc ->
  ~ In id (List.map (@fst ident (globvar type)) l) ->
  gc ! id = None.
Proof.
  unfold init_genvc. intros.
  erewrite alloc_globals_notin_eq; eauto.
  rewrite PTree.gempty; auto.
Qed.

Lemma alloc_globals_init_datas_types:
  forall l gc gc',
  alloc_globals gc l = Some gc'->
  (forall a, In a l -> init_data_types (gvar_init (snd a))).
Proof.
  induction l; simpl; intros.
  tauto.
  destruct (alloc_global _ _) eqn:?; try congruence.
  destruct H0; subst; eauto.
  destruct a0; simpl in *. destruct g.
  destruct (store_zeros _ _); try congruence.
  destruct (store_init_datas _ _ _) eqn:?; try congruence.
  simpl. eapply store_init_datas_types; eauto.
Qed.

Inductive load_argv(ty: type)(m: mvl)(ofs: int): val -> Prop :=
  | load_argv_value: forall chunk v,
      access_mode ty = By_value chunk ->
      loadbytes m (Int.unsigned ofs) (sizeof ty) = Some (encode_val chunk v) ->
      load_argv ty m ofs v
  | load_argv_copy: forall m1,
      access_mode ty = By_copy \/ access_mode ty = By_reference ->
      loadbytes m (Int.unsigned ofs) (sizeof ty) = Some m1 ->
      (alignof ty | Int.unsigned ofs) ->
      load_argv ty m ofs (Vmvl m1).

Inductive load_mvl(ty: type)(m: mvl)(ofs: int): val -> Prop :=
  | load_mvl_value: forall chunk v,
      access_mode ty = By_value chunk ->
      load chunk m (Int.unsigned ofs) = Some v ->
      load_mvl ty m ofs v
  | load_mvl_copy: forall m1,
      access_mode ty = By_copy \/ access_mode ty = By_reference ->
      loadbytes m (Int.unsigned ofs) (sizeof ty) = Some m1 ->
      (alignof ty | Int.unsigned ofs) ->
      load_mvl ty m ofs (Vmvl m1).

Inductive vargs_match(m: mvl)(delta: Z): list (ident*type) -> list val -> Prop :=
  | vargs_match_nil:
      vargs_match m delta nil nil
  | vargs_match_cons: forall id ty al v vl,
      load_argv ty m (Int.repr (align delta (alignof ty))) v ->
      vargs_match m (align delta (alignof ty) + sizeof ty) al vl ->
      vargs_match m delta ((id,ty)::al) (v::vl).

CoInductive vargs_matchss_rec(al: list (ident*type))(vass: Stream (list val)) (mass: Stream (list mvl)) : Prop :=
    vargs_matchss_rec_ : forall m,
      vargs_match m 0 al (Streams.hd vass) ->
      Streams.hd mass = m :: nil ->
      mvl_type true m (Tstruct xH (fieldlist_of al)) ->
      vargs_matchss_rec al (Streams.tl vass) (Streams.tl mass) ->
      vargs_matchss_rec al vass mass.

CoInductive vargs_matchss_nil_rec(vass: Stream (list val)) (mass: Stream (list mvl)) : Prop :=
    vargs_matchss_nil_rec_ :
      Streams.hd mass = nil ->
      Streams.hd vass = nil ->
      vargs_matchss_nil_rec (Streams.tl vass) (Streams.tl mass) ->
      vargs_matchss_nil_rec vass mass.

Inductive vargs_matchss(al: list (ident*type))(vass: Stream (list val)) (mass: Stream (list mvl)) : Prop :=
  | vargs_matchss_cons :
      0 < length al ->
      vargs_matchss_rec al vass mass ->
      vargs_matchss al vass mass
  | vargs_matchss_nil:
      al = nil ->
      vargs_matchss_nil_rec vass mass ->
      vargs_matchss al vass mass.

Inductive vrets_match(m: mvl)(delta: Z): list (ident*type) -> list val -> Prop :=
  | vrets_match_nil:
      vrets_match m delta nil nil
  | vrets_match_cons: forall id ty al v vl,
      load_mvl ty m (Int.repr (align delta (alignof ty))) v ->
      vrets_match m (align delta (alignof ty) + sizeof ty) al vl ->
      vrets_match m delta ((id,ty)::al) (v::vl).

CoInductive vrets_matchss_rec(al: list (ident*type))(vrss: Stream (list val)) (mrss: Stream (list mvl)) : Prop :=
    vrets_matchss_ : forall m,
      vrets_match m 0 al (Streams.hd vrss) ->
      Streams.hd mrss = m :: nil ->
      vrets_matchss_rec al (Streams.tl vrss) (Streams.tl mrss) ->
      vrets_matchss_rec al vrss mrss.

Inductive vrets_matchss(al: list (ident*type))(vrss: Stream (list val)) (mrss: Stream (list mvl)) : Prop :=
  | vrets_matchss_cons :
      0 < length al ->
      vrets_matchss_rec al vrss mrss ->
      vrets_matchss al vrss mrss
  | vrets_matchss_nil:
      al = nil ->
      vrets_matchss al vrss mrss.

Variable S: Type.

Variable p: general_program (general_node S).
Variable gc: locenv.

Variable alloc_node: general_program (general_node S) -> env -> ident*general_node S -> Prop.

Inductive initial_state(main: ident*general_node S): env -> Prop :=
  | initial_state_node: forall e,
      init_genvc (const_block p) = Some gc ->
      find_funct (node_block p) p.(node_main) = Some main ->
      alloc_node p e main ->
      initial_state main e.

Definition arg_prop(a: ident*type): Prop :=
  (0 < sizeof (snd a) <= Int.max_signed)%Z
    /\ is_arystr (snd a) = true.

Definition args_prop(l: list (ident*type)): Prop :=
  Forall arg_prop l /\ length l <= 1.

Inductive initial_state1(main: ident*general_node S): env -> Prop :=
  | initial_state1_node: forall e,
      init_genvc (const_block p) = Some gc ->
      find_funct (node_block p) p.(node_main) = Some main ->
      args_prop (nd_args (snd main)) ->
      alloc_node p e main ->
      initial_state1 main e.

Variable eval_node: general_program (general_node S) -> locenv -> env -> env -> ident*general_node S -> list val -> list val -> Prop.

Inductive exec_prog(main: ident*general_node S)(e: env)(n maxn: nat)(vass vrss: Stream (list val)) : Prop :=
  | exec_prog_term: forall mrss,
      n > maxn ->
      vrets_matchss (nd_rets (snd main)) vrss mrss ->
      exec_prog main e n maxn vass vrss
  | exec_prog_cons: forall e',
      n <= maxn ->
      eval_node p gc e e' main (hd vass) (hd vrss) ->
      exec_prog main e' (n+1) maxn (tl vass) (tl vrss) ->
      exec_prog main e n maxn vass vrss.

Inductive exec_prog1(main: ident*general_node S)(e: env)(n maxn: nat)(mass: Stream (list mvl))(vrss: Stream (list val)) : Prop :=
  | exec_prog1_term: forall mrss,
      n > maxn ->
      vrets_matchss (nd_rets (snd main)) vrss mrss ->
      exec_prog1 main e n maxn mass vrss
  | exec_prog1_cons: forall e',
      n <= maxn ->
      has_types (List.map Vmvl (Streams.hd mass)) (List.map snd (nd_args (snd main))) ->
      eval_node p gc e e' main (List.map Vmvl (Streams.hd mass)) (hd vrss) ->
      exec_prog1 main e' (n+1) maxn (tl mass) (tl vrss) ->
      exec_prog1 main e n maxn mass vrss.

End GLOBAL_ENV.


Require Import SpecCert.x86.Architecture.MemoryController.MemoryController_rec.

Definition smramc_is_locked
           (mc :MemoryController) :=
  smramc_is_ro (smramc mc).

Definition smramc_is_unlocked
           (mc :MemoryController) :=
  smramc_is_rw (smramc mc).

Definition can_access_smram
           (mc     :MemoryController)
           (smiact :bool) :=
  smiact = true
  \/ d_open (smramc mc) = true.


Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export maps_def.
Require Export assettheory_def.
Require Export formulatheory_def.
Require Export featuremodelsemantics_def.
Require Export assettheory_int.
Require Export assettheory_inst.
Require Export assetmapping_def.
Require Export assetmapping_int.
Import AssetMapping.
Import FormulaTheory.
Import Maps.
Import AssetTheory.
Import FeatureModelSemantics.

Program Instance AssetMapping_Int : AssetMapping AssetName Asset map_ :=
{
   aMR := aMR_func;

}. Next Obligation.
{ (*assetMappingRefinement*)
  (* generalize H, H1, H0. apply assetMappingRefinement_axiom. *)
  assert (H3: aMR_func x x /\ aMR_func x y).
 split.
 + apply H.
 + apply H1.
 + generalize H3, H0. apply assetMappingRefinement_axiom.

} Qed.
  Next Obligation.
{ (*amRefCompositional*)
  induction am2.
  - induction am1.
    + induction aSet.
      { intros. destruct H2. intuition. }
      { intros. destruct H2. intuition. }
    + induction aSet.
      { intros. destruct H2. intuition. }
      { intros. destruct H2. intuition. }
  - induction am1.
    + induction aSet.
      { intros.
         destruct H2. intuition. }
      { intuition. }
    + induction aSet.
      { intuition. }
      { intuition. }

} Qed.


From Coq Require Import Lists.List.
From Coq Require Import Strings.Ascii.
From Coq Require Import Nat Psatz.
Import ListNotations.

Open Scope char_scope.

Definition input_stacks : list (list ascii) :=
  [
    ["J";"F";"C";"N";"D";"B";"W"];
    ["T";"S";"L";"Q";"V";"Z";"P"];
    ["T";"J";"G";"B";"Z";"P"];
    ["C";"H";"B";"Z";"J";"L";"T";"D"];
    ["S";"J";"B";"V";"G"];
    ["Q";"S";"P"];
    ["N";"P";"M";"L";"F";"D";"V";"B"];
    ["R";"L";"D";"B";"F";"M";"S";"P"];
    ["R";"T";"D";"V"]
  ]
.

Definition test_stacks : list (list ascii) :=
  [
    ["N";"Z"];
    ["D";"C";"M"];
    ["P"]
  ]
.

Definition input_moves : list (nat * nat * nat) := [
  (4,9,6);
  (7,2,5);
  (3,5,2);
  (2,2,1);
  (2,8,4);
  (1,6,9);
  (1,9,4);
  (7,1,2);
  (5,2,3);
  (5,7,4);
  (5,6,3);
  (1,7,6);
  (2,6,9);
  (3,2,4);
  (4,5,6);
  (2,7,3);
  (2,9,3);
  (1,5,2);
  (11,4,3);
  (1,2,9);
  (1,9,3);
  (2,1,6);
  (5,8,5);
  (7,5,4);
  (2,5,6);
  (6,6,4);
  (17,3,4);
  (1,8,3);
  (11,4,7);
  (1,6,4);
  (3,4,2);
  (2,2,6);
  (8,3,1);
  (8,3,9);
  (3,9,6);
  (3,1,3);
  (11,7,5);
  (1,6,4);
  (4,9,6);
  (3,1,4);
  (1,2,3);
  (1,6,9);
  (24,4,9);
  (2,6,5);
  (1,1,2);
  (1,1,3);
  (12,9,6);
  (5,4,2);
  (4,2,3);
  (5,6,3);
  (13,6,7);
  (1,5,6);
  (9,5,3);
  (4,7,5);
  (1,6,1);
  (3,5,1);
  (14,9,4);
  (2,7,9);
  (13,4,9);
  (1,4,7);
  (4,7,9);
  (3,5,1);
  (8,3,9);
  (4,1,4);
  (8,3,7);
  (3,7,6);
  (4,4,2);
  (3,1,9);
  (6,2,6);
  (3,3,1);
  (7,9,7);
  (2,6,5);
  (1,5,3);
  (3,7,5);
  (5,7,4);
  (2,1,4);
  (5,5,9);
  (6,4,1);
  (6,7,8);
  (22,9,3);
  (7,1,8);
  (4,9,6);
  (1,4,5);
  (8,6,4);
  (7,8,1);
  (1,6,4);
  (1,9,4);
  (1,1,2);
  (1,2,5);
  (1,9,8);
  (11,3,7);
  (1,6,2);
  (2,1,5);
  (1,8,2);
  (1,7,8);
  (4,5,7);
  (1,6,9);
  (6,3,1);
  (6,3,1);
  (15,7,5);
  (1,3,1);
  (1,3,6);
  (1,6,8);
  (14,5,1);
  (16,1,3);
  (2,8,9);
  (1,7,4);
  (3,9,8);
  (3,8,7);
  (2,3,5);
  (1,7,1);
  (6,8,5);
  (2,2,9);
  (1,7,2);
  (2,9,2);
  (5,4,7);
  (3,2,7);
  (14,1,5);
  (2,4,7);
  (8,7,6);
  (1,1,5);
  (1,7,4);
  (1,7,5);
  (1,1,8);
  (12,3,4);
  (1,8,7);
  (3,4,1);
  (1,6,2);
  (8,5,2);
  (1,7,6);
  (1,1,7);
  (6,6,2);
  (1,1,2);
  (14,5,7);
  (1,6,4);
  (4,4,7);
  (1,1,6);
  (1,5,6);
  (2,3,1);
  (14,7,5);
  (10,4,7);
  (1,1,9);
  (1,5,9);
  (11,5,1);
  (6,7,6);
  (1,4,6);
  (1,3,7);
  (2,1,5);
  (13,2,1);
  (10,6,7);
  (4,5,2);
  (1,9,1);
  (1,3,6);
  (2,5,2);
  (1,9,3);
  (1,3,1);
  (21,7,5);
  (1,6,4);
  (4,5,1);
  (1,4,1);
  (6,2,3);
  (1,3,6);
  (1,3,8);
  (1,8,7);
  (1,7,3);
  (9,5,3);
  (24,1,4);
  (1,3,7);
  (11,3,8);
  (1,7,3);
  (1,2,4);
  (2,2,1);
  (2,3,5);
  (1,6,5);
  (10,4,6);
  (2,6,4);
  (5,1,2);
  (1,6,7);
  (8,8,6);
  (4,2,7);
  (8,6,7);
  (1,2,8);
  (1,8,3);
  (1,7,4);
  (3,4,1);
  (2,6,7);
  (4,1,9);
  (3,6,7);
  (10,7,4);
  (2,3,9);
  (2,6,9);
  (2,1,8);
  (2,9,5);
  (4,5,6);
  (3,8,1);
  (4,4,8);
  (5,8,4);
  (1,8,2);
  (5,5,9);
  (1,6,1);
  (2,1,7);
  (22,4,8);
  (4,8,7);
  (2,6,7);
  (1,2,6);
  (16,8,9);
  (3,7,4);
  (1,5,9);
  (2,6,7);
  (1,8,2);
  (1,2,3);
  (24,9,3);
  (1,1,7);
  (3,5,1);
  (4,4,6);
  (15,3,6);
  (18,6,2);
  (3,3,2);
  (4,1,6);
  (4,7,3);
  (1,3,9);
  (4,2,1);
  (1,8,7);
  (3,9,6);
  (1,9,3);
  (4,7,3);
  (2,4,2);
  (1,1,2);
  (7,3,5);
  (8,6,1);
  (1,9,2);
  (3,7,5);
  (1,4,8);
  (3,1,7);
  (5,7,6);
  (3,5,2);
  (3,7,3);
  (5,5,9);
  (5,3,6);
  (1,8,3);
  (5,9,7);
  (7,2,4);
  (11,2,7);
  (7,1,6);
  (1,1,9);
  (5,3,6);
  (5,2,1);
  (1,3,9);
  (1,3,7);
  (6,6,2);
  (10,6,7);
  (5,6,7);
  (28,7,8);
  (2,9,1);
  (1,6,3);
  (4,7,5);
  (1,3,6);
  (7,2,7);
  (6,7,3);
  (1,5,9);
  (1,6,2);
  (1,7,3);
  (1,9,1);
  (4,5,2);
  (5,3,5);
  (2,2,8);
  (4,4,7);
  (1,4,7);
  (2,3,6);
  (5,7,1);
  (2,5,8);
  (2,5,8);
  (2,5,3);
  (2,3,1);
  (2,6,7);
  (31,8,3);
  (2,8,5);
  (2,7,4);
  (7,1,4);
  (2,5,1);
  (3,2,8);
  (2,4,6);
  (3,1,2);
  (6,4,8);
  (1,1,8);
  (1,6,5);
  (11,8,9);
  (1,6,8);
  (1,4,1);
  (1,8,7);
  (1,5,8);
  (3,2,1);
  (2,4,3);
  (1,8,1);
  (7,3,6);
  (12,3,2);
  (1,7,9);
  (4,6,1);
  (1,6,3);
  (12,9,3);
  (1,6,4);
  (1,1,7);
  (1,4,1);
  (1,7,2);
  (1,6,5);
  (1,5,6);
  (5,3,1);
  (1,6,4);
  (7,2,1);
  (3,2,6);
  (1,4,5);
  (3,3,2);
  (4,2,8);
  (1,6,4);
  (1,4,9);
  (1,5,1);
  (11,1,5);
  (10,1,8);
  (2,6,4);
  (1,2,9);
  (1,2,4);
  (18,3,5);
  (4,1,4);
  (3,1,2);
  (14,8,5);
  (2,2,6);
  (1,3,2);
  (2,2,7);
  (3,4,1);
  (2,4,3);
  (2,3,4);
  (2,6,9);
  (1,7,1);
  (3,1,4);
  (4,9,7);
  (31,5,2);
  (25,2,4);
  (13,4,2);
  (10,2,3);
  (2,5,7);
  (5,2,9);
  (7,5,7);
  (5,7,4);
  (1,5,8);
  (2,7,3);
  (11,4,8);
  (1,7,3);
  (1,1,4);
  (2,5,3);
  (3,2,9);
  (8,9,6);
  (10,8,2);
  (5,3,2);
  (1,7,3);
  (3,7,3);
  (15,2,1);
  (11,1,3);
  (1,8,2);
  (8,6,5);
  (1,2,6);
  (1,6,1);
  (12,3,7);
  (1,2,9);
  (2,4,1);
  (3,1,8);
  (1,8,7);
  (3,3,4);
  (1,4,7);
  (15,7,9);
  (1,7,5);
  (4,1,8);
  (6,8,6);
  (1,6,2);
  (5,5,1);
  (2,6,8);
  (1,2,7);
  (1,8,2);
  (1,7,1);
  (1,5,8);
  (6,3,1);
  (4,3,8);
  (7,8,5);
  (1,2,4);
  (2,4,2);
  (3,6,4);
  (5,9,3);
  (4,1,4);
  (10,5,9);
  (8,1,7);
  (1,2,1);
  (1,1,9);
  (20,9,2);
  (12,2,3);
  (17,4,3);
  (6,7,2);
  (5,3,8);
  (20,3,5);
  (2,9,4);
  (3,3,1);
  (1,7,1);
  (6,3,6);
  (4,2,3);
  (4,5,3);
  (1,1,9);
  (6,6,1);
  (3,8,4);
  (1,9,8);
  (2,2,1);
  (3,3,2);
  (1,3,6);
  (1,7,4);
  (3,3,6);
  (6,1,5);
  (9,2,4);
  (3,2,5);
  (2,6,5);
  (16,4,8);
  (18,8,6);
  (1,4,5);
  (2,6,7);
  (4,1,7);
  (22,5,6);
  (1,4,9);
  (4,7,6);
  (11,6,5);
  (9,5,2);
  (2,2,3);
  (2,7,2);
  (1,1,7);
  (9,6,2);
  (1,5,1);
  (1,8,9);
  (18,6,8);
  (1,7,4);
  (4,5,1);
  (2,5,2);
  (2,2,5);
  (1,9,5);
  (1,5,9);
  (1,9,1);
  (1,9,2);
  (1,4,8);
  (4,1,4);
  (2,6,5);
  (1,1,9);
  (3,6,7);
  (1,6,9);
  (1,9,8);
  (2,5,9);
  (3,3,5);
  (7,2,3);
  (1,1,3);
  (2,5,9);
  (1,5,7);
  (10,8,3);
  (10,8,9);
  (3,4,3);
  (9,2,1);
  (4,9,6);
  (5,1,9);
  (2,5,9);
  (1,6,4);
  (4,7,2);
  (7,2,9);
  (3,6,8);
  (1,1,3);
  (2,8,5);
  (1,8,1);
  (18,3,6);
  (15,9,2);
  (8,9,1);
  (2,9,2);
  (2,4,9);
  (2,9,7);
  (12,6,3);
  (7,1,7);
  (12,2,5);
  (7,3,2);
  (4,3,4);
  (2,7,6);
  (7,7,8);
  (1,4,2);
  (4,1,8);
  (5,3,1);
  (9,8,3);
  (1,8,7);
  (2,1,2);
  (4,6,7);
  (11,2,5);
  (2,4,6);
  (1,8,2);
  (7,3,2);
  (1,2,4);
  (4,6,1);
  (7,5,8);
  (2,3,1);
  (7,2,3);
  (6,5,1);
  (1,4,2);
  (8,1,6);
  (3,2,9)
].

Definition test_moves : list (nat * nat * nat) := [
  (1,2,1);
  (3,1,3);
  (2,2,1);
  (1,1,2)
].

Fixpoint edit {A} (idx : nat) (f : A -> A) (l : list A) :=
  match idx, l with
  | _,nil => nil
  | 0, (x :: r) => f x :: r
  | S i, (x :: r) => x :: edit i f r
  end.

Fixpoint drop {A} (cnt : nat) (l : list A) :=
  match cnt,l with
  | 0,_ => l
  | _,nil => []
  | S i, (x :: r) => drop i r
  end.

Definition step1 (mov : nat * nat * nat) (state : list (list ascii)) :=
  let (movfst,to) := mov in
  let (cnt,from) := movfst in
  let movd := firstn cnt (nth (from-1) state []) in
  let rest := edit (from-1) (drop cnt) state in
  edit (to-1) (fun x => rev movd ++ x) rest.

Definition step2 (mov : nat * nat * nat) (state : list (list ascii)) :=
  let (movfst,to) := mov in
  let (cnt,from) := movfst in
  let movd := firstn cnt (nth (from-1) state []) in
  let rest := edit (from-1) (drop cnt) state in
  edit (to-1) (fun x => movd ++ x) rest.

Definition flip {A} {B} {C} (f : A -> B -> C) (b : B) (a : A) : C :=
  f a b.

Definition impl_1 (stacks : list (list ascii)) (moves : list (nat * nat * nat)) := map (hd "0") (fold_left (flip step1) moves stacks).

Definition impl_2 (stacks : list (list ascii)) (moves : list (nat * nat * nat)) := map (hd "0") (fold_left (flip step2) moves stacks).

Example test_works1 : impl_1 test_stacks test_moves = ["C";"M";"Z"].
Proof.
  vm_compute. reflexivity.
Qed.

Example test_works2 : impl_2 test_stacks test_moves = ["M";"C";"D"].
Proof.
  vm_compute. reflexivity.
Qed.

Compute (impl_1 input_stacks input_moves).
Compute (impl_2 input_stacks input_moves).

Close Scope char_scope.

Fixpoint lsum (l : list nat) : nat :=
  match l with
  | nil => 0
  | x :: r => x + lsum r
  end.

Lemma sum_0_all_0 (l : list nat) : lsum l = 0 <-> forall n, In n l -> n = 0.
Proof.
  split.
  - intros. induction n.
  -- auto.
  -- exfalso. induction l.
  --- inversion H0.
  --- simpl in *. apply Plus.plus_is_O in H. destruct H. destruct H0.
  ---- subst. inversion H0.
  ---- apply IHl;auto.
  - intros. induction l.
  -- reflexivity.
  -- simpl. apply PeanoNat.Nat.eq_add_0. split.
  --- apply H. left. auto.
  --- apply IHl. intros. apply H. right. auto.
Qed.

Lemma edit_nil {A} (idx : nat) (f : A -> A) : edit idx f [] = [].
Proof.
  destruct idx;auto.
Qed.

Lemma lsum_map {A} (f : A -> nat) (a : A) (l : list A) : lsum (map f (a :: l)) = f a + lsum (map f l).
Proof.
  reflexivity.
Qed.

Lemma double_edit {A} (f1 f2 : A -> A) (i : nat) (l : list A) : edit i f2 (edit i f1 l) = edit i (fun x => f2 (f1 x)) l.
Proof.
  generalize dependent i.
  induction l.
  - destruct i; reflexivity.
  - destruct i; auto. simpl. rewrite (IHl i). reflexivity.
Qed.

Lemma lsum_mod_inv (l : list nat) (i1 i2 d : nat) : length l > i1 /\ length l > i2 /\ nth i1 l 0 >= d -> lsum l = lsum (edit i2 (fun n => n + d) (edit i1 (fun n => n - d) l)).
Proof.
  intro H. destruct H as [Hin1 [Hin2 Hge]].
  destruct (i1 <=? i2) eqn:Hfstle.
  - apply PeanoNat.Nat.leb_le in Hfstle. destruct (i1 =? i2) eqn:Hfsteq.
  -- apply PeanoNat.Nat.eqb_eq in Hfsteq. clear Hfstle. subst. rewrite double_edit. generalize dependent i2. induction l.
  --- simpl. destruct i2; auto.
  --- simpl. destruct i2; auto.
  ---- simpl. intros. rewrite PeanoNat.Nat.sub_add; auto.
  ---- simpl. intros. rewrite (IHl i2);auto; lia.
  -- rewrite PeanoNat.Nat.eqb_neq in Hfsteq. assert (i1 < i2). { lia. } clear Hfstle. clear Hfsteq. generalize dependent i2. induction i1.
  --- intros. destruct l.
  ---- simpl. rewrite edit_nil. reflexivity.
  ---- simpl. destruct i2. { lia. } clear H. simpl. generalize dependent i2. induction l.
  ----- intros. simpl in Hin2. lia.
  ----- intros. simpl in *. clear Hin1. destruct i2.
  ------ simpl. lia.
  ------ simpl. assert (S (length l) > 0). { lia. }
         assert (S (length l) > S i2). { lia. }
         pose (IHl H Hge i2 H0). lia.
  ---
Qed.

Theorem box_length_const (mov : nat * nat * nat) (state : list (list ascii)) : lsum (map (fun l => length l) state) = lsum (map (fun l => length l) (step1 mov state)).
Proof.
  destruct mov as [[cnt from] to].
Admitted.


From iris.proofmode Require Import proofmode.
From iris.algebra Require Import auth list.
From iris.program_logic Require Import adequacy.
From iris_examples.logrel.F_mu_ref_conc.binary.examples Require Export lock.
From iris_examples.logrel.F_mu_ref_conc.binary Require Import soundness.
From iris.prelude Require Import options.

Definition CG_increment (x : expr) : expr :=
  Lam (Store x.[ren (+ 1)] (BinOp Add (#n 1) (Load x.[ren (+ 1)]))).

Definition CG_locked_increment (x l : expr) : expr :=
  with_lock (CG_increment x) l.
Definition CG_locked_incrementV (x l : expr) : val :=
  with_lockV (CG_increment x) l.

Definition counter_read (x : expr) : expr := Lam (Load x.[ren (+1)]).
Definition counter_readV (x : expr) : val := LamV (Load x.[ren (+1)]).

Definition CG_counter_body (x l : expr) : expr :=
  Pair (CG_locked_increment x l) (counter_read x).
Definition CG_counter : expr :=
  LetIn newlock (LetIn (Alloc (#n 0)) (CG_counter_body (Var 0) (Var 1))).

Definition FG_increment (x : expr) : expr :=
  Rec (LetIn
         (Load x.[ren (+2)]) (* read the counter *)
         (* try increment *)
         (If (CAS x.[ren (+3)] (Var 0) (BinOp Add (#n 1) (Var 0)))
             Unit (* increment succeeds we return unit *)
             (App (Var 1) (Var 2)) (* increment fails, we try again *))).
Definition FG_counter_body (x : expr) : expr :=
  Pair (FG_increment x) (counter_read x).
Definition FG_counter : expr :=
  LetIn (Alloc (#n 0)) (FG_counter_body (Var 0)).

Section CG_Counter.
  Context `{heapIG Σ, cfgSG Σ}.

  Notation D := (persistent_predO (val * val) (iPropI Σ)).
  Implicit Types Δ : listO D.

  (* Coarse-grained increment *)
  Lemma CG_increment_type x Γ :
    typed Γ x (Tref TNat) →
    typed Γ (CG_increment x) (TArrow TUnit TUnit).
  Proof.
    intros H1. repeat econstructor.
    - eapply (context_weakening [_]); eauto.
    - eapply (context_weakening [_]); eauto.
  Qed.

  Lemma CG_increment_closed (x : expr) :
    (∀ f, x.[f] = x) → ∀ f, (CG_increment x).[f] = CG_increment x.
  Proof. intros Hx f. unfold CG_increment. asimpl. rewrite ?Hx; trivial. Qed.

  Hint Rewrite CG_increment_closed : autosubst.

  Lemma CG_increment_subst (x : expr) f :
    (CG_increment x).[f] = CG_increment x.[f].
  Proof. unfold CG_increment; asimpl; trivial. Qed.

  Hint Rewrite CG_increment_subst : autosubst.

  Lemma steps_CG_increment E j K x n:
    nclose specN ⊆ E →
    spec_ctx ∗ x ↦ₛ (#nv n) ∗ j ⤇ fill K (App (CG_increment (Loc x)) Unit)
      ⊢ |={E}=> j ⤇ fill K (Unit) ∗ x ↦ₛ (#nv (S n)).
  Proof.
    iIntros (HNE) "[#Hspec [Hx Hj]]". unfold CG_increment.
    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
    iMod (step_load _ j ((BinOpRCtx _ (#nv _) :: StoreRCtx (LocV _) :: K))
                    _ _ _ with "[Hj Hx]") as "[Hj Hx]"; eauto.
    { iFrame "Hspec Hj"; trivial. }
    simpl.
    iMod (do_step_pure _ _ ((StoreRCtx (LocV _)) :: K)  with "[$Hj]") as "Hj";
      eauto.
    simpl.
    iMod (step_store _ j K with "[$Hj $Hx]") as "[Hj Hx]"; eauto.
    iModIntro; iFrame.
  Qed.

  Global Opaque CG_increment.

  Lemma CG_locked_increment_to_val x l :
    to_val (CG_locked_increment x l) = Some (CG_locked_incrementV x l).
  Proof. by rewrite with_lock_to_val. Qed.

  Lemma CG_locked_increment_of_val x l :
    of_val (CG_locked_incrementV x l) = CG_locked_increment x l.
  Proof. by rewrite with_lock_of_val. Qed.

  Global Opaque CG_locked_incrementV.

  Lemma CG_locked_increment_type x l Γ :
    typed Γ x (Tref TNat) →
    typed Γ l LockType →
    typed Γ (CG_locked_increment x l) (TArrow TUnit TUnit).
  Proof.
    intros H1 H2. repeat econstructor.
    eapply with_lock_type; auto using CG_increment_type.
  Qed.

  Lemma CG_locked_increment_subst (x l : expr) f :
  (CG_locked_increment x l).[f] = CG_locked_increment x.[f] l.[f].
  Proof.
    unfold CG_locked_increment. simpl.
    rewrite with_lock_subst CG_increment_subst. asimpl; trivial.
  Qed.

  Hint Rewrite CG_locked_increment_subst : autosubst.

  Lemma steps_CG_locked_increment E j K x n l :
    nclose specN ⊆ E →
    spec_ctx ∗ x ↦ₛ (#nv n) ∗ l ↦ₛ (#♭v false)
      ∗ j ⤇ fill K (App (CG_locked_increment (Loc x) (Loc l)) Unit)
    ={E}=∗ j ⤇ fill K Unit ∗ x ↦ₛ (#nv S n) ∗ l ↦ₛ (#♭v false).
  Proof.
    iIntros (HNE) "[#Hspec [Hx [Hl Hj]]]".
    iMod (steps_with_lock
            _ j K _ _ _ _ UnitV UnitV with "[$Hj Hx $Hl]") as "Hj"; eauto.
    - iIntros (K') "[#Hspec Hxj]".
      iApply steps_CG_increment; by try iFrame.
    - by iFrame.
  Qed.

  Global Opaque CG_locked_increment.

  Lemma counter_read_to_val x : to_val (counter_read x) = Some (counter_readV x).
  Proof. trivial. Qed.

  Lemma counter_read_of_val x : of_val (counter_readV x) = counter_read x.
  Proof. trivial. Qed.

  Global Opaque counter_readV.

  Lemma counter_read_type x Γ :
    typed Γ x (Tref TNat) → typed Γ (counter_read x) (TArrow TUnit TNat).
  Proof.
    intros H1. repeat econstructor.
    eapply (context_weakening [_]); trivial.
  Qed.

  Lemma counter_read_closed (x : expr) :
    (∀ f, x.[f] = x) → ∀ f, (counter_read x).[f] = counter_read x.
  Proof. intros H1 f. asimpl. unfold counter_read. by rewrite ?H1. Qed.

  Hint Rewrite counter_read_closed : autosubst.

  Lemma counter_read_subst (x: expr) f :
    (counter_read x).[f] = counter_read x.[f].
  Proof. unfold counter_read. by asimpl. Qed.

  Hint Rewrite counter_read_subst : autosubst.

  Lemma steps_counter_read E j K x n :
    nclose specN ⊆ E →
    spec_ctx ∗ x ↦ₛ (#nv n)
               ∗ j ⤇ fill K (App (counter_read (Loc x)) Unit)
    ={E}=∗ j ⤇ fill K (#n n) ∗ x ↦ₛ (#nv n).
  Proof.
    intros HNE. iIntros "[#Hspec [Hx Hj]]". unfold counter_read.
    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
    iAsimpl.
    iMod (step_load _ j K with "[$Hj Hx]") as "[Hj Hx]"; eauto.
    by iFrame.
  Qed.

  Local Opaque counter_read.

  Lemma CG_counter_body_type x l Γ :
    typed Γ x (Tref TNat) →
    typed Γ l LockType →
    typed Γ (CG_counter_body x l)
            (TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)).
  Proof.
    intros H1 H2; repeat econstructor;
      eauto using CG_locked_increment_type, counter_read_type.
  Qed.

  Lemma CG_counter_body_subst (x l : expr) f :
    (CG_counter_body x l).[f] = CG_counter_body x.[f] l.[f].
  Proof. by asimpl. Qed.

  Hint Rewrite CG_counter_body_subst : autosubst.

  Lemma CG_counter_type Γ :
    typed Γ CG_counter (TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)).
  Proof.
    econstructor; eauto using newlock_type.
    econstructor; first eauto using typed.
    apply CG_counter_body_type; eauto using typed.
  Qed.

  Lemma CG_counter_closed f : CG_counter.[f] = CG_counter.
  Proof. by asimpl. Qed.

  Hint Rewrite CG_counter_closed : autosubst.

  (* Fine-grained increment *)
  Lemma FG_increment_type x Γ :
    typed Γ x (Tref TNat) →
    typed Γ (FG_increment x) (TArrow TUnit TUnit).
  Proof.
    intros Hx. do 3 econstructor; eauto using typed.
    - eapply (context_weakening [_; _]); eauto.
    - econstructor; [| |repeat econstructor |].
      + constructor.
      + eapply (context_weakening [_; _; _]); eauto.
      + repeat constructor.
  Qed.

  Lemma FG_increment_subst (x : expr) f :
    (FG_increment x).[f] = FG_increment x.[f].
  Proof. rewrite /FG_increment. by asimpl. Qed.

  Hint Rewrite FG_increment_subst : autosubst.

  Lemma FG_counter_body_type x Γ :
    typed Γ x (Tref TNat) →
    typed Γ (FG_counter_body x)
            (TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)).
  Proof.
    intros H1; econstructor.
    - apply FG_increment_type; trivial.
    - apply counter_read_type; trivial.
  Qed.

  Lemma FG_counter_body_subst (x : expr) f :
    (FG_counter_body x).[f] = FG_counter_body x.[f].
  Proof. rewrite /FG_counter_body /FG_increment. by asimpl. Qed.

  Hint Rewrite FG_counter_body_subst : autosubst.

  Lemma FG_counter_type Γ :
    Γ ⊢ₜ FG_counter : (TProd (TArrow TUnit TUnit) (TArrow TUnit TNat)).
  Proof.
    econstructor; eauto using newlock_type, typed.
    apply FG_counter_body_type; by constructor.
  Qed.

  Lemma FG_counter_closed f : FG_counter.[f] = FG_counter.
  Proof. by asimpl. Qed.

  Hint Rewrite FG_counter_closed : autosubst.

  Definition counterN : namespace := nroot .@ "counter".

  Lemma FG_CG_counter_refinement :
    ⊢ [] ⊨ FG_counter ≤log≤ CG_counter : TProd (TArrow TUnit TUnit) (TArrow TUnit TNat).
  Proof.
    iIntros (Δ [|??]) "!# #(Hspec & HΓ)"; iIntros (j K) "Hj"; last first.
    { iDestruct (interp_env_length with "HΓ") as %[=]. }
    iClear "HΓ". cbn -[FG_counter CG_counter].
    rewrite ?empty_env_subst /CG_counter /FG_counter.
    iApply fupd_wp.
    iMod (steps_newlock _ j (LetInCtx _ :: K) with "[$Hj]")
      as (l) "[Hj Hl]"; eauto.
    simpl.
    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
    iAsimpl.
    iMod (step_alloc _ j (LetInCtx _ :: K) with "[$Hj]")
      as (cnt') "[Hj Hcnt']"; eauto.
    simpl.
    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
    iAsimpl.
    iApply (wp_bind (fill [LetInCtx _])).
    iApply wp_wand_l. iSplitR; [iModIntro; iIntros (v) "Hv"; iExact "Hv"|].
    iApply (wp_alloc); trivial; iFrame "#"; iModIntro; iNext; iIntros (cnt) "Hcnt /=".
    (* establishing the invariant *)
    iAssert ((∃ n, l ↦ₛ (#♭v false) ∗ cnt ↦ᵢ (#nv n) ∗ cnt' ↦ₛ (#nv n) )%I)
      with "[Hl Hcnt Hcnt']" as "Hinv".
    { iExists _. by iFrame. }
    iApply fupd_wp.
    iMod (inv_alloc counterN with "[Hinv]") as "#Hinv"; [iNext; iExact "Hinv"|].
    (* splitting increment and read *)
    iApply wp_pure_step_later; trivial. iModIntro. iNext. iAsimpl.
    iApply wp_value; auto.
    iExists (PairV (CG_locked_incrementV _ _) (counter_readV _)); simpl.
    rewrite CG_locked_increment_of_val counter_read_of_val.
    iFrame "Hj".
    iExists (_, _), (_, _); simpl; repeat iSplit; trivial.
    - (* refinement of increment *)
      iModIntro. clear j K. iIntros (v) "#Heq". iIntros (j K) "Hj".
      rewrite CG_locked_increment_of_val /=.
      destruct v; iDestruct "Heq" as "[% %]"; simplify_eq/=.
      iLöb as "Hlat".
      iApply wp_pure_step_later; trivial. iAsimpl. iNext.
      (* fine-grained reads the counter *)
      iApply (wp_bind (fill [LetInCtx _]));
        iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
      iApply wp_atomic; eauto.
      iInv counterN as (n) ">[Hl [Hcnt Hcnt']]" "Hclose".
      iApply (wp_load with "[Hcnt]"); [iNext; by iFrame|].
      iModIntro. iNext. iIntros "Hcnt".
      iMod ("Hclose" with "[Hl Hcnt Hcnt']").
      { iNext. iExists _. iFrame "Hl Hcnt Hcnt'". }
      iApply wp_pure_step_later; trivial. iAsimpl. iModIntro. iNext.
      (* fine-grained performs increment *)
      iApply (wp_bind (fill [CasRCtx (LocV _) (NatV _); IfCtx _ _]));
        iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
      iApply wp_pure_step_later; auto. iApply wp_value.
      iNext.
      iApply (wp_bind (fill [IfCtx _ _]));
        iApply wp_wand_l; iSplitR; [iIntros (v) "Hv"; iExact "Hv"|].
      iApply wp_atomic; eauto.
      iInv counterN as (n') ">[Hl [Hcnt Hcnt']]" "Hclose".
      (* performing CAS *)
      destruct (decide (n = n')) as [|Hneq]; subst.
      + (* CAS succeeds *)
        (* In this case, we perform increment in the coarse-grained one *)
        iMod (steps_CG_locked_increment
                _ _ _ _ _ _ _ with "[Hj Hl Hcnt']") as "[Hj [Hcnt' Hl]]".
        { iFrame "Hspec Hcnt' Hl Hj"; trivial. }
        iApply (wp_cas_suc with "[Hcnt]"); auto.
        iModIntro. iNext. iIntros "Hcnt".
        iMod ("Hclose" with "[Hl Hcnt Hcnt']").
        { iNext. iExists _. iFrame "Hl Hcnt Hcnt'"; trivial. }
        simpl.
        iApply wp_pure_step_later; trivial.
        iModIntro. iNext. iApply wp_value; trivial.
        iExists UnitV; iFrame; auto.
      + (* CAS fails *)
        (* In this case, we perform a recursive call *)
        iApply (wp_cas_fail _ _ _ (#nv n') with "[Hcnt]"); auto;
        [inversion 1; subst; auto | ].
        iModIntro. iNext. iIntros "Hcnt".
        iMod ("Hclose" with "[Hl Hcnt Hcnt']").
        { iNext. iExists _; iFrame "Hl Hcnt Hcnt'". }
        iApply wp_pure_step_later; trivial. iModIntro. iNext. by iApply "Hlat".
    - (* refinement of read *)
      iModIntro. clear j K. iIntros (v) "#Heq". iIntros (j K) "Hj".
      rewrite ?counter_read_of_val.
      iDestruct "Heq" as "[% %]"; destruct v; simplify_eq/=.
      Local Transparent counter_read. (* HACK *)
      unfold counter_read.
      iApply wp_pure_step_later; trivial. simpl.
      iNext.
      iApply wp_atomic; eauto.
      iInv counterN as (n) ">[Hl [Hcnt Hcnt']]" "Hclose".
      iMod (steps_counter_read with "[Hj Hcnt']") as "[Hj Hcnt']"; first by solve_ndisj.
      { by iFrame "Hspec Hcnt' Hj". }
      iApply (wp_load with "[Hcnt]"); eauto.
      iModIntro. iNext. iIntros "Hcnt".
      iMod ("Hclose" with "[Hl Hcnt Hcnt']").
      { iNext. iExists _; iFrame "Hl Hcnt Hcnt'". }
      iExists (#nv _); eauto.
      Unshelve. solve_ndisj.
  Qed.
End CG_Counter.

Theorem counter_ctx_refinement :
  [] ⊨ FG_counter ≤ctx≤ CG_counter :
         TProd (TArrow TUnit TUnit) (TArrow TUnit TNat).
Proof.
  set (Σ := #[invΣ ; gen_heapΣ loc val ; soundness_binaryΣ ]).
  set (HG := soundness.HeapPreIG Σ _ _).
  eapply (binary_soundness Σ _); auto using FG_counter_type, CG_counter_type.
  intros. apply FG_CG_counter_refinement.
Qed.


Require compcert.backend.Stackingproof.
Require SmallstepX.
Require EventsX.
Require MachX.
Require LinearX.

Import Coqlib.
Import Integers.
Import AST.
Import ValuesX.
Import MemoryX.
Import Globalenvs.
Import EventsX.
Import SmallstepX.
Import Locations.
Import LinearX.
Import Lineartyping.
Import MachX.
Import Stacking.
Export Stackingproof.

Section WITHCONFIG.
Context `{compiler_config: CompilerConfiguration}.

Variable prog: Linear.program.
Variable tprog: Mach.program.
Hypothesis TRANSF: transf_program prog = Errors.OK tprog.

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

Lemma genv_next_preserved:
  Genv.genv_next tge = Genv.genv_next ge.
Proof.
  eapply Genv.genv_next_transf_partial; eauto.
Qed.

Variables
  (init_mach_rs: Mach.regset)
  (init_sp: val)
  (init_m: mem)
.

Definition init_linear_rs: Locations.Locmap.t :=
    fun ros =>
      match ros with
        | R r => init_mach_rs r
        | S Outgoing ofs ty =>
          match load_stack init_m init_sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) with
            | Some v => v
            | None => Vundef
          end
        | _ => Vundef
      end.

Lemma extcall_args_eq:
  forall ll vl,
    list_forall2 (Mach.extcall_arg init_mach_rs init_m init_sp) ll vl
  -> vl = map init_linear_rs ll.
Proof.
  induction 1; simpl.
   reflexivity.
  f_equal; eauto.
  inv H.
   reflexivity.
  unfold init_linear_rs.
  rewrite H1.
  reflexivity.
Qed.

Lemma extcall_arg_init_linear_rs:
  forall la,
    list_forall2 (extcall_arg init_mach_rs init_m init_sp) la (map init_linear_rs la) ->
    forall l, In l la ->
    extcall_arg init_mach_rs init_m init_sp l (init_linear_rs l).
Proof.
  induction la; simpl; inversion 1; subst.
   tauto.
  destruct 1; subst; eauto.
Qed.

Variables
  (init_ra: val)
  (sg: signature)
  (args: list val)
  (Hargs: extcall_arguments init_mach_rs init_m init_sp sg args)
  (Hinject_neutral: Mem.inject_neutral (Mem.nextblock init_m) init_m)
  (Hgenv_next: Ple (Genv.genv_next tge) (Mem.nextblock init_m))
.

Hypothesis init_mach_rs_inj:
  forall r, val_inject (Mem.flat_inj (Mem.nextblock init_m)) (init_mach_rs r) (init_mach_rs r).

Lemma transf_initial_states:
  forall i,
  forall s
         (INIT: LinearX.initial_state init_linear_rs prog i sg args init_m s),
    exists s',
      MachX.initial_state init_mach_rs init_sp tprog i sg args init_m s' /\
      match_states prog tprog init_m init_linear_rs init_sp init_ra s s'.
Proof.
  inversion 1; subst.
  exploit function_ptr_translated; eauto.
  destruct 1 as [tf [Htf TRANS]].
  esplit.
  split.
  econstructor.
  erewrite symbols_preserved; eauto.
  assumption.
  econstructor.
  eapply Mem.neutral_inject. assumption.
  econstructor.
  eapply Ple_refl. apply Ple_refl.
  constructor.
  apply Ple_refl.
  unfold Mem.flat_inj. intros. destruct (plt b0 (Mem.nextblock init_m)); eauto. contradiction.
  unfold Mem.flat_inj. intros. destruct (plt b1 (Mem.nextblock init_m)); congruence.
  intros. exploit Genv.genv_symb_range; eauto. erewrite genv_next_preserved in Hgenv_next; eauto. unfold ge in *; xomega.
  intros. exploit Genv.genv_funs_range; eauto. erewrite genv_next_preserved in Hgenv_next; eauto. unfold ge in *; xomega.
  intros. exploit Genv.genv_vars_range; eauto. erewrite genv_next_preserved in Hgenv_next; eauto. unfold ge in *; xomega.
  intros. exploit extcall_arg_init_linear_rs; eauto. intro.
  inv H0.
  esplit. split. econstructor. eassumption.
  destruct init_sp; try discriminate.
  exploit Mem.loadv_inject.
   eapply Mem.neutral_inject. eassumption.
   eassumption.
   unfold Val.add. econstructor.
   unfold Mem.flat_inj. destruct (plt b0 (Mem.nextblock init_m)). reflexivity.
   destruct n.
   eapply Mem.valid_access_valid_block.
   eapply Mem.valid_access_implies.
   eapply Mem.load_valid_access. unfold load_stack, Val.add in H8. eexact H8.
   constructor.
   rewrite Int.add_zero.
   reflexivity.
  destruct 1 as [? [? ?]].
  unfold load_stack, Val.add in H8.
  rewrite H8 in H0. inv H0.
  assumption.
  eassumption.
  assumption.
  assumption.
  constructor.
Qed.

Lemma transf_final_states:
  forall s s' r
         (MATCH: match_states prog tprog init_m init_linear_rs init_sp init_ra s s')
         (FIN: LinearX.final_state init_linear_rs sg s r),
    final_state_with_inject (MachX.final_state init_mach_rs sg) init_m s' r.
Proof.
  intros.
  inv FIN.
  inv MATCH.
  inv STACKS.
  econstructor.
  econstructor.
  reflexivity.
  { (* Callee-save registers. *)
    intros.
    refine (_ (AGLOCS (R r) _)).
    simpl. intro REW.
    eapply Mem.val_inject_flat_inj_lessdef.
    eapply val_inject_incr_recip.
    rewrite <- REW.
    eapply AGREGS.
    eapply init_mach_rs_inj.
    eapply match_globalenvs_inject_incr.
    eassumption.
    assumption.
  }
  eapply match_globalenvs_inject_incr; eauto.
  eapply match_globalenvs_inject_separated; eauto.
  assumption.
  generalize (Conventions1.loc_result sg). induction l; simpl; eauto.
Qed.

Hypothesis wt_init_mach_rs:
  forall r, Val.has_type (init_mach_rs r) (mreg_type r).

Lemma wt_init_linear_rs:
  wt_locset (Some Lineartyping.Locset.empty) init_linear_rs.
Proof.
  constructor.
  destruct l.
   simpl; auto.
  destruct sl; try (constructor; fail).
  unfold init_linear_rs, load_stack.
  case_eq (
      Mem.loadv (chunk_of_type ty) init_m
                (Val.add init_sp
                         (Vint (Int.repr (Stacklayout.fe_ofs_arg + 4 * pos))))
    ); try (constructor; fail).
  destruct init_sp; try discriminate.
  unfold Val.add, Mem.loadv.
  intros.
  exploit Mem.load_type; eauto.
  destruct ty; simpl; tauto.
  inversion 1.
Qed.

Theorem wt_initial_state:
  forall i,
  forall S, LinearX.initial_state init_linear_rs prog i sg args init_m S ->
            Lineartyping.wt_state init_linear_rs S.
Proof.
  induction 1.
  exploit Genv.find_funct_ptr_inversion; eauto.
  destruct 1.
  econstructor.
  apply wt_callstack_nil.
  eapply wt_init_linear_rs.
  eapply wt_prog. eassumption. eassumption.
  apply wt_init_linear_rs.
Qed.

Variable return_address_offset: Mach.function -> Mach.code -> int -> Prop.

Hypothesis return_address_offset_exists:
  forall f sg ros c,
  is_tail (Mcall sg ros :: c) (fn_code f) ->
  exists ofs, return_address_offset f c ofs.

Hypothesis init_sp_not_global:
  forall (b : block) (o : int),
   init_sp = Vptr b o -> Ple (Genv.genv_next (Genv.globalenv prog)) b.

Hypothesis init_sp_valid:
  forall (b : block) (o : int),
   init_sp = Vptr b o -> Mem.valid_block init_m b.

Hypothesis init_sp_int:
  Val.has_type init_sp Tint.

Hypothesis init_ra_int:
  Val.has_type init_ra Tint.

Local Instance: WritableBlockOps (writable_block init_m).
Proof. typeclasses eauto. Defined.

Theorem transf_program_correct:
  forall i,
  forward_simulation
    (LinearX.semantics init_linear_rs prog i sg args init_m)
    (semantics_with_inject (MachX.semantics return_address_offset init_mach_rs init_sp init_ra tprog i sg args init_m) init_m)
.
Proof.
  set (ms := fun s s' => Lineartyping.wt_state init_linear_rs s /\ match_states prog tprog init_m init_linear_rs init_sp init_ra s s').
  intros.
  eapply forward_simulation_plus with (match_states := ms).
- apply symbols_preserved; auto.
- intros. simpl in *.
  exploit transf_initial_states; eauto. intros [st2 [A B]].
  exists st2; split; auto. split; auto.
  eapply wt_initial_state; eauto.
- intros. destruct H. eapply transf_final_states; eauto.
- intros. destruct H0.
  exploit transf_step_correct.
  eassumption.
  eassumption.
  fold ge. erewrite <- genv_next_preserved; eauto.
  eassumption.
  assumption.
  unfold Events.writable_block_with_init_mem. unfold writable_block. intros. generalize (init_sp_not_global _ _ H2). generalize (init_sp_valid _ _ H2). unfold Mem.valid_block. xomega.
  assumption.
  eexact init_ra_int.
  simpl in H. eassumption.
  assumption.
  eassumption.
  intros [s2' [A B]].
  exists s2'; split. exact A. split.
  eapply step_type_preservation; eauto.
  eapply wt_prog. eassumption.
  simpl in *. eassumption.
  assumption.
Qed.

End WITHCONFIG.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Data.Monads.OptionMonad.
Require Import ExtLib.Tactics.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprDI.

Set Implicit Arguments.
Set Strict Implicit.

Module ExprDenote <: ExprDenote.

  Section with_types.
    Context {typ func : Set}.
    Context {RType_typD : RType typ}.
    Context {Typ2_Fun : Typ2 _ Fun}.
    Context {RSym_func : RSym func}.

    (** Reasoning principles **)
    Context {RTypeOk_typD : RTypeOk}.
    Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
    Context {RSymOk_func : RSymOk RSym_func}.

    Let typ_arr : typ -> typ -> typ := @typ2 _ _ _.
    Let arr_match := @typ2_match _ _ _.
    Let typD_arr
    : forall ts a b, typD ts (typ_arr a b) = (typD ts a -> typD ts b)
      := @typ2_cast _ _ _.

    Global Instance RelDec_Rty ts : RelDec (Rty ts) :=
    { rel_dec := fun a b => match type_cast ts a b with
                              | Some _ => true
                              | None => false
                            end }.

    Global Instance RelDec_Correct_Rty ts : @RelDec_Correct _ (Rty ts) _.
    Proof.
      constructor. unfold rel_dec; simpl.
      intros; consider (type_cast ts x y); intros.
      split; auto. apply type_cast_total in H; eauto with typeclass_instances.
      intuition.
    Qed.

    Definition Rcast T {ts a b} (pf : Rty ts a b) : T (typD ts a) -> T (typD ts b) :=
      Relim T (Rsym pf).

    Definition Rcast_val
    : forall {ts a b} (pf : Rty ts a b), typD ts a -> typD ts b :=
      @Rcast (fun T => T).

    Definition OpenT ts := ResType.OpenT (typD ts).
    Definition Open_UseV := ResType.Open_UseV.
    Definition Open_UseU := ResType.Open_UseU.
    Definition Open_Inj ts tus tvs := Eval simpl in @pure (OpenT ts tus tvs) _.

    Definition Open_App {ts tus tvs t u}
    : OpenT ts tus tvs (typD ts (typ_arr t u)) -> OpenT ts tus tvs (typD ts t) -> OpenT ts tus tvs (typD ts u) :=
      match eq_sym (typD_arr ts t u) in _ = T
            return OpenT ts tus tvs T ->
                   OpenT ts tus tvs (typD ts t) ->
                   OpenT ts tus tvs (typD ts u)
      with
        | eq_refl => fun f x => fun us vs => (f us vs) (x us vs)
      end.

    Section OpenT.
      Variable ts : list Type.
      Variables tus tvs : tenv typ.

      (** Auxiliary definitions **)
      Definition Open_GetUAs (n : nat) (t : typ) :
        option (OpenT ts tus tvs (typD ts t)) :=
        bind (m := option)
             (nth_error_get_hlist_nth (typD ts) tus n)
             (fun t_get =>
                let '(existT t' get) := t_get in
                bind (m := option)
                     (type_cast ts t' t)
                     (fun cast =>
                        ret (fun us vs => Rcast_val cast (get us)))).

      Definition Open_GetVAs (n : nat) (t : typ) :
        option (OpenT ts tus tvs (typD ts t)) :=
        bind (m := option)
             (nth_error_get_hlist_nth (typD ts) tvs n)
             (fun t_get =>
                let '(existT t' get) := t_get in
                bind (m := option)
                     (type_cast ts t' t)
                     (fun cast =>
                        ret (fun us vs => Rcast_val cast (get vs)))).

    End OpenT.

    Definition Open_Abs {ts tus tvs t u}
    : OpenT ts tus (t :: tvs) (typD ts u) ->
      OpenT ts tus tvs (typD ts (typ_arr t u)) :=
      match eq_sym (typD_arr ts t u) in _ = T
            return OpenT ts tus (t :: tvs) (typD ts u) -> OpenT ts tus tvs T
      with
        | eq_refl => fun f => fun us vs x => f us (Hcons x vs)
      end.

    Section typeof_expr.
      Variable ts : list Type.
      Variable tus : tenv typ.

      Definition type_of_apply (tv x : typ) : option typ :=
        arr_match (fun _ => option typ) ts tv
                  (fun d r =>
                     match type_cast ts d x with
                       | Some _ => Some r
                       | None => None
                     end)
                  None.

      Fixpoint typeof_expr (tvs : tenv typ) (e : expr typ func)
      : option typ :=
        match e with
        | Var x  => nth_error tvs x
        | UVar x => nth_error tus x
        | Inj f => typeof_sym f
        | App e e' =>
          match typeof_expr tvs e
              , typeof_expr tvs e'
          with
            | Some tf , Some tx =>
              type_of_apply tf tx
            | _ , _ => None
          end
        | Abs t e =>
          match typeof_expr (t :: tvs) e with
            | None => None
            | Some t' => Some (typ_arr t t')
          end
      end.
    End typeof_expr.

    Section exprD'.
      Variable ts : list Type.
      Variable tus : tenv typ.

      Fixpoint exprD' (tvs : tenv typ) (t : typ) (e : expr typ func)
      : option (OpenT ts tus tvs (typD ts t)) :=
        match e return option (OpenT ts tus tvs (typD ts t)) with
          | Var v => @Open_GetVAs ts tus tvs v t
          | Inj f =>
            bind (m := option)
                 (@symAs _ _  _ f t)
                 (fun val =>
                    ret (@Open_Inj ts tus tvs _ val))
          | App f x =>
            bind (m := option)
                 (typeof_expr ts tus tvs x)
                 (fun d =>
                    bind (m := option)
                         (exprD' tvs (typ_arr d t) f)
                         (fun f =>
                            bind (m := option)
                                 (exprD' tvs d x)
                                 (fun x => ret (@Open_App ts _ _ _ _ f x))))
          | Abs t' e =>
            arr_match (fun T => option (OpenT ts tus tvs T)) ts t
                      (fun d r =>
                         bind (m := option)
                              (type_cast ts d t')
                              (fun cast =>
                                 bind (m := option)
                                      (exprD' (t' :: tvs) r e)
                                      (fun val =>
                                         ret (fun us vs x =>
                                                val us (Hcons (Rcast_val cast x) vs)))))
                      None
          | UVar u => @Open_GetUAs ts tus tvs u t
        end.
    End exprD'.

    (** Equations **)
    Theorem exprD'_Var
    : RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall ts tus tvs t v,
        exprD' ts tus tvs t (Var v) =
        bind (m := option)
             (nth_error_get_hlist_nth (typD ts) tvs v)
             (fun t_get =>
                let '(existT t' get) := t_get in
                bind (m := option)
                     (type_cast ts t' t)
                     (fun cast =>
                        ret (fun us vs => Rcast_val cast (get vs)))).
    Proof. reflexivity. Qed.

    Theorem exprD'_UVar
    : RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall ts tus tvs t u,
        exprD' ts tus tvs t (UVar u) =
        bind (m := option)
             (nth_error_get_hlist_nth (typD ts) tus u)
             (fun t_get =>
                let '(existT t' get) := t_get in
                bind (m := option)
                     (type_cast ts t' t)
                     (fun cast =>
                        ret (fun us vs => Rcast_val cast (get us)))).
    Proof. reflexivity. Qed.

    Theorem exprD'_Inj
    : RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall ts tus tvs t s,
        exprD' ts tus tvs t (Inj s) =
        bind (m := option)
             (funcAs s t)
             (fun val =>
                ret (fun _ _ => val)).
    Proof. reflexivity. Qed.

    Lemma exprD'_App'
    : forall ts tus tvs t f x,
        exprD' ts tus tvs t (App f x) =
        bind (m := option)
             (typeof_expr ts tus tvs x)
             (fun d =>
                bind (m := option)
                     (exprD' ts tus tvs (typ_arr d t) f)
                     (fun f =>
                        bind (m := option)
                             (exprD' ts tus tvs d x)
                             (fun x => ret (@Open_App ts _ _ _ _ f x)))).
    Proof. reflexivity. Qed.

    Theorem exprD'_Abs
    : RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall ts tus tvs t t' e,
        exprD' ts tus tvs t (Abs t' e) =
        arr_match (fun T => option (OpenT ts tus tvs T)) ts t
                  (fun d r =>
                     bind (m := option)
                          (type_cast ts d t')
                          (fun cast =>
                             bind (m := option)
                                  (exprD' ts tus (t' :: tvs) r e)
                                  (fun val =>
                                     ret (fun us vs x =>
                                            val us (Hcons (Rcast_val cast x) vs)))))
                  None.
    Proof. reflexivity. Qed.

    Theorem exprD'_App
    : RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall ts tus tvs t f x,
        exprD' ts tus tvs t (App f x) =
        bind (m := option)
             (typeof_expr ts tus tvs x)
             (fun t' =>
                bind (exprD' ts tus tvs (typ_arr t' t) f)
                     (fun f =>
                        bind (exprD' ts tus tvs t' x)
                             (fun x =>
                                ret (Open_App f x)))).
    Proof. reflexivity. Qed.

    Theorem exprD'_respects
    : RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall ts tus tvs t t' e (pf : Rty ts t' t),
        exprD' ts tus tvs t e =
        Rcast (fun T => option (OpenT ts tus tvs T)) pf
              (exprD' ts tus tvs t' e).
    Proof.
      destruct pf. change (eq_refl t') with (Rrefl ts t').
      unfold Rcast. rewrite Relim_refl; eauto with typeclass_instances.
    Qed.

  End with_types.

End ExprDenote.


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

Local Open Scope Z_scope.

Section Spec.

  Definition smc_realm_activate_spec (rd_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rd_addr with
    | VZ64 addr =>
      rely is_int64 addr;
      rely prop_dec (cur_rec (priv adt) = None);
      let gidx := __addr_to_gidx addr in
      if (GRANULE_ALIGNED addr) && (is_gidx gidx) then
        when adt == query_oracle adt;
        let gn := (gs (share adt)) @ gidx in
        rely prop_dec (glock gn = None);
        let e := EVT CPU_ID (ACQ gidx) in
        if g_tag (ginfo gn) =? GRANULE_STATE_RD then
          rely prop_dec (gtype gn = GRANULE_STATE_RD);
          rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
          rely is_int (g_realm_state (gnorm gn));
          if g_realm_state (gnorm gn) =? REALM_STATE_NEW then
            if g_measurement_algo (gnorm gn) =? MEASUREMENT_ALGO_SHA256 then
              if measure_finish (g_measurement_ctx (gnorm gn)) =? 0 then
                let g' := gn {gnorm: (gnorm gn) {g_measurement: 0} {g_realm_state: REALM_STATE_ACTIVE}} in
                let e' := EVT CPU_ID (REL gidx (g' {glock: Some CPU_ID})) in
                Some (adt {log: e' :: e :: log adt}
                          {share: (share adt) {gs: (gs (share adt)) # gidx == g'}},
                      VZ64 0)
              else None
            else
              let g' := gn {gnorm: (gnorm gn) {g_realm_state: REALM_STATE_ACTIVE}} in
              let e' := EVT CPU_ID (REL gidx (g' {glock: Some CPU_ID})) in
              Some (adt {log: e' :: e :: log adt}
                        {share: (share adt) {gs: (gs (share adt)) # gidx == g'}},
                    VZ64 0)
          else
            let e' := EVT CPU_ID (REL gidx (gn {glock: Some CPU_ID})) in
            Some (adt {log: e' :: e :: (log adt)}, VZ64 1)
        else
          let e' := EVT CPU_ID (REL gidx (gn {glock: Some CPU_ID})) in
          Some (adt {log: e' :: e :: (log adt)}, VZ64 1)
      else Some (adt, VZ64 1)
    end.

End Spec.


From caml5 Require Import
  prelude.
From caml5.base_logic Require Import
  lib.excl.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.concurrent Require Export
  base.
From caml5.concurrent Require Import
  mpmc_queue
  spmc_queue
  mpsc_queue.

Implicit Types v t : val.
Implicit Types vs : list val.

Record spsc_queue `{!heapGS Σ} {unboxed : bool} := {
  spsc_queue_make : val ;
  spsc_queue_push : val ;
  spsc_queue_pop : val ;

  spsc_queue_name : Type ;
  spsc_queue_inv : val → spsc_queue_name → namespace → iProp Σ ;
  spsc_queue_model : val → spsc_queue_name → list val → iProp Σ ;
  spsc_queue_producer : val → spsc_queue_name → iProp Σ ;
  spsc_queue_consumer : val → spsc_queue_name → iProp Σ ;

  spsc_queue_inv_persistent t γ ι :
    Persistent (spsc_queue_inv t γ ι) ;
  spsc_queue_model_timeless t γ vs :
    Timeless (spsc_queue_model t γ vs) ;
  spsc_queue_producer_timeless t γ :
    Timeless (spsc_queue_producer t γ) ;
  spsc_queue_consumer_timeless t γ :
    Timeless (spsc_queue_consumer t γ) ;

  spsc_queue_producer_exclusive t γ :
    spsc_queue_producer t γ -∗
    spsc_queue_producer t γ -∗
    False ;
  spsc_queue_consumer_exclusive t γ :
    spsc_queue_consumer t γ -∗
    spsc_queue_consumer t γ -∗
    False ;

  spsc_queue_make_spec ι :
    {{{ True }}}
      spsc_queue_make #()
    {{{ t γ,
      RET t;
      spsc_queue_inv t γ ι ∗
      spsc_queue_model t γ [] ∗
      spsc_queue_producer t γ ∗
      spsc_queue_consumer t γ
    }}} ;

  spsc_queue_push_spec t γ ι v :
    <<<
      spsc_queue_inv t γ ι ∗
      spsc_queue_producer t γ |
      ∀∀ vs, spsc_queue_model t γ vs
    >>>
      spsc_queue_push t v @ ↑ι
    <<<
      spsc_queue_model t γ (v :: vs) |
      RET #(); spsc_queue_producer t γ
    >>> ;

  spsc_queue_pop_spec t γ ι :
    <<<
      spsc_queue_inv t γ ι ∗
      spsc_queue_consumer t γ |
      ∀∀ vs, spsc_queue_model t γ vs
    >>>
      spsc_queue_pop t @ ↑ι
    <<< ∃∃ o,
      (⌜vs = [] ∧ o = NONEV⌝ ∗ spsc_queue_model t γ []) ∨
      (∃ vs' v, ⌜vs = vs' ++ [v] ∧ o = SOMEV v⌝ ∗ spsc_queue_model t γ vs') |
      RET o; spsc_queue_consumer t γ
    >>> ;

  spsc_queue_unboxed :
    if unboxed then ∀ t γ ι,
      spsc_queue_inv t γ ι -∗
      ⌜val_is_unboxed t⌝
    else
      True ;
}.
#[global] Arguments spsc_queue _ {_} _ : assert.
#[global] Arguments Build_spsc_queue {_ _} _ {_ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ : assert.
#[global] Existing Instance spsc_queue_inv_persistent.
#[global] Existing Instance spsc_queue_model_timeless.
#[global] Existing Instance spsc_queue_producer_timeless.
#[global] Existing Instance spsc_queue_consumer_timeless.

Class SpscQueueOfSpmcQueueG Σ `{!heapGS Σ} := {
  spsc_queue_of_spmc_queue_G_consumer_G : ExclG Σ unitO ;
}.
#[local] Existing Instance spsc_queue_of_spmc_queue_G_consumer_G.

Definition spsc_queue_of_spmc_queue_Σ := #[
  excl_Σ unitO
].
Lemma subG_spsc_queue_of_spmc_queue_Σ Σ `{!heapGS Σ} :
  subG spsc_queue_of_spmc_queue_Σ Σ →
  SpscQueueOfSpmcQueueG Σ.
Proof.
  solve_inG.
Qed.

Section spsc_queue_of_spmc_queue.
  Context `{SpscQueueOfSpmcQueueG Σ} {unboxed} (spmc_queue : spmc_queue Σ unboxed).

  Notation "γ .(base)" := γ.1
  ( at level 5
  ) : stdpp_scope.
  Notation "γ .(consumer)" := γ.2
  ( at level 5
  ) : stdpp_scope.

  Program Definition spsc_queue_of_spmc_queue : spsc_queue Σ unboxed := {|
    spsc_queue_make :=
      spmc_queue.(spmc_queue_make) ;
    spsc_queue_push :=
      spmc_queue.(spmc_queue_push) ;
    spsc_queue_pop :=
      spmc_queue.(spmc_queue_pop) ;

    spsc_queue_name :=
      spmc_queue.(spmc_queue_name) * gname ;
    spsc_queue_inv t γ ι :=
      spmc_queue.(spmc_queue_inv) t γ.(base) ι ;
    spsc_queue_model t γ :=
      spmc_queue.(spmc_queue_model) t γ.(base) ;
    spsc_queue_producer t γ :=
      spmc_queue.(spmc_queue_producer) t γ.(base) ;
    spsc_queue_consumer _ γ :=
      excl γ.(consumer) () ;
  |}.
  Next Obligation.
    intros. apply spmc_queue_producer_exclusive.
  Qed.
  Next Obligation.
    intros. apply excl_exclusive.
  Qed.
  Next Obligation.
    iIntros "%ι %Φ _ HΦ".
    iMod excl_alloc as "(%γ_consumer & Hconsumer)".
    wp_apply (spmc_queue_make_spec with "[//]"). iIntros "%t %γ_base (Hinv & Hmodel & Hproducer)".
    iApply ("HΦ" $! t (γ_base, γ_consumer)). iFrame.
  Qed.
  Next Obligation.
    intros. apply spmc_queue_push_spec.
  Qed.
  Next Obligation.
    iIntros "%t %γ %ι !> %Φ (Hinv & Hconsumer) HΦ".
    wp_apply (spmc_queue_pop_spec with "Hinv").
    iApply (atomic_update_wand with "[Hconsumer] HΦ").
    iIntros "_ %v HΦ _". iApply "HΦ". done.
  Qed.
  Next Obligation.
    destruct unboxed; last done. eauto using spmc_queue.(spmc_queue_unboxed).
  Qed.
End spsc_queue_of_spmc_queue.

Class SpscQueueOfMpscQueueG Σ `{!heapGS Σ} := {
  spsc_queue_of_mpsc_queue_G_producer_G : ExclG Σ unitO ;
}.
#[local] Existing Instance spsc_queue_of_mpsc_queue_G_producer_G.

Definition spsc_queue_of_mpsc_queue_Σ := #[
  excl_Σ unitO
].
Lemma subG_spsc_queue_of_mpsc_queue_Σ Σ `{!heapGS Σ} :
  subG spsc_queue_of_mpsc_queue_Σ Σ →
  SpscQueueOfMpscQueueG Σ.
Proof.
  solve_inG.
Qed.

Section spsc_queue_of_mpsc_queue.
  Context `{SpscQueueOfMpscQueueG Σ} {unboxed} (mpsc_queue : mpsc_queue Σ unboxed).

  Notation "γ .(base)" := γ.1
  ( at level 5
  ) : stdpp_scope.
  Notation "γ .(producer)" := γ.2
  ( at level 5
  ) : stdpp_scope.

  Program Definition spsc_queue_of_mpsc_queue : spsc_queue Σ unboxed := {|
    spsc_queue_make :=
      mpsc_queue.(mpsc_queue_make) ;
    spsc_queue_push :=
      mpsc_queue.(mpsc_queue_push) ;
    spsc_queue_pop :=
      mpsc_queue.(mpsc_queue_pop) ;

    spsc_queue_name :=
      mpsc_queue.(mpsc_queue_name) * gname ;
    spsc_queue_inv t γ ι :=
      mpsc_queue.(mpsc_queue_inv) t γ.(base) ι ;
    spsc_queue_model t γ :=
      mpsc_queue.(mpsc_queue_model) t γ.(base) ;
    spsc_queue_producer _ γ :=
      excl γ.(producer) () ;
    spsc_queue_consumer t γ :=
      mpsc_queue.(mpsc_queue_consumer) t γ.(base) ;
  |}.
  Next Obligation.
    intros. apply excl_exclusive.
  Qed.
  Next Obligation.
    intros. apply mpsc_queue_consumer_exclusive.
  Qed.
  Next Obligation.
    iIntros "%ι %Φ _ HΦ".
    iMod excl_alloc as "(%γ_producer & Hproducer)".
    wp_apply (mpsc_queue_make_spec with "[//]"). iIntros "%t %γ_base (Hinv & Hmodel & Hconsumer)".
    iApply ("HΦ" $! t (γ_base, γ_producer)). iFrame.
  Qed.
  Next Obligation.
    iIntros "%t %γ %ι %v !> %Φ (Hinv & Hproducer) HΦ".
    wp_apply (mpsc_queue_push_spec with "Hinv").
    iApply (atomic_update_wand with "[Hproducer] HΦ").
    iIntros "_ HΦ _". iApply "HΦ". done.
  Qed.
  Next Obligation.
    intros. apply mpsc_queue_pop_spec.
  Qed.
  Next Obligation.
    destruct unboxed; last done. eauto using mpsc_queue.(mpsc_queue_unboxed).
  Qed.
End spsc_queue_of_mpsc_queue.

Class SpscQueueOfMpmcQueueG Σ `{!heapGS Σ} := {
  spsc_queue_of_mpmc_queue_G_mpmc_queue_G : SpmcQueueOfMpmcQueueG Σ ;
  spsc_queue_of_mpmc_queue_G_spmc_queue_G : SpscQueueOfSpmcQueueG Σ ;
}.
#[local] Existing Instance spsc_queue_of_mpmc_queue_G_mpmc_queue_G.
#[local] Existing Instance spsc_queue_of_mpmc_queue_G_spmc_queue_G.

Definition spsc_queue_of_mpmc_queue_Σ := #[
  spmc_queue_of_mpmc_queue_Σ ;
  spsc_queue_of_spmc_queue_Σ
].
Lemma subG_spsc_queue_of_mpmc_queue_Σ Σ `{!heapGS Σ} :
  subG spsc_queue_of_mpmc_queue_Σ Σ →
  SpscQueueOfMpmcQueueG Σ.
Proof.
  pose subG_spmc_queue_of_mpmc_queue_Σ.
  pose subG_spsc_queue_of_spmc_queue_Σ.
  solve_inG.
Qed.

Definition spsc_queue_of_mpmc_queue `{SpscQueueOfMpmcQueueG Σ} {unboxed} {mpmc_queue : mpmc_queue Σ unboxed} :=
  spsc_queue_of_spmc_queue (spmc_queue_of_mpmc_queue mpmc_queue).