Require Import Axioms CoqlibC Maps Iteration (* Errors *).
Require Import Integers Floats AST Linking.
Require Import ValuesC Memory Events Globalenvs Smallstep.
Require Import Machregs LocationsC Conventions Op LinearC.
Require Import Debugvar.
(** newly added **)
Require Export Debugvarproof.
Require Import Simulation.
Require Import Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem AsmregsC MatchSimModSem.
Require SimMemId.
Require SoundTop.
Require Import LiftDummy.

Set Implicit Arguments.

Definition strong_wf_tgt (st_tgt0: Linear.state): Prop :=
  exists sg_init ls_init, last_option (LinearC.get_stack st_tgt0) = Some (Linear.dummy_stack sg_init ls_init).

Section SIMMODSEM.

Variable skenv_link: SkEnv.t.
Variable sm_link: SimMem.t.
Variables prog tprog: program.
Let md_src: Mod.t := (LinearC.module prog).
Let md_tgt: Mod.t := (LinearC.module tprog).
Hypothesis (INCLSRC: SkEnv.includes skenv_link (Mod.sk md_src)).
Hypothesis (INCLTGT: SkEnv.includes skenv_link (Mod.sk md_tgt)).
Hypothesis (WF: SkEnv.wf skenv_link).
Hypothesis TRANSL: match_prog prog tprog.
Let ge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_src)) prog).
Let tge := (SkEnv.revive (SkEnv.project skenv_link (Mod.sk md_tgt)) tprog).
Definition msp: ModSemPair.t := ModSemPair.mk (md_src skenv_link) (md_tgt skenv_link) (SimSymbId.mk md_src md_tgt) sm_link.

Inductive match_states
          (idx: nat) (st_src0: Linear.state) (st_tgt0: Linear.state) (sm0: SimMem.t): Prop :=
| match_states_intro
    (MATCHST: Debugvarproof.match_states st_src0 st_tgt0)
    (MCOMPATSRC: (get_mem st_src0) = sm0.(SimMem.src))
    (MCOMPATTGT: (get_mem st_tgt0) = sm0.(SimMem.tgt))
    (DUMMYTGT: strong_wf_tgt st_tgt0).

Theorem make_match_genvs :
  SimSymbId.sim_skenv (SkEnv.project skenv_link (Mod.sk md_src))
                      (SkEnv.project skenv_link (Mod.sk md_tgt)) ->
  Genv.match_genvs (match_globdef (fun _ f tf => transf_fundef f = Errors.OK tf) eq prog) ge tge.
Proof. subst_locals. eapply SimSymbId.sim_skenv_revive; eauto. Qed.

Theorem sim_modsem: ModSemPair.sim msp.
Proof.
  eapply match_states_sim with (match_states := match_states) (match_states_at := top4) (sound_state := SoundTop.sound_state);
    eauto; ii; ss.
  - instantiate (1:= Nat.lt). apply lt_wf.
  - eapply SoundTop.sound_state_local_preservation.
  - (* init bsim *)
    inv INITTGT. destruct sm_arg; ss. clarify.
    inv SIMARGS; ss. clarify. inv TYP.
    exploit (fill_arguments_progress ls_init (typify_list vs_tgt (sig_args (fn_sig fd)))
                                     (Conventions1.loc_arguments (fn_sig fd))); eauto.
    { apply (f_equal (@length _)) in TYP0. rewrite map_length in *. etrans; try apply TYP0; eauto. }
    intro P; des.
    hexploit (@fill_arguments_spec); et. intro Q; des.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE. des.
    eexists. eexists (SimMemId.mk _ _). esplits; ss; cycle 1.
    + econs; eauto; ss.
      * rpapply match_states_call.
        { econs; eauto.
          - instantiate (1:= (dummy_stack (fn_sig fd) ls_init)). unfold dummy_stack, dummy_function.
            rpapply match_stackframe_intro; eauto; swap 1 2.
            + econs; eauto.
            + econs; eauto. ss. econs; eauto. econs; eauto.
            + ss. f_equal; ss.
              * instantiate (1:= None). instantiate (1:= None). ss.
              * instantiate (1:= None). instantiate (1:= None). ss.
          - econs; et.
        }
      * rr. esplits; ss; eauto.
    + inv SAFESRC. folder. inv TYP.
      exploit (Genv.find_funct_transf_partial_genv SIMGE); eauto. intro FINDFSRC; des; clarify.
      unfold transf_fundef; ss. unfold Errors.bind in *. des_ifs.
      econs; swap 1 3.
      { folder; ss. eauto. }
      all: ss.
      unfold transf_function in *. des_ifs.
  - (* init progress *)
    des. inv SAFESRC. inv SIMARGS; ss.
    exploit make_match_genvs; eauto. { apply SIMSKENV. } intro SIMGE.
    exploit (Genv.find_funct_match_genv SIMGE); eauto. i; des. ss. clarify. folder.
    inv TYP. unfold Errors.bind in *. des_ifs.
    destruct sm_arg; ss. clarify.
    exploit (Genv.find_funct_match_genv SIMGE); eauto. i; des. ss. clarify.
    exploit (fill_arguments_progress (Locmap.init Vundef) (typify_list vs_tgt (sig_args (fn_sig fd)))
                                     (Conventions1.loc_arguments (fn_sig fd))); eauto.
    { apply (f_equal (@length _)) in TYP0. rewrite map_length in *. etrans; try apply TYP0; eauto. }
    intro P; des.
    hexploit (fill_arguments_spec); eauto. intro Q; des.
    assert(SGEQ: fn_sig fd = fn_sig f).
    { unfold transf_function in *; des_ifs. }
    esplits; eauto. econs; swap 1 3.
    { ss. folder. eauto. }
    all: ss; eauto with congruence.
    + econs; ss; eauto with congruence.
  - (* call wf *)
    inv MATCH; ss. destruct sm0; ss. clarify.
    inv CALLSRC. inv MATCHST; ss.
  - (* call fsim *)
    inv MATCH; ss. destruct sm0; ss. clarify.
    inv CALLSRC. inv MATCHST; ss.
    folder. esplits; eauto.
    + econs; eauto.
      * folder. des.
        r in TRANSL. r in TRANSL.
        exploit (SimSymbId.sim_skenv_revive TRANSL); eauto.
        { apply SIMSKENV. }
        intro GE.
        apply (fsim_external_funct_id GE); ss.
    + econs; ss; eauto.
      * instantiate (1:= SimMemId.mk _ _). ss.
      * ss.
    + ss.
  - (* after fsim *)
    inv AFTERSRC. inv SIMRET; ss. exists sm_ret. destruct sm_ret; ss. clarify.
    inv MATCH; ss. inv MATCHST; ss. esplits; eauto.
    + econs; eauto.
    + econs; ss; eauto. econs; eauto.
      { inv H5; ss. - econs; eauto. - des_ifs. econs; eauto. inv H. econs; eauto. }
      { clear - DUMMYTGT. unfold strong_wf_tgt in *. des. destruct ts; ss. unfold dummy_stack, dummy_function in *. des_ifs; ss; clarify; esplits; et. }
  - (* final fsim *)
    inv MATCH. inv FINALSRC; inv MATCHST; ss.
    inv H3; ss. inv H4; ss. rr in DUMMYTGT. des. ss. clarify. destruct sm0; ss. clarify.
    eexists (SimMemId.mk _ _). esplits; ss; eauto.
    econs; ss; eauto. inv H1; ss. inv H2; ss.
  - left; i. esplits; eauto.
    { apply modsem_receptive; et. }
    inv MATCH.
    ii. rr in STEPSRC. des. hexploit (@transf_step_correct prog skenv_link); eauto.
    { inv SIMSKENV. ss. }
    { apply make_match_genvs; eauto. apply SIMSKENV. }
    i; des.
    exploit (lift_plus Linear.step (fun st => get_stack st <> []) strong_wf_tgt); ss; et.
    { intros st X Y. rr in X. des. rewrite Y in *. ss. }
    { i. folder. unfold strong_wf_tgt in *. des. inv HSTEP; ss; eauto.
      - des_ifs; ss; eauto.
      - des_ifs; ss; eauto. right. ii. inv HSTEP0; ss. }
    { ii. unfold strong_wf_tgt in *; des. inv HSTEP; try inv STACKS; ss; clarify; et; des_ifs; et. }
    { intro T. inv H0; ss; clarify; try inv STACKS; ss; try inv H1; ss. }
    intro TT; des.
    esplits; eauto.
    * left. eapply ModSemProps.spread_dplus; eauto.
      { eapply modsem_determinate; eauto. }
    * instantiate (1:= SimMemId.mk _ _). econs; ss.
Unshelve.
  all: ss; try (by econs).
Qed.

End SIMMODSEM.

Section SIMMOD.

Variables prog tprog: program.
Hypothesis TRANSL: match_prog prog tprog.
Definition mp: ModPair.t := SimSymbId.mk_mp (LinearC.module prog) (LinearC.module tprog).

Theorem sim_mod: ModPair.sim mp.
Proof.
  econs; ss.
  - r. eapply Sk.match_program_eq; eauto.
    ii. destruct f1; ss.
    + clarify. right. unfold Errors.bind, transf_function in *. des_ifs. esplits; eauto.
    + clarify. left. esplits; eauto.
  - ii. inv SIMSKENVLINK. eapply sim_modsem; eauto.
Qed.

End SIMMOD.


(* Mostly taken form https://github.com/sigurdschneider/lvc/blob/23b7fa8cd0640503ff370144fb407192632f9cc6/Infra/AutoIndTac.v *)

(* fail 1 will break from the 'match H with', and indicate to
   the outer match that it should consider finding another
   hypothesis, see documentation on match goal and fail
   This tactic is a variation of Tobias Tebbi's revert_except_until *)

Ltac revert_all :=
  repeat match goal with [ H : _ |- _ ] => revert H end.

Tactic Notation "revert" "all" := revert_all.

Ltac revert_except i :=
  repeat match goal with [ H : _ |- _ ] => tryif unify H i then fail else revert H end.

Tactic Notation "revert" "all" "except" ident(i) := revert_except i.

Ltac clear_except i :=
  repeat match goal with [ H : _ |- _ ] => tryif unify H i then fail else clear H end.

Tactic Notation "clear" "all" "except" ident(i) := clear_except i.

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

(*
(* succeed if H has a function type, fail otherwise *)
Ltac is_ftype H :=
  let t := type of H in
    let t' := eval cbv in t in
      match t' with
        | _ -> _ => idtac
      end.
*)
(* match on the type of E and remember each of it's arguments
   that is not a variable by calling tac.
   tac needs to do a remember exactly if x is not a var, and
   fail otherwise. (We need to fail, otherwise the repeat will
   stop prematurely)
   try will silently ignore a fail 0, but will fail if a fail 1 or
   above occurs. Sequentialization makes sure fail 1 is executed
   if is_var is successful, hence try (is_var x; fail 1) will
   fail exactly when x is a var. *)

Ltac remember_arguments E :=
  let tac x := (try (is_var x; fail 1); (*try (is_ftype x; fail 1);*) remember (x)) in
  repeat (match type of E with
    | ?t ?x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ _ => tac x
    | ?t ?x _ _ _ _ => tac x
    | ?t ?x _ _ _ => tac x
    | ?t ?x _ _ => tac x
    | ?t ?x _ => tac x
    | ?t ?x => tac x
  end).

(* from Coq.Program.Tactics *)
Ltac clear_dup :=
  match goal with
    | [ H : ?X |- _ ] =>
      match goal with
        | [ H' : ?Y |- _ ] =>
          match H with
            | H' => fail 2
            | _ => unify X Y ; (clear H' || clear H)
          end
      end
  end.

Ltac inv_eqs :=
  repeat (match goal with
              | [ H : @eq _ ?x ?x |- _ ] => fail (* nothing to do on x = x *)
              | [ H : @eq _ ?x ?y |- _ ] => progress (inversion H; subst; try clear_dup)
            end).

(* this is a standard tactic *)
Ltac clear_trivial_eqs :=
  repeat (progress (match goal with
              | [ H : @eq _ ?x ?x |- _ ] => clear H
            end)).

Tactic Notation "general" "induction" hyp(H) :=
  remember_arguments H; revert_except H;
  induction H; intros; (try inv_eqs); (try clear_trivial_eqs).

(* Module Test. *)
(* Require Import List. *)

(* Inductive decreasing : list nat -> Prop := *)
(*   | base : decreasing nil *)
(*   | step m n L : decreasing (n::L) -> n <= m -> decreasing (m :: n :: L). *)

(* Lemma all_zero_by_hand L *)
(*   : decreasing (0::L) -> forall x, In x L -> x = 0. *)
(* Proof. *)
(*   intros. remember (0::L). *)
(*   revert dependent L. revert x. induction H; intros. *)
(*   inversion Heql. *)
(*   inversion Heql. subst. inversion H0; subst; firstorder. *)
(* Qed. *)

(* Lemma all_zero L *)
(*   : decreasing (0::L) -> forall x, In x L -> x = 0. *)
(* Proof. *)
(*   intros. general induction H.  *)
(*   inversion H0; subst; firstorder. *)
(* Qed. *)
(* End Test. *)


Require Export P04.

(** **** Problem #2 : 1 star, optional (hd_opt_poly) *)
(** Complete the definition of a polymorphic version of the
    [hd_opt] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_opt {X : Type} (l : list X)  : option X :=
  match l with
  | nil => None
  | a :: l' => Some a
  end.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_opt2 :   hd_opt  [[1];[2]]  = Some [1].
Proof. reflexivity. Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef1.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_unmap2_spec (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level with
    | VZ64 map_addr, VZ64 level =>
      rely is_int64 map_addr; rely (level >=? 3); rely GRANULE_ALIGNED map_addr; rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      rely (peq (base g_rd) ginfo_loc);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx; rely is_gidx root_gidx;
      when adt == query_oracle adt;
      let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
      (* hold root lock *)
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
      rely (gtype groot =? GRANULE_STATE_TABLE);
      (* walk deeper root *)
      let entry0 := (g_data (gnorm groot)) @ idx0 in
      rely is_int64 entry0;
      let phys0 := __entry_to_phys entry0 3 in
      let lv1_gidx := __addr_to_gidx phys0 in
      if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
        (* level 1 valid, hold level 1 lock *)
        let glv1 := (gs (share adt)) @ lv1_gidx in
        rely prop_dec (glock glv1 = None);
        rely (tbl_level (gaux glv1) =? 1);
        (* walk deeper level 1 *)
        rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
        rely (gtype glv1 =? GRANULE_STATE_TABLE);
        let entry1 := (g_data (gnorm glv1)) @ idx1 in
        rely is_int64 entry1;
        let phys1 := __entry_to_phys entry1 3 in
        let lv2_gidx := __addr_to_gidx phys1 in
        if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
          (* level 2 valid, hold level 2 lock *)
          let glv2 := (gs (share adt)) @ lv2_gidx in
          rely (tbl_level (gaux glv2) =? 2);
          rely prop_dec (glock glv2 = None);
          if level =? 3 then
            (* walk until level 2 *)
            let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
            unmap_table lv2_gidx idx2 level map_addr adt
          else
            (* walk deeper level 2 *)
            rely (g_tag (ginfo glv2) =? GRANULE_STATE_TABLE);
            rely (gtype glv2 =? GRANULE_STATE_TABLE);
            let entry2 := (g_data (gnorm glv2)) @ idx2 in
            rely is_int64 entry2;
            let phys2 := __entry_to_phys entry2 3 in
            let lv3_gidx := __addr_to_gidx phys2 in
            if (__entry_is_table entry2) && (GRANULE_ALIGNED phys2) && (is_gidx lv3_gidx) then
              (* level 2 valid, hold level 2 lock *)
              let adt := adt {log: EVT CPU_ID (REL lv2_gidx glv2 {glock: Some CPU_ID}) :: EVT CPU_ID (ACQ lv3_gidx) :: log adt} in
              let glv3 := (gs (share adt)) @ lv3_gidx in
              rely prop_dec (glock glv3 = None);
              rely (tbl_level (gaux glv3) =? 3);
              if level =? 4 then
                (* walk until level 3 *)
                let adt :=  adt {priv: (priv adt) {wi_llt: lv3_gidx} {wi_index: idx3}} in
                unmap_table lv3_gidx idx3 level map_addr adt
              else (* can't be other level *)
                None
            else
              (* level 3 invalid *)
              Some (adt {log: EVT CPU_ID (REL lv2_gidx glv2 {glock: Some CPU_ID}) :: log adt}
                        {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
        else
          (* level 2 invalid *)
          Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
      else
        (* level 1 invalid *)
        Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
  end.

End Spec.