Require Export Coq.Lists.ListSet.
Require Export Coq.Classes.SetoidDec.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export featuremodelrefinement_def.
Require Export featuremodelrefinement_int.
Import FeatureModelRefinimentTheory.
Require Export formulatheory_def.
Require Export formulatheory_proofs.
Require Export formulatheory_int.
Import FormulaTheory.

Program Instance FeatureModelRefinement_Ins: FeatureModelRefinement Formula Name FM :=
{
  addMandatoryNode:= addMandatoryNode_func;
  addOptionalNode := addOptionalNode_func;

}. Next Obligation. {
  apply name_dec_axiom.
} Qed. Next Obligation. {
  apply form_dec_axiom.
} Qed. Next Obligation. {
  unfold not in H4. unfold ns_func. unfold ns_func in H0, H3, H4, H2.
  intuition. admit.

} Admitted. Next Obligation. {
  unfold FeatureModelSemantics.wfFM_func. split. unfold addMandatoryNode_func in H.
  destruct H. destruct H0. intuition. admit.
  admit.

} Admitted. Next Obligation. {
  admit.
} Admitted. Next Obligation. {
  admit.
} Admitted. Next Obligation. {
  admit.
} Admitted. Next Obligation. {
  admit.

} Admitted. Next Obligation. {
  admit.

} Admitted.


Require Import CoqlibC Maps.
Require Import ASTC Integers ValuesC EventsC Memory Globalenvs.
Require Import Op Registers.
Require Import sflib.
Require Import SmallstepC.
Require Export Simulation.
Require Import Skeleton Mod ModSem.
Require Import CtypesC CtypingC.
Require Import ClightC AsmC.
Require Import LinkingC.
Require Import MutrecHeader.
Require Import MutrecA MutrecB.

Set Implicit Arguments.

Local Obligation Tactic := ii; ss; des; inv_all_once; ss; clarify.

Definition sk_link: Sk.t :=
  match link (CSk.of_program signature_of_function MutrecA.prog) (Sk.of_program fn_sig MutrecB.prog) with
  | Some sk => sk
  | None => Sk.empty
  end
.

Section MODSEM.

  Variable skenv_link: SkEnv.t.
  Variable p: unit.
  Let skenv: SkEnv.t := (SkEnv.project skenv_link) sk_link.
  Let ge: SkEnv.t := skenv.

  Inductive state: Type :=
  | Callstate
      (i: int)
      (m: mem)
  | Returnstate
      (s: int)
      (m: mem)
  .

  Definition get_mem (st: state): mem :=
    match st with
    | Callstate _ m => m
    | Returnstate _ m => m
    end
  .

  Inductive initial_frame (args: Args.t): state -> Prop :=
  | initial_frame1_intro
      i m func_fg
      (FINDF: Genv.find_funct ge (Args.fptr args) = Some (AST.Internal func_fg))
      (VS: (Args.vs args) = [Vint i])
      (M: (Args.m args) = m)
      (RANGE: 0 <= i.(Int.intval) < MAX)
    :
      initial_frame args (Callstate i m)
  .

  Inductive step (se: Senv.t) (ge: SkEnv.t): state -> trace -> state -> Prop :=
  | step_zero
      i m
    :
      step se ge (Callstate i m) E0 (Returnstate (sum i) m)
  .

  Inductive final_frame: state -> Retv.t -> Prop :=
  | final_frame_return
      s m
    :
      final_frame (Returnstate s m) (Retv.mk (Vint s) m)
  .

  Program Definition modsem: ModSem.t :=
    {|
      ModSem.step := step;
      ModSem.at_external := bot2;
      ModSem.initial_frame := initial_frame;
      ModSem.final_frame := final_frame;
      ModSem.after_external := bot3;
      ModSem.globalenv := ge;
      ModSem.skenv := skenv;
      ModSem.skenv_link := skenv_link;
    |}
  .

End MODSEM.

Program Definition module: Mod.t :=
  {| Mod.data := tt; Mod.get_sk := fun _ => sk_link; Mod.get_modsem := modsem; |}.


Require Import VST.floyd.proofauto.
Import ListNotations.
Require sha.sha.
Require Import sha.SHA256.
Local Open Scope logic.

Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC256_functional_prog.
Require Import sha.hmac.
Require Import sha.spec_hmac.
Require Import sha.vst_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.hmac_common_lemmas.

Require Import sha.verif_hmac_init_part1.
Require Import sha.verif_hmac_init_part2.

Lemma initbodyproof Espec c k l key kv h1 pad ctxkey:
@semax CompSpecs Espec (func_tycontext f_HMAC_Init HmacVarSpecs HmacFunSpecs)
  (PROP  ()
   LOCAL  (lvar _ctx_key (tarray tuchar 64) ctxkey;
           lvar _pad (tarray tuchar 64) pad; temp _ctx c; temp _key k;
           temp _len (Vint (Int.repr l)); gvar sha._K256 kv)
   SEP  (data_at_ Tsh (tarray tuchar 64) ctxkey;
         data_at_ Tsh (tarray tuchar 64) pad;
         K_vector kv; initPre c k h1 l key))
  (Ssequence (fn_body f_HMAC_Init) (Sreturn None))
  (frame_ret_assert
     (function_body_ret_assert tvoid
        (PROP  ()
         LOCAL ()
         SEP  (hmacstate_ (hmacInit key) c; initPostKey k key; K_vector kv)))
     (stackframe_of f_HMAC_Init)).
Proof. abbreviate_semax.
freeze [1; 2; 3] FR1. simpl.
Time forward. (*0.8 versus 1.3*)

Time assert_PROP (isptr ctxkey) as Pckey by entailer!. (*0.7*)
apply isptrD in Pckey; destruct Pckey as [ckb [ckoff PcKey]].
  (*Issue subst ctxkey. fails*) rewrite PcKey in *.

(*isolate branch if (key != NULL) *)
apply seq_assoc.
(*from init_part1:
Definition initPostKeyNullConditional r (c:val) (k: val) h key ctxkey: mpred:=
  match k with
    Vint z => if Int.eq z Int.zero
              then if zeq r Z0
                   then (hmacstate_PreInitNull key h c) * (data_at_ Tsh (tarray tuchar 64) ctxkey)
                   else FF
              else FF
  | Vptr b ofs => if zeq r 0 then FF
                  else !!(Forall isbyteZ key) &&
                    ((data_at Tsh t_struct_hmac_ctx_st keyedHMS c) *
                     (data_at Tsh (tarray tuchar 64) (map Vint (map Int.repr (HMAC_SHA256.mkKey key)))
                      ctxkey)  *
                     (data_at Tsh (tarray tuchar (Zlength key)) (map Vint (map Int.repr key))
                      (Vptr b ofs)))
  | _ => FF
  end.*)
(*remember (EX  cb : block,
                 (EX  cofs : int,
                   (EX  r : Z,
                    PROP  (c = Vptr cb cofs /\ (r=0 \/ r=1))
                    LOCAL  (temp _reset (Vint (Int.repr r));
                      lvar _ctx_key (tarray tuchar 64) (Vptr ckb ckoff);
                      lvar _pad (tarray tuchar 64) pad;
                      temp _ctx c; temp _key k; temp _len (Vint (Int.repr l));
                      gvar sha._K256 kv)
                    SEP  (data_at_ Tsh (tarray tuchar 64) pad;
                    initPostKeyNullConditional r c k h1 key (Vptr ckb ckoff);
                    K_vector kv)))) as PostKeyNull. *)
forward_seq. instantiate (1:= PostKeyNull c k pad kv h1 l key ckb ckoff).
{  assert (DD: Delta= initialized _reset Delta) by reflexivity.
   rewrite DD.
   eapply semax_pre_simple.
   2: eapply hmac_init_part1; eassumption.
   thaw' FR1. Time entailer!. (*2.2 versus 2.3*) }
(*subst PostKeyNull.*)
unfold PostKeyNull. Intros cb cofs r.
(*Time normalize. (*2.3*)*)
unfold POSTCONDITION, abbreviate. subst c.
rename H0 into R.

(*isolate branch if (reset) *)
apply seq_assoc.
(*from init_part2:
Definition postResetHMS (iS oS: s256state): hmacstate :=
  (default_val t_struct_SHA256state_st, (iS, oS)).
Definition initPostResetConditional r (c:val) (k: val) h key iS oS: mpred:=
  match k with
    Vint z => if Int.eq z Int.zero
              then if zeq r Z0 then hmacstate_PreInitNull key h c else FF
              else FF
  | Vptr b ofs => if zeq r 0 then FF
                  else !!(Forall isbyteZ key) &&
                       ((data_at Tsh t_struct_hmac_ctx_st (postResetHMS iS oS) c) *
                        (data_at Tsh (tarray tuchar (Zlength key)) (map Vint (map Int.repr key)) (Vptr b ofs)))
  | _ => FF
  end.*)
remember (EX shaStates:_ ,
          PROP  (innerShaInit (map Byte.repr (HMAC_SHA256.mkKey key))
                           =(fst shaStates) /\
                  s256_relate (fst shaStates) (fst (snd shaStates)) /\
                  outerShaInit (map Byte.repr (HMAC_SHA256.mkKey key))
                          = (fst (snd (snd shaStates))) /\
                  s256_relate (fst (snd (snd shaStates))) (snd (snd (snd shaStates))))
          LOCAL  (lvar _pad (tarray tuchar 64) pad;
                  lvar _ctx_key (tarray tuchar 64) (Vptr ckb ckoff);
                  temp _ctx (Vptr cb cofs); temp _key k;
                  temp _len (Vint (Int.repr l));
                  gvar sha._K256 kv)
          SEP  (data_at_ Tsh (tarray tuchar 64) pad;
                data_at_ Tsh (Tarray tuchar 64 noattr) (Vptr ckb ckoff);
                initPostResetConditional r (Vptr cb cofs) k h1 key (fst (snd shaStates)) (snd (snd (snd shaStates)));
                K_vector kv))
  as PostResetBranch.
clear FR1.
eapply semax_seq. instantiate (1:=PostResetBranch).
{ apply sequential'.
  eapply semax_pre_post'.
  Focus 3 . apply init_part2; try eassumption.
  apply andp_left2. apply derives_refl. apply ENTAIL_refl. }

{ (*Continuation after if (reset*)
  subst PostResetBranch.
  simpl update_tycon.
  apply semax_extensionality_Delta with (Delta).
  apply tycontext_sub_refl.
  apply extract_exists_pre; intros [iSA [iS [oSA oS]]]. simpl.
  assert_PROP (is_pointer_or_null k) as Ptr_null_k by entailer!.
  destruct k; simpl in Ptr_null_k; try contradiction.
  { (*Case key==null*)
    subst i.
    destruct R; subst r; simpl.
    2: solve [apply semax_pre with (P':=FF); try entailer!; try apply semax_ff].
    freeze [0; 1; 3] FR2.
    Time normalize. (*5.7*)
    rename H into InnerRelate.
    rename H0 into OuterRelate.
    unfold hmacstate_PreInitNull.
    Intros s v.
    rename H into Hs.
    unfold hmac_relate_PreInitNull in Hs.
    clear InnerRelate OuterRelate iS oS.
    destruct h1.
    destruct Hs as [IREL [OREL [ILEN [OLEN [ISHA OSHA]]]]].
    destruct s as [mdS [iS oS]].

(* Issue: why is update_reptype not simplifying? *)
     match goal with |- context [@upd_reptype ?cs ?t ?gfs ?x ?v] =>
           change (@upd_reptype cs t gfs x v) with (v,(iS,oS)) end.
     simpl in *.

     Time assert_PROP (field_compatible t_struct_hmac_ctx_st [] (Vptr cb cofs))
       as FC_cb by entailer!. (*1.8 versus 3.9*)
     assert (FC_cb_ictx: field_compatible t_struct_hmac_ctx_st [StructField _i_ctx] (Vptr cb cofs)).
     { red in FC_cb. repeat split; try solve [apply FC_cb]. right; left; reflexivity. }
     assert (FC_cb_md: field_compatible t_struct_hmac_ctx_st [StructField _md_ctx] (Vptr cb cofs)).
     { red in FC_cb. repeat split; try solve [apply FC_cb]. left. reflexivity. }

     Time unfold_data_at 1%nat. (*0.8, was slow*)
     rewrite (field_at_data_at _ _ [StructField _i_ctx]).
     (*VST Issue: why does rewrite field_at_data_at at 2 FAIL, but focus_SEP 3; rewrite field_at_data_at at 1. SUCCEED???
        Answer: instead of using "at 2", use the field-specificer in the line above.*)
     rewrite field_address_offset by auto with field_compatible.

     freeze [0; 3] FR3.
     Time forward_call ((Tsh, Tsh),
             Vptr cb cofs,
             Vptr cb (Ptrofs.add cofs (Ptrofs.repr 108)),
             mkTrep t_struct_SHA256state_st iS,
             @sizeof (@cenv_cs CompSpecs) t_struct_SHA256state_st).
     (*5.9 versus 13*)
     { rewrite sepcon_comm.
       rewrite (field_at_data_at _ _ [StructField _md_ctx]).
       rewrite field_address_offset by auto with field_compatible.
       apply sepcon_derives.
         eapply derives_trans. apply data_at_memory_block. apply derives_refl'. f_equal.
         apply isptr_offset_val_zero; simpl; trivial.
       Time cancel. (*0 versus 2*)
     }

     freeze [0; 1; 2] FR4.
     Time forward. (*return*) (* 3 versus 13*) (*Issue : leaves a somewhat messy subgoal*)
     unfold hmacInit.
     remember (Int.unsigned (Int.repr (if zlt 64 (Zlength key) then 32 else Zlength key)))as KL.
     Time entailer!. (*1.6 versus 7.4*)
     unfold hmacstate_, hmac_relate.
      Exists (iS, (iS, oS)).
      simpl. Time entailer!. (*1.9 versus 5.6*)

     unfold_data_at 1%nat.
     rewrite (field_at_data_at _ _ [StructField _md_ctx]).
     rewrite (field_at_data_at _ _ [StructField _i_ctx]).
      rewrite field_address_offset by auto with field_compatible.
      rewrite field_address_offset by auto with field_compatible.
      simpl; rewrite Ptrofs.add_zero.
      change (Tarray tuchar 64 noattr) with (tarray tuchar 64).
      thaw FR4. thaw FR3. thaw FR2.
      Time cancel. (*1.6 versus 0.7*)
  }

  { (*k is Vptr, key!=NULL*)
    freeze [0;1;3] FR5.
    destruct R as [R | R]; rewrite R; simpl.
    solve [apply semax_pre with (P':=FF); try entailer; try apply semax_ff].
    Intros.
    rename H0 into InnerRelate.
    rename H2 into OuterRelate. rename H3 into isbyteKey.
    unfold postResetHMS. simpl.
    freeze [0; 2] FR6.
    Time assert_PROP (field_compatible t_struct_hmac_ctx_st [] (Vptr cb cofs)) as FC_cb by entailer!. (*2.8*)
    assert (FC_cb_ictx: field_compatible t_struct_hmac_ctx_st [StructField _i_ctx] (Vptr cb cofs)).
    { red in FC_cb. repeat split; try solve [apply FC_cb]. right; left; reflexivity. }
    assert (FC_cb_md: field_compatible t_struct_hmac_ctx_st [StructField _md_ctx] (Vptr cb cofs)).
    { red in FC_cb. repeat split; try solve [apply FC_cb]. left; reflexivity. }

    unfold_data_at 1%nat.
    freeze [0; 3] FR7.
    rewrite (field_at_data_at Tsh t_struct_hmac_ctx_st [StructField _i_ctx]).
    rewrite (field_at_data_at Tsh t_struct_hmac_ctx_st [StructField _md_ctx]).
    rewrite field_address_offset by auto with field_compatible.
    rewrite field_address_offset by auto with field_compatible.
    simpl; rewrite Ptrofs.add_zero.

    Time forward_call ((Tsh, Tsh),
             Vptr cb cofs,
             Vptr cb (Ptrofs.add cofs (Ptrofs.repr 108)),
             mkTrep t_struct_SHA256state_st iS,
             @sizeof (@cenv_cs CompSpecs) t_struct_SHA256state_st).
    (* 4.7 versus 14.7 *)
    { rewrite sepcon_comm.
      apply sepcon_derives.
          eapply derives_trans. apply data_at_memory_block. apply derives_refl.
          Time cancel. (*0 versus 2*)
    }
    freeze [0; 1; 2] FR8.
    Time forward. (*return*) (*3.4 versus 17*) (*Issue: leaves messy subgoal*)
    Time entailer!. (* 1.2 versus 9*)
    unfold data_block, hmacstate_, hmac_relate.
    Exists (iS, (iS, oS)).
    change (@data_at spec_sha.CompSpecs Tsh (tarray tuchar (@Zlength Z key)))
       with (@data_at CompSpecs Tsh (tarray tuchar (@Zlength Z key))).
    change (Tarray tuchar 64 noattr) with (tarray tuchar 64). simpl.
    Time entailer!. (*2.9*)
      unfold s256a_len, innerShaInit, outerShaInit.
           repeat rewrite Zlength_mkArgZ,
           map_length, mkKey_length. split; reflexivity.
    unfold_data_at 1%nat.
      rewrite (field_at_data_at _ _ [StructField _md_ctx]).
      rewrite (field_at_data_at _ _ [StructField _i_ctx]).
    rewrite field_address_offset by auto with field_compatible.
    rewrite field_address_offset by auto with field_compatible.
    simpl; rewrite Ptrofs.add_zero.
    thaw FR8. thaw FR7. thaw FR6. thaw FR5.
    Time cancel. (*1.7 versus 1.2 penalty when melting*)
  }
}
Time Qed. (*25 versus 49*)

Lemma body_hmac_init: semax_body HmacVarSpecs HmacFunSpecs
       f_HMAC_Init HMAC_Init_spec.
Proof.
start_function.
apply initbodyproof.
Qed.


Require Import VST.floyd.base2.
Require Import VST.floyd.assert_lemmas.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.jmeq_lemmas.
Require Export VST.floyd.fieldlist.
Require Export VST.floyd.compact_prod_sum.
Require Export VST.zlist.sublist.

Definition proj_struct (i : ident) (m : members) {A: member -> Type} (v: compact_prod (map A m))
    (d: A (get_member i m)): A (get_member i m) :=
  proj_compact_prod (get_member i m) m v d member_dec.

Definition proj_union (i : ident) (m : members) {A: member -> Type} (v: compact_sum (map A m))
   (d: A (get_member i m)): A (get_member i m) :=
  proj_compact_sum (get_member i m) m v d member_dec.

Definition members_union_inj {m: members} {A} (v: compact_sum (map A m)) (it: member): Prop :=
  compact_sum_inj v it member_dec.

(* TODO: We should use the following two definition in replace_refill lemmas in the future. And avoid using compact prod/sum directly. *)

Definition upd_struct (i : ident) (m : members) {A: member -> Type} (v: compact_prod (map A m))
   (v0: A (get_member i m)): compact_prod (map A m) :=
  upd_compact_prod _ v (get_member i m) v0 member_dec.

Definition upd_union (i : ident) (m : members) {A: member -> Type} (v: compact_sum (map A m))
   (v0: A (get_member i m)): compact_sum (map A m) :=
  upd_compact_sum _ v (get_member i m) v0 member_dec.

Lemma get_member_name: forall a m,
  members_no_replicate m = true ->
  In a m ->
  get_member (name_member a) m = a.
Proof.
 intros.
 unfold members_no_replicate in H.
 apply compute_list_norepet_e in H.
 induction m.
 inv H0.
 simpl in H. inv H.
  destruct H0.
 subst. simpl. rewrite if_true by auto. auto.
 simpl. rewrite if_false; auto.
 contradict H3.
 rewrite <- H3.
 apply in_map. auto.
Qed.

Lemma in_get_member:
  forall i m,
   in_members i m ->
   In (get_member i m) m.
Proof.
intros.
 induction m.
 inv H.
 simpl in *.
  if_tac. auto.
  destruct H. subst. contradiction.
  right. auto.
Qed.

Lemma proj_struct_JMeq: forall (i: ident) (m : members)
   {A1 A2: member -> Type}
   (v1: compact_prod (map A1 m)) (v2: compact_prod (map A2 m))
  (d1: A1 (get_member i m)) (d2: A2 (get_member i m)),
  (forall i, in_members i m -> @eq Type (A1 (get_member i m)) (A2 (get_member i m))) ->
  members_no_replicate m = true ->
  in_members i m ->
  JMeq v1 v2 ->
  JMeq (proj_struct i m v1 d1) (proj_struct i m v2 d2).
Proof.
  intros.
  apply proj_compact_prod_JMeq; auto.
  + clear - H H0.
    intros.
    rewrite <- (get_member_name i m); auto.
    apply H.
    apply List.in_map with (f := name_member) in H1.
    auto.
  +
   apply in_get_member; auto.
Qed.

Lemma members_union_inj_JMeq: forall (m : members)
  {A1 A2: member -> Type} (v1: compact_sum (map A1 m)) (v2: compact_sum (map A2 m)),
  (forall i, in_members i m -> @eq Type (A1 (get_member i m)) (A2 (get_member i m))) ->
  members_no_replicate m = true ->
  JMeq v1 v2 ->
  (forall it, members_union_inj v1 it <-> members_union_inj v2 it).
Proof.
  intros.
  apply compact_sum_inj_JMeq; auto.
  intros a ?.
  specialize (H (name_member a)).
  spec H.
  +
    apply in_map; auto.
  +
     rewrite <- (get_member_name a m); auto.
Qed.

Lemma proj_union_JMeq: forall (i: ident) (m : members)
  {A1 A2: member -> Type} (v1: compact_sum (map A1 m)) (v2: compact_sum (map A2 m)) (d1: A1 (get_member i m)) (d2: A2 (get_member i m)),
  (forall i, in_members i m -> @eq Type (A1 (get_member i m)) (A2 (get_member i m))) ->
  members_no_replicate m = true ->
  members_union_inj v1 (get_member i m) ->
  JMeq v1 v2 ->
  JMeq (proj_union i m v1 d1) (proj_union i m v2 d2).
Proof.
  intros.
  apply proj_compact_sum_JMeq; auto.
  + clear - H H0.
    intros.
    rewrite <- (get_member_name i m); auto.
    apply H.
    apply List.in_map with (f := name_member) in H1.
    auto.
Qed.


Require Import Coq.ZArith.BinInt.
Require Import riscv.util.BitWidths.
Require Import riscv.util.Monads.
Require Import riscv.Decode.
Require Import riscv.Memory. (* should go before Program because both define loadByte etc *)
Require Import riscv.Program.
Require Import riscv.Execute.
Require Import riscv.util.PowerFunc.
Require Import riscv.Utility.
Require Import Coq.Lists.List. Import ListNotations.
Require Import riscv.Minimal.

Section Riscv.

  Context {t: Set}.

  Context {MW: MachineWidth t}.

  Context {Mem: Set}.

  Context {MemIsMem: Memory Mem t}.

  Context {RF: Type}.
  Context {RFI: RegisterFile RF Register t}.

  Inductive LogEvent :=
  | EvLoadWord(addr: Z)(i: Instruction)
  | EvStoreWord(addr: Z)(v: word 32).

  Definition Log := list LogEvent.

  Record RiscvMachineL := mkRiscvMachineL {
    machine: @RiscvMachine t Mem RF;
    log: Log;
  }.

  Definition with_machine m ml := mkRiscvMachineL m ml.(log).
  Definition with_log l ml := mkRiscvMachineL ml.(machine) l.

  Definition liftL0{B: Type}(f: OState RiscvMachine B):  OState RiscvMachineL B :=
    fun s => let (ob, ma) := f s.(machine) in (ob, with_machine ma s).

  Definition liftL1{A B: Type}(f: A -> OState RiscvMachine B): A -> OState RiscvMachineL B :=
    fun a s => let (ob, ma) := f a s.(machine) in (ob, with_machine ma s).

  Definition liftL2{A1 A2 B: Type}(f: A1 -> A2 -> OState RiscvMachine B):
    A1 -> A2 -> OState RiscvMachineL B :=
    fun a1 a2 s => let (ob, ma) := f a1 a2 s.(machine) in (ob, with_machine ma s).

  Instance IsRiscvMachineL: RiscvProgram (OState RiscvMachineL) t :=  {|
      getRegister := liftL1 getRegister;
      setRegister := liftL2 setRegister;
      getPC := liftL0 getPC;
      setPC := liftL1 setPC;
      loadByte   := liftL1 loadByte;
      loadHalf   := liftL1 loadHalf;
      loadWord a :=
        m <- get;
        res <- (liftL1 loadWord a);
        put (with_log (m.(log) ++ [EvLoadWord (regToZ_unsigned a) (decode RV64IM (uwordToZ res))]) m);;
        Return res;
      loadDouble := liftL1 loadDouble;
      storeByte   := liftL2 storeByte;
      storeHalf   := liftL2 storeHalf;
      storeWord a v :=
        m <- get;
        put (with_log (m.(log) ++ [EvStoreWord (regToZ_unsigned a) v]) m);;
        liftL2 storeWord a v;
      storeDouble := liftL2 storeDouble;
      step := liftL0 step;
      getCSRField_MTVecBase := liftL0 getCSRField_MTVecBase;
      endCycle A := Return None;
  |}.

  Definition putProgram(prog: list (word 32))(addr: t)(ma: RiscvMachineL): RiscvMachineL :=
    with_machine (putProgram prog addr ma.(machine)) ma.

End Riscv.

Existing Instance IsRiscvMachineL. (* needed because it was defined inside a Section *)


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.
Require Import SplitTest.

Lemma eval_a :
  eval_expr ge empty a (bits (v 1)).
Proof.
  g.
  e. e. e. e. e. g.
  e. e. e. e. e. e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. repeat e. e.
  repeat e.
  e. e. e. e. g.
  e. e. e. repeat e. e.
  repeat e.
  e. e. e. e.
  e. e. e. e. e. e.
  e. e. e. e. g.
  e. e. e. e. e. e. e. e.
  e. e. repeat e. e.
  eapply select_split. e. reflexivity.
  simpl. reflexivity.
  e. e. e. g.
  e. e. e. e. e. e. e. e.
  e.
  e. repeat e.
  e. eapply select_slice.
  repeat e. reflexivity.
  simpl. repeat e.
  Unshelve.
  all: exact nz.
Qed.


Require Import Omega.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Loc.

Require Import Event.
Require Import Time.
Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import WFConfig.

Set Implicit Arguments.

Lemma promise_step_promise_consistent
      lc1 mem1 loc from to msg lc2 mem2 kind
      (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii.
  destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
  - destruct kind; ss. inv PROMISE.
    destruct (Memory.get loc0 ts promises2) as [[]|] eqn:GET2.
    + dup GET2. revert GET0.
      erewrite Memory.remove_o; eauto. condtac; ss. i.
      rewrite PROMISE0 in *. inv GET0. eauto.
    + revert GET2. erewrite Memory.remove_o; eauto. condtac; ss; i.
      * des. subst. exploit Memory.remove_get0; eauto. i. des. congr.
      * congr.
  - exploit Memory.promise_get1_promise; eauto. i. des.
    inv MSG_LE. exploit CONS; eauto.
Qed.

Lemma read_step_promise_consistent
      lc1 mem1 loc to val released ord lc2 lo
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2 lo)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii. exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto. ss.
  etrans; [|apply Time.join_l]. etrans; [|apply Time.join_l]. refl.
Qed.

Lemma fulfill_unset_promises
      loc from ts msg
      promises1 promises2
      l t f m
      (FULFILL: Memory.remove promises1 loc from ts msg promises2)
      (TH1: Memory.get l t promises1 = Some (f, m))
      (TH2: Memory.get l t promises2 = None):
  l = loc /\ t = ts /\ f = from /\ Message.le msg m.
Proof.
  revert TH2. erewrite Memory.remove_o; eauto. condtac; ss; [|congr].
  des. subst. exploit Memory.remove_get0; eauto. i. des.
  rewrite GET in TH1. inv TH1.
  esplits; eauto. refl.
Qed.

Lemma write_step_promise_consistent
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind lo
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind lo)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. inv WRITE. ii.
  exploit Memory.promise_get1_promise; eauto.
  { inv PROMISE; ss. }
  i. des. inv MSG_LE.
  destruct (Memory.get loc0 ts promises2) as [[]|] eqn:X.
  - dup X. revert X0.
    erewrite Memory.remove_o; eauto. condtac; ss; i.
    rewrite GET in *. inv X0.
    apply CONS in X. eapply TimeFacts.le_lt_lt; eauto.
    s. etrans; [|apply Time.join_l]. refl.
  - exploit fulfill_unset_promises; eauto. i. des. subst.
    apply WRITABLE.
Qed.

Lemma fence_step_promise_consistent
      lc1 sc1 mem1 ordr ordw lc2 sc2
      (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2)
      (WF: Local.wf lc1 mem1)
      (CONS: Local.promise_consistent lc2):
  Local.promise_consistent lc1.
Proof.
  inv STEP. ii.
  exploit CONS; eauto. i.
  eapply TimeFacts.le_lt_lt; eauto.
  cut (TView.le (Local.tview lc1)
                (TView.write_fence_tview (TView.read_fence_tview (Local.tview lc1) ordr) sc1 ordw)).
  { i. inv H. apply CUR. }
  etrans.
  - eapply TViewFacts.write_fence_tview_incr. apply WF.
  - eapply TViewFacts.write_fence_tview_mon; try refl; try apply WF.
    eapply TViewFacts.read_fence_tview_incr. apply WF.
Qed.

Lemma ordering_relaxed_dec
      ord:
  Ordering.le ord Ordering.relaxed \/ Ordering.le Ordering.strong_relaxed ord.
Proof. destruct ord; auto. Qed.

Lemma step_promise_consistent
      lang pf lo e th1 th2
      (STEP: @Thread.step lo lang pf e th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (*(SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))*)
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  inv STEP; [inv STEP0|inv STEP0; inv LOCAL]; ss.
  - eapply promise_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
  - eapply write_step_promise_consistent; eauto.
  - eapply read_step_promise_consistent; eauto.
    eapply write_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
  - eapply fence_step_promise_consistent; eauto.
Qed.

Lemma opt_step_promise_consistent
      lang e th1 th2 lo
      (STEP: @Thread.opt_step lang lo e th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (*(SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))*)
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  inv STEP; eauto using step_promise_consistent.
Qed.

Lemma rtc_all_step_promise_consistent
      lang th1 th2 lo
      (STEP: rtc (@Thread.all_step lang lo) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  revert_until STEP. induction STEP; auto. i.
  inv H. inv USTEP. exploit Thread.step_future; eauto. i. des.
  eapply step_promise_consistent; eauto.
Qed.

Lemma rtc_tau_step_promise_consistent
      lang th1 th2 lo
      (STEP: rtc (@Thread.tau_step lang lo) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2))
      (WF1: Local.wf (Thread.local th1) (Thread.memory th1))
      (SC1: Memory.closed_timemap (Thread.sc th1) (Thread.memory th1))
      (MEM1: Memory.closed (Thread.memory th1)):
  Local.promise_consistent (Thread.local th1).
Proof.
  eapply rtc_all_step_promise_consistent; cycle 1; eauto.
  eapply rtc_implies; [|eauto].
  intros. inv H; econstructor; eauto.
Qed.

Lemma rtc_reserve_step_promise_consistent
      lang th1 th2 lo
      (STEPS: rtc (@Thread.reserve_step lang lo) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2)):
  Local.promise_consistent (Thread.local th1).
Proof.
  ginduction STEPS; eauto. i. eapply IHSTEPS in CONS.
  inv H. inv STEP. inv LOCAL. inv PROMISE. ss.
  ii. eapply Memory.add_get1 in PROMISE; eauto.
Qed.

Lemma rtc_cancel_step_promise_consistent
      lang th1 th2 lo
      (STEPS: rtc (@Thread.cancel_step lang lo) th1 th2)
      (CONS: Local.promise_consistent (Thread.local th2)):
  Local.promise_consistent (Thread.local th1).
Proof.
  ginduction STEPS; eauto. i. eapply IHSTEPS in CONS.
  inv H. inv STEP. inv LOCAL. inv PROMISE. ss.
  ii. dup PROMISE. eapply Memory.remove_get1 in PROMISE; eauto. des; eauto.
  clarify. eapply Memory.remove_get0 in PROMISES. des. clarify.
Qed.

Lemma rtc_reserve_step_promise_consistent2
      lang (th1 th2: Thread.t lang) lo
      (CONS: Local.promise_consistent (Thread.local th1))
      (STEPS: rtc (@Thread.reserve_step lang lo) th1 th2)
  :
    Local.promise_consistent (Thread.local th2).
Proof.
  ginduction STEPS; eauto.  i. eapply IHSTEPS.
  inv H. inv STEP. inv LOCAL. inv PROMISE. ss.
  ii. erewrite Memory.add_o in PROMISE; eauto. des_ifs.
  eapply CONS; eauto.
Qed.

Lemma rtc_cancel_step_promise_consistent2
      lang (th1 th2: Thread.t lang) lo
      (CONS: Local.promise_consistent (Thread.local th1))
      (STEPS: rtc (@Thread.cancel_step lang lo) th1 th2)
  :
    Local.promise_consistent (Thread.local th2).
Proof.
  ginduction STEPS; eauto.  i. eapply IHSTEPS.
  inv H. inv STEP. inv LOCAL. inv PROMISE. ss.
  ii. erewrite Memory.remove_o in PROMISE; eauto. des_ifs.
  eapply CONS; eauto.
Qed.

Lemma consistent_promise_consistent
      lang th lo
      (CONS: @Thread.consistent lang th lo)
      (WF: Local.wf (Thread.local th) (Thread.memory th))
      (SC: Memory.closed_timemap (Thread.sc th) (Thread.memory th))
      (MEM: Memory.closed (Thread.memory th)):
  Local.promise_consistent (Thread.local th).
Proof.
  destruct th. ss.
  exploit Memory.cap_exists; eauto. i. des.
  exploit Memory.cap_closed; eauto. i.
  exploit Local.cap_wf; eauto. i.
  exploit Memory.max_concrete_timemap_exists; try apply x0. i. des.
  hexploit Memory.max_concrete_timemap_closed; eauto. i.
  exploit CONS; eauto. s. i. des.
  hexploit rtc_tau_step_promise_consistent; try exact STEPS; eauto.
  ii. rewrite PROMISES, Memory.bot_get in *. congr.
Qed.

Lemma promise_consistent_promise_read
      lc1 mem1 loc to val ord released lc2
      f t v r lo
      (STEP: Local.read_step lc1 mem1 loc to val released ord lc2 lo)
      (PROMISE: Memory.get loc t (Local.promises lc1) = Some (f, Message.concrete v r))
      (CONS: Local.promise_consistent lc2):
  Time.lt to t.
Proof.
  inv STEP. exploit CONS; eauto. s. i.
  apply TimeFacts.join_lt_des in x. des.
  apply TimeFacts.join_lt_des in AC. des.
  revert BC0. unfold View.singleton_ur_if. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - unfold TimeMap.singleton, LocFun.add. condtac; ss.
Qed.

Lemma promise_consistent_promise_write
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      f t v r lo
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind lo)
      (PROMISE: Memory.get loc t (Local.promises lc1) = Some (f, Message.concrete v r))
      (CONS: Local.promise_consistent lc2):
  Time.le to t.
Proof.
  destruct (Memory.get loc t (Local.promises lc2)) as [[]|] eqn:X.
  - inv STEP. inv WRITE. ss.
    dup X. revert X0.
    erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
    exploit Memory.promise_get1_promise; try exact PROMISE; eauto.
    { inv PROMISE0; ss. }
    i. des. inv MSG_LE.
    rewrite X0 in *. inv GET.
    exploit CONS; eauto. i. ss.
    apply TimeFacts.join_lt_des in x. des.
    left. revert BC. unfold TimeMap.singleton, LocFun.add. condtac; ss.
  - inv STEP. inv WRITE.
    exploit Memory.promise_get1_promise; eauto.
    { inv PROMISE0; ss. }
    i. des. inv MSG_LE.
    exploit fulfill_unset_promises; eauto. i. des. subst. refl.
Qed.

Hint Resolve read_step_promise_consistent write_step_promise_consistent promise_step_promise_consistent:
  solve_promise_consistent.

Lemma promise_consistent_prsv_thread_nprm_step:
  forall n lang lo (e e': Thread.t lang)
         (CLOSED_MEM: Memory.closed (Thread.memory e))
         (LOCAL_WF: Local.wf (Thread.local e) (Thread.memory e))
         (NPRM_STEPS: rtcn (@Thread.nprm_step lang lo) n e e')
         (CONS: Local.promise_consistent (Thread.local e')),
    Local.promise_consistent (Thread.local e).
Proof.
  induction n; intros.
  - inv NPRM_STEPS; eauto.
  - inv NPRM_STEPS.
    inv A12.
    {
      (* program step *)
      des.
      inv PROG; simpls.
      Ltac solve_not_sc_fence A IHn:=
        eapply IHn in A; eauto with solve_promise_consistent.

      inv LOCAL.
      {
        (* silent *)
        solve_not_sc_fence A23 IHn.
      }
      {
        (* read *)
        solve_not_sc_fence A23 IHn.
        simpl.
        eapply local_wf_read; eauto.
      }
      {
        (* write *)
        solve_not_sc_fence A23 IHn; simpl.
        eapply write_step_closed_mem; eauto.
        eapply local_wf_write; eauto.
      }
      {
        (* update *)
        solve_not_sc_fence A23 IHn; simpl.
        eapply write_step_closed_mem with (releasedr := releasedr); eauto.
        inv LOCAL1.
        eapply closed_mem_implies_closed_msg; eauto.
        eapply local_wf_read; eauto.
        eapply local_wf_upd; eauto.
      }
      {
        (* fence *)
        destruct (Ordering.le Ordering.seqcst ordw) eqn:SEQCST.
        {
          (* sc fence *)
          destruct ordw; simpls.
          inv LOCAL0.
          eapply Local.bot_promise_consistent.
          exploit PROMISES; eauto.
        }
        {
          (* not sc fence *)
          solve_not_sc_fence A23 IHn; simpl.
          eapply fence_step_promise_consistent; eauto.
          inv LOCAL0.
          eapply local_wf_fence_not_seqcst; eauto.
          destruct lc1; eauto.
        }
      }
      {
        ss.
      }
    }
    {
      (* cancel step *)
      inv PF. ss.
      destruct kind; ss.
      destruct msg1; ss.
      solve_not_sc_fence A23 IHn; eauto; simpl.
      inv LOCAL.
      inv PROMISE.
      eapply Memory.lower_closed; eauto.
      inv LOCAL.
      eapply local_wf_promise; eauto.
      destruct lc1; eauto.
      inv LOCAL; simpls.
      inv PROMISE; ss.
      solve_not_sc_fence A23 IHn; eauto; simpl.
      eapply Memory.cancel_closed; eauto.
      eapply local_wf_promise; eauto.
      destruct lc1; eauto.
    }
Qed.

Lemma read_promise_not_consistent
      lc mem loc from to msg lc' mem' kind loc0 to0 val0 released ord lc'' lo
      (PROMISE: Local.promise_step lc mem loc from to msg lc' mem' kind)
      (LOCAL: Local.read_step lc' mem' loc0 to0 val0 released ord lc'' lo)
      (CONS: Local.promise_consistent lc''):
  (loc, to) <> (loc0, to0).
Proof.
  intro CONTR; inv CONTR.
  inv PROMISE.
  cut(Memory.op_kind_is_cancel kind = false); ii.
  eapply Memory.promise_get2 in PROMISE0; eauto.
  des.
  dup LOCAL.
  inv LOCAL0; ss.
  rewrite GET_MEM in GET. inv GET.
  eapply promise_consistent_promise_read in LOCAL; eauto.
  eapply Time.lt_strorder in LOCAL; eauto.
  destruct (Memory.op_kind_is_cancel kind) eqn:IS_CCL; eauto.
  destruct kind; ss.
  inv PROMISE0.
  eapply Memory.remove_get0 in MEM; des.
  inv LOCAL; ss.
  rewrite GET0 in GET1; ss.
Qed.


Require Import Util LengthEq AllInRel Map SetOperations.
Require Import Var Val EqDec Computable Var Fresh Envs IL Annotation AppExpFree.
Require Import Liveness.Liveness LabelsDefined.
Require Import SimF Filter ReplaceIf ListToStmt.

Set Implicit Arguments.
Unset Printing Records.

Fixpoint compile s {struct s}
  : stmt  :=
  match s with
    | stmtLet x e s => stmtLet x e (compile s)
    | stmtIf x s t => stmtIf x (compile s) (compile t)
    | stmtApp l Y  =>
      let Y' := List.filter NotVar Y in
      let xl := @fresh_list var _
                           fresh
                           (list_union (List.map Ops.freeVars Y)) (length Y') in
      list_to_stmt xl Y' (stmtApp l (replace_if NotVar Y (Var ⊝ xl)))
    | stmtReturn x => stmtReturn x
    | stmtFun F t => stmtFun (List.map (fun Zs => (fst Zs, compile (snd Zs))) F) (compile t)
  end.

Instance SR : PointwiseProofRelationF params := {
   ParamRelFP G VL VL' :=   VL = VL' /\ length VL = length G;
   ArgRelFP E E' G Z Z' := Z = Z' /\ length Z = length G
}.

Lemma sim_EAE' r L L' V s
  : labenv_sim SimExt (sim r) SR (block_Z ⊝ L) L L'
    -> ❬L❭ = ❬L'❭
    -> sim r SimExt (L, V, s) (L',V, compile s).
Proof.
  revert_except s.
  sind s; destruct s; simpl; intros; simpl in * |- *.
  - destruct e.
    + eapply (sim_let_op il_statetype_F); eauto.
    + eapply (sim_let_call il_statetype_F); eauto.
  - eapply (sim_cond il_statetype_F); eauto.
  - case_eq (omap (op_eval V) (List.filter NotVar Y)); intros.
    + destruct (get_dec L (counted l)) as [[[bE bZ bs n]]|].
      * decide (length Y = length bZ).
        -- eapply sim_expansion_closed;
             [
             | eapply star2_refl
             | eapply list_to_stmt_correct;
               eauto using fresh_spec, fresh_list_nodup, fresh_list_spec
             ]; eauto.
           ++ eapply labenv_sim_app; eauto. simpl.
             intros; split; intros; eauto; dcr; subst.
             case_eq (omap (op_eval V) (List.filter IsVar Y)); intros.
             ** exploit (omap_filter_partitions _ _ _ H4 H1).
                intros; repeat cases; eauto.
                exists Yv; repeat split; eauto with len.
                erewrite omap_replace_if.
                --- rewrite <- H7; eauto.
                --- erewrite omap_op_eval_agree; eauto.
                    rewrite <-  update_with_list_agree';
                      eauto using fresh_spec, fresh_list_nodup,
                      fresh_list_spec with len.
                    eapply agree_on_incl.
                    symmetry.
                    eapply update_with_list_agree_minus; eauto.
                    eapply not_incl_minus. reflexivity.
                    symmetry.
                    eapply disj_2_incl.
                    eapply fresh_list_spec; eauto using fresh_spec.
                    eapply list_union_incl; intros; eauto with cset.
                    inv_get.
                    eapply incl_list_union; eauto using map_get_1.
                    eapply fresh_list_nodup; eauto using fresh_spec.
                --- erewrite omap_op_eval_agree; [ eapply H1 | | ].
                    Focus 2.
                    rewrite omap_lookup_vars;
                      eauto using fresh_list_nodup, fresh_spec with len.
                    eapply fresh_list_nodup; eauto using fresh_spec.
                    rewrite <-  update_with_list_agree';
                      eauto using fresh_spec, fresh_list_nodup,
                      fresh_list_spec with len. reflexivity.
                    eapply fresh_list_nodup; eauto using fresh_spec.
             ** exfalso. eapply omap_filter_none in H4. congruence.
           ++ eauto with len.
           ++ eapply fresh_list_nodup; eauto using fresh_spec.
           ++ eapply disj_2_incl.
             eapply fresh_list_spec; eauto using fresh_spec.
             eapply list_union_incl; intros; eauto with cset.
             inv_get. eapply incl_list_union; eauto using map_get_1.
        -- perr.
      * perr.
    + perr.
      erewrite omap_filter_none in def; eauto. congruence.
  - pno_step.
  - pone_step.
    left. eapply IH; eauto 20 with len.
    + rewrite List.map_app.
      eapply labenv_sim_extension_ptw; eauto with len.
      * intros; hnf; intros; inv_get; simpl in *; dcr; subst.
        get_functional. eapply IH; eauto 20 with len.
        rewrite List.map_app. eauto.
      * hnf; intros; simpl in *; subst; inv_get; simpl; eauto.
Qed.

Lemma sim_EAE V s
  : @sim _ statetype_F _ statetype_F bot3 SimExt (nil, V, s) (nil,V, compile s).
Proof.
  eapply sim_EAE'; eauto.
  eapply labenv_sim_nil.
Qed.

Lemma EAE_app_expfree s
  : app_expfree (compile s).
Proof.
  sind s; destruct s; simpl; eauto using app_expfree.
  - eapply list_to_stmt_app_expfree.
    intros.
    eapply replace_if_get_inv in H as [A [B [[C D]|[C D]]]].
    + dcr; subst; inv_get; eauto using isVar.
    + subst. cases in C; isabsurd. decide (isVar A); eauto.
      exfalso; eauto.
  - econstructor; intros; inv_get; eauto using app_expfree.
Qed.

Lemma EAE_paramsMatch_app Y'' L f Y Y'
  :  get L (counted f) (❬Y''❭ + ❬Y❭)
     -> disj (of_list Y') (list_union (Ops.freeVars ⊝ Y)
                                     ∪ list_union (Ops.freeVars ⊝ Y''))
     -> NoDupA _eq Y'
     -> ❬Y'❭ = ❬List.filter NotVar Y❭
     -> paramsMatch
         (list_to_stmt Y'
            (List.filter NotVar Y)
            (stmtApp f (Y'' ++ replace_if NotVar Y (Var ⊝ Y')))) L.
Proof.
  intros. general induction Y.
  - simpl. destruct Y'; isabsurd.
    econstructor; eauto with len.
  - simpl in *; cases.
    destruct Y'; isabsurd; simpl.
    econstructor.
    + rewrite cons_app. rewrite app_assoc.
      eapply IHY.
      * rewrite app_length; simpl. rewrite <- plus_assoc; eauto.
      * rewrite List.map_app. rewrite list_union_app.
        simpl in *.
        rewrite <- union_assoc.
        rewrite disj_app.
        split.
        eapply (disj_incl H0).
        eauto with cset.
        setoid_rewrite list_union_start_swap at 3.
        clear. cset_tac.
        hnf; intros. invt NoDupA.
        rewrite of_list_1 in H3.
        revert H4 H7 H3. clear. cset_tac.
      * eauto.
      * eauto.
    + rewrite cons_app, app_assoc.
      eapply IHY.
      * rewrite app_length; simpl. rewrite <- plus_assoc; eauto.
      * rewrite List.map_app. rewrite list_union_app.
        simpl in *.
        rewrite <- union_assoc.
        rewrite disj_app.
        split.
        eapply (disj_incl H0).
        eauto with cset.
        setoid_rewrite list_union_start_swap at 3.
        clear. cset_tac.
        eapply disj_2_incl; eauto.
        rewrite list_union_start_swap.
        clear; cset_tac.
      * eauto.
      * eauto.
Qed.

Lemma EAE_paramsMatch s L
  : paramsMatch s L
    -> paramsMatch (compile s) L.
Proof.
  intros.
  general induction H; simpl; eauto using paramsMatch.
  - eapply (EAE_paramsMatch_app nil); eauto.
    + simpl. eapply disj_2_incl.
      eapply fresh_list_spec; eauto using fresh_spec with cset.
      eauto with cset.
    + eapply fresh_list_nodup; eauto using fresh_spec.
    + eauto with len.
  - econstructor; intros; inv_get; rewrite !map_map in *; simpl; eauto.
Qed.

Lemma freeVars_filter_Var Y
  : list_union (Ops.freeVars ⊝ Y) [=]
               list_union (Ops.freeVars ⊝ List.filter NotVar Y)
               ∪ list_union (Ops.freeVars ⊝ List.filter IsVar Y).
Proof.
  general induction Y; simpl; norm_lunion; eauto with cset.
  - repeat cases; simpl; norm_lunion; try now (exfalso; eauto).
    + rewrite IHY. rewrite !union_assoc. reflexivity.
    + rewrite IHY. clear IHY n.
      cset_tac.
Qed.

Ltac norm_lunion :=
 repeat match goal with
      | [ |- context [ fold_left union ?A ?B ]] =>
        match B with
          | empty => fail 1
          | _ => rewrite (list_union_start_swap A B)
        end
      | [ H : context [ fold_left union ?A ?B ] |- _ ] =>
        match B with
          | empty => fail 1
          | _ => rewrite (list_union_start_swap A B) in H
        end
    end.

Ltac clr_prtct :=
        repeat match goal with
               | [ H : protected_setin_fnc _ _ |- _ ] => clear H
               | [ H : protected _ |- _ ] => clear H
               end.

Lemma freeVars_replaceIf Y (xl:list var) (Len:❬List.filter NotVar Y❭ = ❬xl❭)
      (Disj:disj (of_list xl) (list_union (Ops.freeVars ⊝ Y)))
  : list_union (Ops.freeVars ⊝ replace_if NotVar Y (Var ⊝ xl)) \ of_list xl
               [=] list_union (Ops.freeVars ⊝ List.filter IsVar Y).

Proof.
  rewrite freeVars_filter_Var in Disj.
  general induction Y; simpl in *; eauto with cset.
  - cset_tac.
  - do 2 cases; simpl in *; try now (exfalso; eauto).
    + destruct xl; simpl in *; clear_trivial_eqs;
      norm_lunion; simpl in *.
      * rewrite minus_dist_union.
        setoid_rewrite minus_minus_add at 2.
        rewrite IHY; eauto.
        -- revert Disj; clear; cset_tac.
        -- eapply disj_incl; eauto.
           eauto with cset.
           clear. cset_tac.
    + norm_lunion.
      rewrite minus_dist_union.
      rewrite (IHY (xl)); eauto.
      * revert Disj; clear; cset_tac.
      * eapply disj_incl; eauto.
        clear; cset_tac.
Qed.

Lemma EAE_freeVars s
  : freeVars (compile s) [=] freeVars s.
Proof.
  sind s; destruct s; simpl;
    try rewrite !IH; eauto with cset.
  - rewrite list_to_stmt_freeVars; eauto with len.
    + simpl.
      setoid_rewrite freeVars_filter_Var at 5.
      eapply eq_union_lr; eauto.
      rewrite freeVars_replaceIf; eauto.
      rewrite fresh_list_length; eauto.
      eapply fresh_list_spec, fresh_spec.
    + eapply disj_2_incl.
      eapply fresh_list_spec.
      eapply fresh_spec.
      setoid_rewrite freeVars_filter_Var at 2; eauto with cset.
  - eapply eq_union_lr; eauto.
    eapply list_union_eq; eauto with len.
    intros; inv_get; simpl.
    rewrite IH; eauto.
Qed.

(*
Fixpoint compile_live (LV:list (set var)) (s:stmt) (a:ann (set var)) : ann (set var) :=
  match s, a with
  | stmtLet x e s, ann1 lv an as a =>
    let an' := compile_live LV s an in
    ann1 (getAnn an' \ singleton x) an'
  | stmtIf e s t, ann2 lv ans ant =>
    let ans' := compile_live LV s ans in
    let ant' := compile_live LV t ant in
    ann2 (getAnn ans' ∪ getAnn ant') ans' ant'
  | stmtApp f Y, ann0 lv =>
    let lv := nth (counted f) LV ∅ in
    ann0 (list_union (Ops.freeVars ⊝ Y) ∪ lv)
  | stmtReturn e, ann0 lv => ann0 (Ops.freeVars e)
  | stmtFun F t, annF lv ans ant =>
    let ans' := zip (fun Zs a => compile_live (getAnn ⊝ ans ++ LV) (snd Zs) a) F ans in
    annF lv ans' (compile_live (getAnn ⊝ ans ++ LV) t ant)
  | _, a => a
  end.
*)

(*
Fixpoint live_for_stmts (Y:list op) (xl:list var) (lv:set var) : ann (set var) :=
  match Y, xl with
  | e::Y, x::xl =>
    let an' := live_for_stmts Y xl lv in
    ann1 (Ops.freeVars e ∪ (getAnn an' \ singleton x)) an'
  | _, _ => ann0 lv
  end.

Fixpoint compile_live (LV:list (set var)) (s:stmt) (a:ann (set var)) : ann (set var) :=
  match s, a with
  | stmtLet x e s, ann1 lv an as a => ann1 lv (compile_live LV s an)
  | stmtIf e s t, ann2 lv ans ant =>
    ann2 lv (compile_live LV s ans) (compile_live LV t ant)
  | stmtApp f Y, ann0 lv =>
    let lv_f := nth (counted f) LV ∅ in
    let Y' := (List.filter NotVar Y) in
    let xl := (fresh_list fresh (list_union (List.map Ops.freeVars Y)) (length Y')) in
    let lv' := list_union (Ops.freeVars ⊝ (List.filter IsVar Y)) ∪ of_list xl ∪ lv_f in
    setTopAnn (live_for_stmts Y' xl lv') lv
  | stmtReturn e, ann0 lv => ann0 lv
  | stmtFun F t, annF lv ans ant =>
    let ans' := zip (fun Zs a => compile_live (getAnn ⊝ ans ++ LV) (snd Zs) a) F ans in
    annF lv ans' (compile_live (getAnn ⊝ ans ++ LV) t ant)
  | _, a => a
  end.

Lemma compile_live_getAnn LV s a
  : getAnn (compile_live LV s a) [=] getAnn a.
Proof.
  general induction s; destruct a; simpl; eauto.
  rewrite getAnn_setTopAnn; eauto.
Qed.

Lemma incl_set_right (X : Type) `{H : OrderedType X} s t
  : s [=] t -> t ⊆ s.
Proof.
  intros. rewrite H0. reflexivity.
Qed.

Lemma EAE_live i ZL Lv s lv
  : live_sound i ZL Lv s lv
    -> live_sound i ZL Lv (compile s) (compile_live Lv s lv).
Proof.
  intros.
  general induction H; simpl;
    eauto 20 using live_sound, compile_live_getAnn.
  - econstructor; eauto; rewrite compile_live_getAnn; eauto.
  - econstructor; eauto; rewrite compile_live_getAnn; eauto.
  -
  - econstructor; eauto.
    + rewrite !map_map; simpl.
      eapply live_sound_monotone; eauto.
      eapply PIR2_get; intros; inv_get; eauto with len.
      rewrite map_zip in H5.
      eapply get_app_cases in H6. destruct H6; dcr; inv_get.
      rewrite get_app_lt in H5; eauto with len. inv_get.
      rewrite compile_live_getAnn. eauto.
      rewrite get_app_ge in H5; eauto with len.
      rewrite zip_length2 in H5; eauto. rewrite map_length in H7.
      rewrite H0 in H5. inv_get. eauto.
      rewrite zip_length2; eauto. rewrite map_length in H8. omega.
    + eauto with len.
    + intros; inv_get. simpl.
      rewrite !map_map; simpl.
      eapply live_sound_monotone; eauto.
      eapply PIR2_get; intros; inv_get; eauto with len.
      rewrite map_zip in H5.
      eapply get_app_cases in H8. destruct H8; dcr; inv_get.
      rewrite get_app_lt in H5; eauto with len. inv_get.
      rewrite compile_live_getAnn. eauto.
      rewrite get_app_ge in H5; eauto with len.
      rewrite zip_length2 in H5; eauto. rewrite map_length in H9.
      rewrite H0 in H5. inv_get. eauto.
      rewrite zip_length2; eauto. rewrite map_length in H10. omega.
    + intros; inv_get; simpl.
      exploit H3; eauto; dcr.
      destruct i; simpl in *; rewrite compile_live_getAnn; eauto.
    + rewrite compile_live_getAnn; eauto.
Qed.
*)


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

(* Inductive nat : Set :=  O : nat | S : forall ns:nat, nat. *)

Run TemplateProgram (genParamInd [] true true "Coq.Init.Datatypes.bool").
Run TemplateProgram (mkIndEnv "indTransEnv" ["Coq.Init.Datatypes.bool"]).

(*
Definition xx :=
(fix
 Coq_Init_Datatypes_nat_pmtcty_RR0_iso (tind tind₂ tind₂o : nat)
                                       (tind_R : Coq_Init_Datatypes_nat_pmtcty_RR0
                                                 tind tind₂)
                                       (tind_Ro :
                                        Coq_Init_Datatypes_nat_pmtcty_RR0
                                          tind tind₂o) {struct tind} :
   tind₂ = tind₂o :=
   match
     tind as tind0
     return
       (Coq_Init_Datatypes_nat_pmtcty_RR0 tind0 tind₂ ->
        Coq_Init_Datatypes_nat_pmtcty_RR0 tind0 tind₂o -> tind₂ = tind₂o)
   with
   | 0%nat =>
       match
         tind₂ as tind₂0
         return
           (forall tind₂o0 : nat,
            Coq_Init_Datatypes_nat_pmtcty_RR0 0 tind₂0 ->
            Coq_Init_Datatypes_nat_pmtcty_RR0 0 tind₂o0 -> tind₂0 = tind₂o0)
       with
       | 0%nat =>
           fun (tind₂o0 : nat)
             (tind_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 0)
             (tind_Ro0 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 tind₂o0) =>
           let Hexeq :=
             Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0_inv tind_R0
               (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 0 0 =>
                0%nat = tind₂o0)
               (match
                  tind₂o0 as tind₂o1
                  return
                    (Coq_Init_Datatypes_nat_pmtcty_RR0 0 tind₂o1 ->
                     0%nat = tind₂o1)
                with
                | 0%nat =>
                    fun tind_Ro1 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 0 =>
                    Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0_inv tind_Ro1
                      (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 0 0 =>
                       0%nat = 0%nat) (fiat (0%nat = 0%nat))
                | S o =>
                    fun tind_Ro1 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 (S o)
                    => match tind_Ro1 return (0%nat = S o) with
                       end
                end tind_Ro0) in
           Hexeq
       | S x =>
           fun (tind₂o0 : nat)
             (tind_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 (S x))
             (_ : Coq_Init_Datatypes_nat_pmtcty_RR0 0 tind₂o0) =>
           match tind_R0 return (S x = tind₂o0) with
           end
       end tind₂o
   | S x =>
       match
         tind₂ as tind₂0
         return
           (forall tind₂o0 : nat,
            Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) tind₂0 ->
            Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) tind₂o0 ->
            tind₂0 = tind₂o0)
       with
       | 0%nat =>
           fun (tind₂o0 : nat)
             (tind_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) 0)
             (_ : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) tind₂o0) =>
           match tind_R0 return (0%nat = tind₂o0) with
           end
       | S x0 =>
           fun (tind₂o0 : nat)
             (tind_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) (S x0))
             (tind_Ro0 : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) tind₂o0) =>
           let Hexeq :=
             Coq_Init_Datatypes_nat_pmtcty_RR0_constr_1_inv x x0 tind_R0
               (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) (S x0) =>
                S x0 = tind₂o0)
               (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 x x0 =>
                match
                  tind₂o0 as tind₂o1
                  return
                    (Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) tind₂o1 ->
                     S x0 = tind₂o1)
                with
                | 0%nat =>
                    fun tind_Ro1 : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) 0
                    => match tind_Ro1 return (S x0 = 0%nat) with
                       end
                | S o =>
                    fun
                      tind_Ro1 : Coq_Init_Datatypes_nat_pmtcty_RR0
                                   (S x) (S o) =>
                    Coq_Init_Datatypes_nat_pmtcty_RR0_constr_1_inv x o
                      tind_Ro1
                      (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 (S x) (S o)
                       => S x0 = S o)
                      (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 x (*x0*) o =>
                       fiat (S x0 = S o))
                end tind_Ro0) in
           Hexeq
       end tind₂o
   end tind_R tind_Ro).
   *)

Run TemplateProgram (genParamIndTotAll [] true "Coq.Init.Datatypes.bool").

(* functions wont work until we fully produce the goodness of inductives *)


(*
  This module defines the functional unit entries for floating
  point arithmetic.

  TODO: WARNING: check that the instructions set exceptions on invalid rounding modes.
*)
Require Import Vector.
Import VectorNotations.
Require Import Kami.AllNotations.
Require Import FpuKami.Definitions.
Require Import FpuKami.MulAdd.
Require Import FpuKami.Compare.
Require Import FpuKami.NFToIN.
Require Import FpuKami.INToNF.
Require Import FpuKami.Classify.
Require Import FpuKami.ModDivSqrt.
Require Import ProcKami.FU.
Require Import ProcKami.RiscvIsaSpec.Insts.Fpu.FpuFuncs.
Require Import List.
Import ListNotations.

Section Fpu.
  Context `{procParams: ProcParams}.
  Context `{fpuParams : FpuParams}.

  Open Scope kami_expr.

  Section ty.
    Variable ty : Kind -> Type.

    Definition FDivSqrtInput
      (sqrt : Bool @# ty)
      (_ : ContextCfgPkt @# ty)
      (context_pkt_expr : ExecContextPkt ## ty)
      :  inpK expWidthMinus2 sigWidthMinus2 ## ty
      := LETE context_pkt
           :  ExecContextPkt
           <- context_pkt_expr;
         RetE
           (STRUCT {
              "isSqrt" ::= sqrt;
              "nfA"    ::= bitToNF (fp_get_float Flen (#context_pkt @% "reg1"));
              "nfB"    ::= bitToNF (fp_get_float Flen (#context_pkt @% "reg2"));
              "round"  ::= rounding_mode (#context_pkt);
              "tiny"   ::= $$true
            } : inpK expWidthMinus2 sigWidthMinus2 @# ty).

    Definition FDivSqrtOutput (sem_out_pkt_expr : outK expWidthMinus2 sigWidthMinus2 ## ty)
      :  PktWithException ExecUpdPkt ## ty
      := LETE sem_out_pkt
           :  outK expWidthMinus2 sigWidthMinus2
                   <- sem_out_pkt_expr;
         LETC val1 : RoutedReg <- (STRUCT {
                                       "tag" ::= Const ty (natToWord RoutingTagSz FloatRegTag);
                                       "data"
                                       ::= (OneExtendTruncLsb Rlen
                                                              (pack (NFToBit (#sem_out_pkt @% "outNf")))
                                            : Bit Rlen @# ty)
                                  });
         LETC val2 : RoutedReg <- (STRUCT {
                               "tag"  ::= Const ty (natToWord RoutingTagSz FflagsTag);
                               "data" ::= (csr (#sem_out_pkt @% "exception") : Bit Rlen @# ty)
                                  });
         LETC fstVal
           :  ExecUpdPkt
           <- (noUpdPkt ty)
                @%["val1" <- (Valid #val1)]
                @%["val2" <- (Valid #val2)];
         RetE
           (STRUCT {
              "fst" ::= #fstVal;
              "snd" ::= Invalid
            } : PktWithException ExecUpdPkt @# ty).
  End ty.

  Definition FDivSqrt
    :  FUEntry
    := {|
         fuName := append "fdivsqrt" fpu_suffix;
         fuFunc
           := fun ty (sem_in_pkt_expr : inpK expWidthMinus2 sigWidthMinus2 ## ty)
                => LETE sem_in_pkt
                     :  inpK expWidthMinus2 sigWidthMinus2
                     <- sem_in_pkt_expr;
                   div_sqrt_expr (#sem_in_pkt);
         fuInsts
           := [
                {|
                  instName   := append "fdiv" fpu_suffix;
                  xlens      := xlens_all;
                  extensions := fpu_exts;
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal fmtField fpu_format_field;
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal rs3Field      ('b"00011")
                       ];
                  inputXform  := fun ty => FDivSqrtInput (ty := ty) ($$false);
                  outputXform := fun ty => FDivSqrtOutput (ty := ty);
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrs2 := true|><|hasFrd := true|>
                |};
                {|
                  instName   := append "fsqrt" fpu_suffix;
                  xlens      := xlens_all;
                  extensions := fpu_exts;
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal fmtField fpu_format_field;
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal rs2Field      ('b"00000");
                         fieldVal rs3Field      ('b"01011")
                       ];
                  inputXform  := fun ty => FDivSqrtInput (ty := ty) ($$true);
                  outputXform := fun ty => FDivSqrtOutput (ty := ty);
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrd := true|>
                |}
              ]
       |}.

  Close Scope kami_expr.

End Fpu.


Require Import HoareDef MutHeader MutF0 MutF1 SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.

Require Import HTactics ProofMode.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section SIMMODSEM.

  Context `{Σ: GRA.t}.

  Let W: Type := Any.t * Any.t.

  Let wf: _ -> W -> Prop :=
    mk_wf (fun (_: unit) _ _ => (True: iProp)%I).

  Ltac check_o :=
    match goal with
    | [ |- (gpaco8 _ _ _ _ _ _ _ ?o_src ?o_tgt _ _ _) ] =>
      pose o_src; pose o_tgt
    end.

  Theorem correct: refines2 [MutF0.F] [MutF1.F].
  Proof.
    eapply adequacy_local2. econs; ss.
    i. econstructor 1 with (wf:=wf) (le:=top2); et.
    { ss. }
    2: { exists tt. econs; ss; rr; uipropall. }
    econs; ss. init. harg. mDesAll.
    des; clarify. unfold fF, ccallU. steps. astart 10.
    force_r.
    { eapply mut_max_intrange. auto. } steps.
    destruct (dec (Z.of_nat x) 0%Z).
    - destruct x; ss. astop. steps. force_l. eexists. steps.
      hret _; ss.
    - destruct x; [ss|]. rewrite Nat2Z.inj_succ. steps.
      acatch. hcall _ _ with "*"; auto.
      { iPureIntro.
        replace (Z.succ (Z.of_nat x) - 1)%Z with (Z.of_nat x) by lia.
        esplits; et. lia. }
      { splits; ss; eauto with ord_step. }
      i. mDesAll. des; clarify.
      steps. astop. steps.
      force_l. eexists. steps.
      hret _; ss. iPureIntro. esplits; ss.
      f_equal. f_equal. lia.
      Unshelve. all: ss. all: try exact 0.
  Qed.

End SIMMODSEM.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import GenSem.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import RealParams.
Require Import GenSem.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import PrimSemantics.
Require Import CompatClightSem.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import AbstractMachine.Spec.
Require Import Locks.Spec.
Require Import MmioSPTWalk.Layer.
Require Import MmioSPTWalk.Spec.
Require Import RData.
Require Import Constants.
Require Import HypsecCommLib.

Local Open Scope Z_scope.

Section MmioSPTOpsSpec.

  Definition init_spt_spec (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    rely is_smmu index; rely is_smmu_cfg cbndx;
    if halt adt then Some adt else
    let id := SPT_ID in
    let cpu := curid adt in
    match id @ (lock adt) with
    | LockFalse =>
      let l := id @ (log adt) in
      let orac := id @ (oracle adt) in
      let l0 := orac cpu l in
      let spt0 := spts (shared adt) in
      let spt := CalSPT spt0 (orac cpu l) in
      let l' := TEVENT cpu (TSHARED (OPULL id)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) :: ((orac cpu l) ++ l) in
      let ttbr := SMMU_TTBR index cbndx in
      let spt' := spt {spt_pt: (spt_pt spt) # ttbr == (ZMap.init (0, 0))}
                      {spt_pgd_t: (spt_pgd_t spt) # ttbr == (ZMap.init false)}
                      {spt_pmd_t: (spt_pmd_t spt) # ttbr == (ZMap.init (ZMap.init false))} in

      let l'' := (TEVENT cpu (TTICKET REL_LOCK)) :: (TEVENT cpu (TSHARED (OSPT spt'))) :: l' in
      let adt' := adt {tstate: 1} {shared: (shared adt) {spts: spt'}} {log: (log adt) # id == l''} {lock: (lock adt) # id == LockFalse} in
      match H_CalLock l'' with
      | Some _ => Some adt'
      | _ => None
      end
    | _ => None
    end.

  Definition walk_spt_spec (cbndx: Z) (index: Z) (addr: Z64) (adt: RData) : option (RData * Z64) :=
    match addr with
    | VZ64 addr =>
      rely is_smmu index; rely is_smmu_cfg cbndx; rely is_smmu_addr addr;
      if halt adt then Some (adt, (VZ64 0)) else
      let id := SPT_ID in
      let cpu := curid adt in
      match id @ (lock adt) with
      | LockFalse =>
        let l := id @ (log adt) in
        let orac := id @ (oracle adt) in
        let l0 := orac cpu l in
        let spt0 := spts (shared adt) in
        let spt := CalSPT spt0 (orac cpu l) in
        let l' := TEVENT cpu (TSHARED (OPULL id)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) :: ((orac cpu l) ++ l) in
        let ttbr := SMMU_TTBR index cbndx in
        let pt := ttbr @ (spt_pt spt) in
        let gfn := addr / PAGE_SIZE in
        match ZMap.get gfn pt with
        | (pfn, pte) =>
          rely is_int64 pte;
          let l'' := (TEVENT cpu (TTICKET REL_LOCK)) :: (TEVENT cpu (TSHARED (OSPT spt))) :: l' in
          let adt' := adt {tstate: 1} {shared: (shared adt) {spts: spt}} {log: (log adt) # id == l''} {lock: (lock adt) # id == LockFalse} in
          match H_CalLock l'' with
          | Some _ => Some (adt', (VZ64 pte))
          | _ => None
          end
        end
      | _ => None
      end
    end.

  Definition map_spt_spec (cbndx: Z) (index: Z) (addr: Z64) (pte: Z64) (adt: RData) : option RData :=
    match addr, pte with
    | VZ64 addr, VZ64 pte =>
      rely is_smmu index; rely is_smmu_cfg cbndx; rely is_smmu_addr addr; rely is_int64 pte;
      if halt adt then Some adt else
      let id := SPT_ID in
      let cpu := curid adt in
      match id @ (lock adt) with
      | LockFalse =>
        let l := id @ (log adt) in
        let orac := id @ (oracle adt) in
        let l0 := orac cpu l in
        let spt0 := spts (shared adt) in
        let spt := CalSPT spt0 (orac cpu l) in
        let l' := TEVENT cpu (TSHARED (OPULL id)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) :: ((orac cpu l) ++ l) in
        match local_spt_map cbndx index addr pte spt with
        | Some (halt', spt') =>
          let l'' := (TEVENT cpu (TTICKET REL_LOCK)) :: (TEVENT cpu (TSHARED (OSPT spt'))) :: l' in
          let adt' := adt {halt: halt'} {tstate: if halt' then 0 else 1}
                          {shared: (shared adt) {spts: spt'}}
                          {log: (log adt) # id == (if halt' then l' else l'')}
                          {lock: (lock adt) # id == (if halt' then LockOwn true else LockFalse)} in
          match H_CalLock l'' with
          | Some _ => Some adt'
          | _ => None
          end
        | _ => None
        end
      | _ => None
      end
    end.

  Definition unmap_spt_spec (cbndx: Z) (index: Z) (addr: Z64) (adt: RData) : option (RData * Z64) :=
    match addr with
    | VZ64 addr =>
      rely is_smmu index; rely is_smmu_cfg cbndx; rely is_smmu_addr addr;
      if halt adt then Some (adt, (VZ64 0)) else
      let id := SPT_ID in
      let cpu := curid adt in
      match id @ (lock adt) with
      | LockFalse =>
        let l := id @ (log adt) in
        let orac := id @ (oracle adt) in
        let l0 := orac cpu l in
        let spt0 := spts (shared adt) in
        let spt := CalSPT spt0 (orac cpu l) in
        let l' := TEVENT cpu (TSHARED (OPULL id)) :: TEVENT cpu (TTICKET (WAIT_LOCK local_lock_bound)) :: ((orac cpu l) ++ l) in
        let ttbr := SMMU_TTBR index cbndx in
        let pt := ttbr @ (spt_pt spt) in
        let gfn := addr / PAGE_SIZE in
        match ZMap.get gfn pt with
        | (pfn, pte) =>
          rely is_int64 pte;
          match (if pte =? 0 then Some (false, spt) else local_spt_map cbndx index addr 0 spt) with
          | Some (halt', spt') =>
            let l'' := (TEVENT cpu (TTICKET REL_LOCK)) :: (TEVENT cpu (TSHARED (OSPT spt'))) :: l' in
            let adt' := adt {halt: halt'} {tstate: if halt' then 0 else 1}
                            {shared: (shared adt) {spts: spt'}}
                            {log: (log adt) # id == (if halt' then l' else l'')}
                            {lock: (lock adt) # id == (if halt' then LockOwn true else LockFalse)} in
            match H_CalLock l'' with
            | Some _ => Some (adt', (VZ64 (if halt' then 0 else pte)))
            | _ => None
            end
          | _ => None
          end
        end
      | _ => None
      end
    end.

End MmioSPTOpsSpec.

Section MmioSPTOpsSpecLow.

  Context `{real_params: RealParams}.

  Notation LDATA := RData.

  Notation LDATAOps := (cdata (cdata_ops := MmioSPTWalk_ops) LDATA).

  Definition init_spt_spec0 (cbndx: Z) (index: Z) (adt: RData) : option RData :=
    when adt1 == acquire_lock_spt_spec adt;
    when adt2 == clear_smmu_pt_spec cbndx index adt1;
    release_lock_spt_spec adt2.

  Definition walk_spt_spec0 (cbndx: Z) (index: Z) (addr: Z64) (adt: RData) : option (RData * Z64) :=
    when adt1 == acquire_lock_spt_spec adt;
    when' ret == walk_smmu_pt_spec cbndx index addr adt1;
    rely is_int64 ret;
    when adt2 == release_lock_spt_spec adt1;
    when' res == check64_spec (VZ64 ret) adt2;
    Some (adt2, VZ64 res).

  Definition map_spt_spec0 (cbndx: Z) (index: Z) (addr: Z64) (pte: Z64) (adt: RData) : option RData :=
    when adt1 == acquire_lock_spt_spec adt;
    when adt2 == set_smmu_pt_spec cbndx index addr pte adt1;
    release_lock_spt_spec adt2.

  Definition unmap_spt_spec0 (cbndx: Z) (index: Z) (addr: Z64) (adt: RData) : option (RData * Z64) :=
    when adt1 == acquire_lock_spt_spec adt;
    when' res == walk_smmu_pt_spec cbndx index addr adt1;
    rely is_int64 res;
    if res =? 0 then
      when adt2 == release_lock_spt_spec adt1;
      when' ret == check64_spec (VZ64 res) adt2;
      Some (adt2, VZ64 ret)
    else
      when adt2 == set_smmu_pt_spec cbndx index addr (VZ64 0) adt1;
      when adt3 == release_lock_spt_spec adt2;
      when' ret == check64_spec (VZ64 res) adt3;
      Some (adt3, VZ64 ret).

  Inductive init_spt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | init_spt_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' cbndx index
      (Hinv: high_level_invariant labd)
      (Hspec: init_spt_spec0 (Int.unsigned cbndx) (Int.unsigned index) labd = Some labd'):
      init_spt_spec_low_step s WB ((Vint cbndx)::(Vint index)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive walk_spt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | walk_spt_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' cbndx index addr res
      (Hinv: high_level_invariant labd)
      (Hspec: walk_spt_spec0 (Int.unsigned cbndx) (Int.unsigned index) (VZ64 (Int64.unsigned addr)) labd = Some (labd', (VZ64 (Int64.unsigned res)))):
      walk_spt_spec_low_step s WB ((Vint cbndx)::(Vint index)::(Vlong addr)::nil) (m'0, labd) (Vlong res) (m'0, labd').

  Inductive map_spt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | map_spt_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' cbndx index addr pte
      (Hinv: high_level_invariant labd)
      (Hspec: map_spt_spec0 (Int.unsigned cbndx) (Int.unsigned index) (VZ64 (Int64.unsigned addr)) (VZ64 (Int64.unsigned pte)) labd = Some labd'):
      map_spt_spec_low_step s WB ((Vint cbndx)::(Vint index)::(Vlong addr)::(Vlong pte)::nil) (m'0, labd) Vundef (m'0, labd').

  Inductive unmap_spt_spec_low_step `{StencilOps} `{Mem.MemoryModelOps} `{UseMemWithData mem}:
    sextcall_sem (mem := mwd LDATAOps) :=
  | unmap_spt_spec_low_intro s (WB: _ -> Prop) m'0 labd labd' cbndx index addr res
      (Hinv: high_level_invariant labd)
      (Hspec: unmap_spt_spec0 (Int.unsigned cbndx) (Int.unsigned index) (VZ64 (Int64.unsigned addr)) labd = Some (labd', (VZ64 (Int64.unsigned res)))):
      unmap_spt_spec_low_step s WB ((Vint cbndx)::(Vint index)::(Vlong addr)::nil) (m'0, labd) (Vlong res) (m'0, labd').

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModelX}.
    Context `{Hmwd: UseMemWithData mem}.

    Definition init_spt_spec_low: compatsem LDATAOps :=
      csem init_spt_spec_low_step (type_of_list_type (Tint32::Tint32::nil)) Tvoid.

    Definition walk_spt_spec_low: compatsem LDATAOps :=
      csem walk_spt_spec_low_step (type_of_list_type (Tint32::Tint32::Tint64::nil)) Tint64.

    Definition map_spt_spec_low: compatsem LDATAOps :=
      csem map_spt_spec_low_step (type_of_list_type (Tint32::Tint32::Tint64::Tint64::nil)) Tvoid.

    Definition unmap_spt_spec_low: compatsem LDATAOps :=
      csem unmap_spt_spec_low_step (type_of_list_type (Tint32::Tint32::Tint64::nil)) Tint64.

  End WITHMEM.

End MmioSPTOpsSpecLow.


Require Import List.
Require Import String.
Require Import ZArith.

Open Scope list_scope.
Open Scope string_scope.
Open Scope Z_scope.

Require Import StructTactics.
Require Import ImpSyntax.
Require Import ImpCommon.
Require Import ImpExprTransf.
Require Import ImpInterpNock.
Require Import ImpConstFold.

Require Import ImpEval.
Require Import ImpStep.
Require Import ImpSemanticsFacts.
Require Import ImpInterpProof.
Require Import ImpInterpNockProof.

Section PROOF.

Variable transf : expr -> expr.

Variable transf_fwd :
  forall s h e v,
    eval_e s h e v ->
    eval_e s h (transf e) v.

Variable transf_bwd :
  forall s h e v,
    eval_e s h (transf e) v ->
    eval_e s h e v \/
    (forall v', ~ eval_e s h e v').

Lemma transf_e_fwd :
  forall s h e v,
    eval_e s h e v ->
    eval_e s h (transf_e transf e) v.
Proof.
  induction e; simpl; intros;
    apply transf_fwd; auto.
  - on (eval_e _ _ _ _), invc.
    find_copy_apply_hyp_hyp. ee.
  - on (eval_e _ _ _ _), invc.
    do 2 find_copy_apply_hyp_hyp. ee.
  - on (eval_e _ _ _ _), invc.
    + find_copy_apply_hyp_hyp. ee.
    + find_copy_apply_hyp_hyp.
      eapply eval_len_s; eauto.
  - on (eval_e _ _ _ _), invc.
    + find_copy_apply_hyp_hyp. ee.
    + find_copy_apply_hyp_hyp.
      eapply eval_idx_s; eauto.
Qed.

Lemma transf_e_bwd :
  forall s h e v,
    eval_e s h (transf_e transf e) v ->
    eval_e s h e v \/
    (forall v', ~ eval_e s h e v').
Proof.
  induction e; simpl; intros;
    find_apply_hyp_hyp;
    on (or _ _), invc; auto.
  - on (eval_e _ _ _ _), inv.
    find_apply_hyp_hyp.
    on (or _ _), invc; auto.
    + left; ee.
    + right; unfold not in *; intros.
      on (eval_e _ _ _ _), inv. firstorder.
  - right; unfold not in *; intros.
    on (eval_e _ _ _ _), inv.
    eapply H0; eauto. ee.
    eapply transf_e_fwd; eauto.
  - on (eval_e _ _ _ _), invc.
    repeat find_apply_hyp_hyp.
    repeat on (or _ _), invc; auto.
    + left; ee.
    + right; unfold not in *; intros.
      on (eval_e _ _ _ _), inv. firstorder.
    + right; unfold not in *; intros.
      on (eval_e _ _ _ _), inv. firstorder.
    + right; unfold not in *; intros.
      on (eval_e _ _ _ _), inv. firstorder.
  - right; unfold not in *; intros.
    on (eval_e _ _ _ _), inv.
    eapply H0; eauto. ee.
    + eapply transf_e_fwd; eauto.
    + eapply transf_e_fwd; eauto.
  (* len and idx are copy paste *)
  - on (eval_e _ _ _ _), invc.
    + find_apply_hyp_hyp.
      on (or _ _), invc; auto.
      * left; ee.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
    + find_apply_hyp_hyp.
      on (or _ _), invc; auto.
      * left; eapply eval_len_s; eauto.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
  - right; unfold not in *; intros.
    on (eval_e _ _ _ _), inv.
    + eapply H0; eauto. ee.
      eapply transf_e_fwd; eauto.
    + eapply H0; eauto.
      eapply eval_len_s; eauto.
      eapply transf_e_fwd; eauto.
  - on (eval_e _ _ _ _), invc.
    + repeat find_apply_hyp_hyp.
      repeat on (or _ _), invc; auto.
      * left; ee.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
    + repeat find_apply_hyp_hyp.
      repeat on (or _ _), invc; auto.
      * left; eapply eval_idx_s; eauto.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
      * right; unfold not in *; intros.
        on (eval_e _ _ _ _), inv.
        firstorder. firstorder.
  - right; unfold not in *; intros.
    on (eval_e _ _ _ _), inv.
    + eapply H0; eauto. ee.
      * eapply transf_e_fwd; eauto.
      * eapply transf_e_fwd; eauto.
    + eapply H0; eauto.
      eapply eval_idx_s; eauto.
      * eapply transf_e_fwd; eauto.
      * eapply transf_e_fwd; eauto.
Qed.

Lemma transfs_e_fwd :
  forall s h es vs,
    evals_e s h es vs ->
    evals_e s h (List.map transf es) vs.
Proof.
  induction es; simpl; intros.
  - auto.
  - on (evals_e _ _ _ _), invc.
    find_apply_hyp_hyp. repeat ee.
Qed.

Lemma transfs_e_bwd :
  forall s h es vs,
    evals_e s h (List.map transf es) vs ->
    evals_e s h es vs \/
    (forall vs', ~ evals_e s h es vs').
Proof.
  induction es; simpl; intros.
  - auto.
  - on (evals_e _ _ _ _), invc.
    find_apply_hyp_hyp.
    on (or _ _), invc; auto.
    + find_apply_lem_hyp transf_bwd.
      on (or _ _), invc; auto.
      * left; ee.
      * right; unfold not in *; intros.
        on (evals_e _ _ _ _), invc.
        eapply H0; eauto.
    + right; unfold not in *; intros.
      on (evals_e _ _ _ _), invc.
      eapply H; eauto.
Qed.

Lemma locate_some_transf :
  forall env x f,
    locate env x = Some f ->
    locate (transf_env transf env) x =
      Some (transf_f transf f).
Proof.
  induction env; simpl; intros.
  - discriminate.
  - repeat break_match; subst.
    + congruence.
    + simpl in *. find_inversion. congruence.
    + simpl in *. find_inversion. congruence.
    + auto.
Qed.

Lemma locate_none_transf :
  forall env x,
    locate env x = None ->
    locate (transf_env transf env) x = None.
Proof.
  induction env; simpl; intros.
  - auto.
  - repeat break_match; subst.
    + congruence.
    + simpl in *. find_inversion. congruence.
    + simpl in *. find_inversion. congruence.
    + auto.
Qed.

Lemma transf_locate_some :
  forall env x f',
    locate (transf_env transf env) x = Some f' ->
    exists f,
      locate env x = Some f /\
      transf_f transf f = f'.
Proof.
  induction env; simpl; intros.
  - discriminate.
  - repeat break_match; subst.
    + find_inversion; repeat ee.
    + simpl in *; find_inversion; congruence.
    + simpl in *; find_inversion; congruence.
    + auto.
Qed.

Lemma transf_locate_none :
  forall env x,
    locate (transf_env transf env) x = None ->
    locate env x = None.
Proof.
  induction env; simpl; intros.
  - auto.
  - repeat break_match; subst.
    + congruence.
    + simpl in *. find_inversion. congruence.
    + simpl in *. find_inversion. congruence.
    + auto.
Qed.

Lemma transf_s_fwd :
  forall env s1 h1 p1 s2 h2 p2,
    step env
      s1 h1 p1
      s2 h2 p2 ->
    step (transf_env transf env)
      s1 h1 (transf_s transf p1)
      s2 h2 (transf_s transf p2).
Proof.
  induction 1; simpl; intros.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee.
    + find_apply_lem_hyp locate_some_transf; auto.
    + apply transfs_e_fwd; auto.
  - repeat ee.
    + find_apply_lem_hyp locate_none_transf; auto.
    + eapply transfs_e_fwd; eauto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
  - repeat ee; apply transf_e_fwd; auto.
Qed.

(* Need to slightly strengthen IH for env locate,
   and add lame equalities b/c prep_induction
   does not work well with sections(?). *)
Lemma transf_s_bwd' :
  forall env' s1 h1 p1' s2 h2 p2,
    step env'
      s1 h1 p1'
      s2 h2 p2 ->
  forall env p1,
    env' = transf_env transf env ->
    p1' = transf_s transf p1 ->
    (exists p,
      step env
        s1 h1 p1
        s2 h2 p
      /\ transf_s transf p = p2) \/
    (forall s2 h2 p,
      p1 <> Snop /\
      ~ step env
        s1 h1 p1
        s2 h2 p).
Proof.
  induction 1; intros; subst.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [left | right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      firstorder.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    repeat find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [|right].
    on (or _ _), invc; [left | right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      firstorder.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      firstorder.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    repeat find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [|right].
    on (or _ _), invc; [left | right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      firstorder.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      firstorder.
  - destruct p1; simpl in *; try discriminate.
    find_apply_lem_hyp transf_locate_some.
    break_exists; break_and.
    repeat find_inversion.
    repeat find_apply_lem_hyp transfs_e_bwd.
    on (or _ _), invc; [left |right].
    + destruct f0; simpl in *.
      repeat find_inversion. repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * firstorder.
  - destruct p1; simpl in *; try discriminate.
    find_apply_lem_hyp transf_locate_none.
    repeat find_inversion.
    repeat find_apply_lem_hyp transfs_e_bwd.
    on (or _ _), invc; [left |right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * firstorder.
  - destruct p0; simpl in *; try discriminate.
    repeat find_inversion.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [left | right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * firstorder.
  - destruct p0; simpl in *; try discriminate.
    repeat find_inversion.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [left | right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * firstorder.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [left | right].
    + repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * firstorder.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [left | right].
    + exists Snop; repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * firstorder.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    destruct p1_1; simpl in *; try discriminate.
    left; repeat ee.
  - destruct p0; simpl in *; try discriminate.
    repeat find_inversion.
    edestruct IHstep; eauto.
    + break_exists; break_and.
      left; repeat ee.
      subst; auto.
    + right; unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), inv; simpl in *.
      * inversion H.
      * eapply H0; eauto.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    destruct p1; simpl in *; try discriminate.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc; [left | right].
    + exists Snop; repeat ee.
    + unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), invc.
      * firstorder.
      * inv H11.
  - destruct p1; simpl in *; try discriminate.
    repeat find_inversion.
    edestruct IHstep; eauto.
    + break_exists; break_and.
      left; repeat ee.
      subst; auto.
    + right; unfold not in *; intros.
      split; [congruence | intros].
      on (step _ _ _ _ _ _ _), inv; simpl in *.
      * inversion H.
      * eapply H0; eauto.
Qed.

Lemma transf_s_bwd :
  forall env s1 h1 p1 s2 h2 p2,
    step (transf_env transf env)
      s1 h1 (transf_s transf p1)
      s2 h2 p2 ->
    (exists p,
      step env
        s1 h1 p1
        s2 h2 p
      /\ transf_s transf p = p2) \/
    (forall s2 h2 p,
      p1 <> Snop /\
      ~ step env
        s1 h1 p1
        s2 h2 p).
Proof.
  intros.
  eapply transf_s_bwd'; eauto.
Qed.

Lemma transfs_s_fwd :
  forall env s1 h1 p1 s2 h2 p2,
    step_star env
      s1 h1 p1
      s2 h2 p2 ->
    step_star (transf_env transf env)
      s1 h1 (transf_s transf p1)
      s2 h2 (transf_s transf p2).
Proof.
  induction 1.
  - repeat ee.
  - find_apply_lem_hyp transf_s_fwd.
    repeat ee.
Qed.

Inductive can_get_stuck :
  env -> store -> heap -> stmt -> Prop :=
| cgs_stuck :
    forall env s1 h1 p1,
      p1 <> Snop ->
      (forall s2 h2 p2,
        ~ step env
            s1 h1 p1
            s2 h2 p2) ->
      can_get_stuck env s1 h1 p1
| cgs_step :
    forall env s1 h1 p1 s2 h2 p2,
      step env
        s1 h1 p1
        s2 h2 p2 ->
      can_get_stuck env s2 h2 p2 ->
      can_get_stuck env s1 h1 p1.

Lemma transfs_s_bwd :
  forall env' s1 h1 p1' s2 h2 p2,
    step_star env'
      s1 h1 p1'
      s2 h2 p2 ->
  forall env p1,
    env' = transf_env transf env ->
    p1' = transf_s transf p1 ->
    (exists p,
      step_star env
        s1 h1 p1
        s2 h2 p
      /\ transf_s transf p = p2) \/
    can_get_stuck env s1 h1 p1.
Proof.
  induction 1; intros; subst.
  - left; repeat ee.
  - find_apply_lem_hyp transf_s_bwd.
    on (or _ _), invc.
    + break_exists; break_and.
      edestruct IHstep_star; eauto.
      * break_exists; break_and.
        left; repeat ee.
      * right. eapply cgs_step; eauto.
    + right. ee.
      * firstorder.
      * firstorder.
Qed.

Lemma transf_p_fwd :
  forall p v,
    steps_p p v ->
    steps_p (transf_p transf p) v.
Proof.
  destruct p; intros.
  on (steps_p _ _), invc. ee.
  change Snop
    with (transf_s transf Snop).
  eapply transfs_s_fwd; eauto.
Qed.

Inductive can_get_stuck_prog : prog -> Prop :=
| cgsp_body :
    forall funcs main ret,
      can_get_stuck funcs store_0 heap_0 main ->
      can_get_stuck_prog (Prog funcs main ret)
| cgsp_ret :
    forall funcs main ret s2 h2,
      step_star funcs
        store_0 heap_0 main
        s2 h2 Snop ->
      (forall v,
        ~ eval_e s2 h2 ret v) ->
      can_get_stuck_prog (Prog funcs main ret).

Lemma transf_p_bwd :
  forall p v,
    steps_p (transf_p transf p) v ->
    steps_p p v \/ can_get_stuck_prog p.
Proof.
  destruct p; intros.
  on (steps_p _ _), invc.
  find_eapply_lem_hyp transfs_s_bwd; eauto.
  on (or _ _), invc.
  - break_exists; break_and.
    destruct p; simpl in *; try discriminate.
    find_apply_lem_hyp transf_bwd.
    on (or _ _), invc.
    + left; ee.
    + right. eapply cgsp_ret; eauto.
  - right; ee.
Qed.

End PROOF.


From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import frac.
From cap_machine Require Export rules_base.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Lemma wp_jmp_success E pc_p pc_b pc_e pc_a w r w' :
    decodeInstrW w = Jmp r →
     isCorrectPC (WCap pc_p pc_b pc_e pc_a) →

     {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
         ∗ ▷ pc_a ↦ₐ w
         ∗ ▷ r ↦ᵣ w' }}}
       Instr Executable @ E
       {{{ RET NextIV;
           PC ↦ᵣ updatePcPerm w'
           ∗ pc_a ↦ₐ w
           ∗ r ↦ᵣ w' }}}.
  Proof.
    iIntros (Hinstr Hvpc ϕ) "(>HPC & >Hpc_a & >Hr) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ns l1 l2 nt) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr0 Hm]".
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %?; auto.
    iDestruct (@gen_heap_valid with "Hr0 HPC") as %?.
    iDestruct (@gen_heap_valid with "Hr0 Hr") as %Hr_r0.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iIntros "_".
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.
    unfold exec, exec_opt in Hstep. rewrite Hr_r0 /= in Hstep. simplify_pair_eq.

    iMod (@gen_heap_update with "Hr0 HPC") as "[Hr0 HPC]". iFrame.
    iApply "Hφ". by iFrame.
  Qed.

  Lemma wp_jmp_successPC E pc_p pc_b pc_e pc_a w :
    decodeInstrW w = Jmp PC →
     isCorrectPC (WCap pc_p pc_b pc_e pc_a) →

     {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
         ∗ ▷ pc_a ↦ₐ w }}}
       Instr Executable @ E
       {{{ RET NextIV;
           PC ↦ᵣ updatePcPerm (WCap pc_p pc_b pc_e pc_a)
           ∗ pc_a ↦ₐ w }}}.
  Proof.
    iIntros (Hinstr Hvpc ϕ) "(>HPC & >Hpc_a) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ns l1 l2 nt) "Hσ1 /=". destruct σ1; cbn.
    iDestruct "Hσ1" as "[Hr0 Hm]".
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %?; auto.
    iDestruct (@gen_heap_valid with "Hr0 HPC") as %Hr_PC.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iIntros "_".
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.
    unfold exec, exec_opt in Hstep. rewrite Hr_PC /= in Hstep. simplify_pair_eq.

    iMod (@gen_heap_update with "Hr0 HPC") as "[Hr0 HPC]". iFrame.
    iApply "Hφ". by iFrame.
  Qed.

End cap_lang_rules.


Require Import VST.floyd.base.
Require Import VST.floyd.assert_lemmas.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.nested_pred_lemmas.
Require Import VST.floyd.mapsto_memory_block.

Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.seplog.
Require Import RamifyCoq.msl_ext.log_normalize.
Require Import RamifyCoq.veric_ext.SeparationLogic.

Local Open Scope logic.

Module Mapsto.
Section Mapsto.

Definition empty_compspecs : compspecs.
Proof.
  refine (mkcompspecs (PTree.empty _) _ _ _).
  + constructor.
    - rewrite PTree.gempty in H; inv H.
    - rewrite PTree.gempty in H; inv H.
    - rewrite PTree.gempty in H; inv H.
    - rewrite PTree.gempty in H; inv H.
  + hnf; intros.
    rewrite PTree.gempty in H; inv H.
  + hnf; intros.
    rewrite PTree.gempty in H; inv H.
Defined.

Definition adr_conflict (sh: share) : val * type -> val * type -> bool :=
  fun a1 a2 =>
  if (dec_share_nonunit sh)
  then match a1, a2 with
       | (p1, t1), (p2, t2) =>
         if (pointer_range_overlap_dec p1 (BV_sizeof t1) p2 (BV_sizeof t2)) then true else false
       end
  else false.

Instance AA (sh: share) : AbsAddr (val * type) val.
  apply (mkAbsAddr (val * type) val (adr_conflict sh)); intros; unfold adr_conflict in *; destruct p1, p2.
  + destruct (pointer_range_overlap_dec v (BV_sizeof t) v0 (BV_sizeof t0)); subst;
    destruct (pointer_range_overlap_dec v0 (BV_sizeof t0) v (BV_sizeof t)); subst; auto;
    pose proof pointer_range_overlap_comm v (BV_sizeof t) v0 (BV_sizeof t0);
    tauto.
  + destruct (pointer_range_overlap_dec v (BV_sizeof t) v0 (BV_sizeof t0)); [| if_tac; auto].
    destruct (pointer_range_overlap_isptr _ _ _ _ p).
    destruct (zlt 0 (BV_sizeof t)).
    - assert (pointer_range_overlap v (BV_sizeof t) v (BV_sizeof t))
        by (apply pointer_range_overlap_refl; auto; omega).
      destruct (pointer_range_overlap_dec v (BV_sizeof t) v (BV_sizeof t)); [congruence | tauto].
    - apply pointer_range_overlap_non_zero in p.
      omega.
Defined.

Instance MSL sh: MapstoSepLog (AA sh) (fun pt v => let (p, t) := pt in mapsto sh t p v).
Proof.
  apply mkMapstoSepLog.
  intros [p t].
  apply exp_mapsto_precise.
Defined.

Instance sMSL (sh: share): StaticMapstoSepLog (AA sh) (fun pt v => let (p, t) := pt in mapsto sh t p v).
Proof.
  apply mkStaticMapstoSepLog.
  + intros [p t] v ?.
    unfold addr_empty in H. simpl in H. unfold adr_conflict in H.
    if_tac in H.
    - destruct (pointer_range_overlap_dec p (BV_sizeof t) p (BV_sizeof t)); [congruence |].
      unfold mapsto.
      destruct (access_mode t) eqn:?H; try apply FF_left.
      destruct (type_is_volatile t), p; try apply FF_left.
      assert (pointer_range_overlap (Vptr b i) (BV_sizeof t) (Vptr b i) (BV_sizeof t)); [| tauto].
      apply pointer_range_overlap_refl.
      * simpl; tauto.
      * eapply BV_sizeof_pos; eauto.
      * eapply BV_sizeof_pos; eauto.
    - apply mapsto_memory_block.mapsto_not_nonunit; auto.
  + intros [p1 t1] [p2 t2] v1 v2 ?.
    simpl in H; unfold adr_conflict in H.
    if_tac in H; [| congruence].
    apply mapsto_memory_block.mapsto_overlap with empty_compspecs; auto.
    apply pointer_range_overlap_BV_sizeof.
    destruct (pointer_range_overlap_dec p1 (BV_sizeof t1) p2 (BV_sizeof t2)); [auto | congruence].
  + intros [p1 t1] [p2 t2] ?.
    simpl in H; unfold adr_conflict in H.
    if_tac in H.
    1: {
     destruct (pointer_range_overlap_dec p1 (BV_sizeof t1) p2 (BV_sizeof t2)); [congruence |].
     destruct (pointer_range_overlap_dec p1 (@sizeof (PTree.empty _) t1) p2 (@sizeof (PTree.empty _) t2)).
      - apply pointer_range_overlap_sizeof with (sh0 := sh) in p.
        destruct p as [? | [? | ?]].
        * tauto.
        * eapply disj_derives; [exact H1 | apply derives_refl |].
          pose proof log_normalize.FF_disj.
          simpl in H2; apply H2.
        * eapply disj_derives; [apply derives_refl | exact H1 |].
          pose proof log_normalize.disj_FF.
          simpl in H2; apply H2.
      - apply @disj_mapsto_ with (PTree.empty _); auto.
    }
    1: {
      unfold mapsto_.
      simpl.
      eapply disj_derives.
      + apply exp_left; intro; apply mapsto_memory_block.mapsto_not_nonunit; auto.
      + apply exp_left; intro; apply mapsto_memory_block.mapsto_not_nonunit; auto.
      + apply (@emp_disj _ Nveric).
    }
Defined.

End Mapsto.
End Mapsto.

Module MemoryBlock.
Section MemoryBlock.

Definition adr_conflict (a1 a2 : val * Z) : bool :=
  match a1, a2 with
  | (p1, n1), (p2, n2) =>
    if (pointer_range_overlap_dec p1 n1 p2 n2) then true else false
  end.

Instance AA : AbsAddr (val * Z) unit.
  apply (mkAbsAddr (val * Z) unit adr_conflict); intros; unfold adr_conflict in *; destruct p1, p2.
  + destruct (pointer_range_overlap_dec v z v0 z0); subst;
    destruct (pointer_range_overlap_dec v0 z0 v z); subst; auto;
    pose proof pointer_range_overlap_comm v z v0 z0;
    tauto.
  + destruct (pointer_range_overlap_dec v z v0 z0); auto.
    destruct (pointer_range_overlap_isptr _ _ _ _ p).
    destruct (zlt 0 z).
    - assert (pointer_range_overlap v z v z)
        by (apply pointer_range_overlap_refl; auto; omega).
      destruct (pointer_range_overlap_dec v z v z); [congruence | tauto].
    - apply pointer_range_overlap_non_zero in p.
      omega.
Defined.

Instance MSL sh: MapstoSepLog AA (fun pn v => let (p, n) := pn in memory_block sh n p).
Proof.
  apply mkMapstoSepLog.
  intros [p n].
  rewrite exp_unit.
  apply memory_block_precise.
Defined.

Instance sMSL (sh: share) (H_non_unit: sepalg.nonunit sh): StaticMapstoSepLog AA (fun pn v => let (p, n) := pn in memory_block sh n p).
Proof.
  apply mkStaticMapstoSepLog.
  + intros [p n] v ?.
    unfold addr_empty in H; simpl in H.
    destruct (pointer_range_overlap_dec p n p n); [congruence |].
    rewrite memory_block_isptr.
    normalize.
    destruct p; try inversion Pp.
    destruct (zlt 0 n).
    - assert (pointer_range_overlap (Vptr b i) n (Vptr b i) n); [| tauto].
      apply pointer_range_overlap_refl; simpl; try tauto; omega.
    - change memory_block with mapsto_memory_block.memory_block.
      unfold mapsto_memory_block.memory_block.
      rewrite nat_of_Z_neg by omega.
      simpl.
      change (predicates_hered.andp
        (predicates_hered.prop (Int.unsigned i + n <= Int.modulus))
        predicates_sl.emp) with (!! (Int.unsigned i + n <= Int.modulus) && emp)%logic.
      apply andp_left2; auto.
  + intros [p1 n1] [p2 n2] _ _ ?.
    apply mapsto_memory_block.memory_block_overlap; auto.
    simpl in H.
    destruct (pointer_range_overlap_dec p1 n1 p2 n2); [auto | congruence].
  + intros [p1 n1] [p2 n2] ?.
    simpl in H.
    unfold mapsto_.
    rewrite !exp_unit.
    destruct (pointer_range_overlap_dec p1 n1 p2 n2); [congruence |].
    destruct (pointer_range_overlap_dec p1 n1 p2 n2); [tauto |].
    apply disj_memory_block; auto.
Defined.

End MemoryBlock.
End MemoryBlock.