(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory ArchUserOp_IF
imports UserOp_IF
begin

context Arch begin global_naming ARM

definition ptable_lift_s where
  "ptable_lift_s s \<equiv> ptable_lift (cur_thread s) s"

definition ptable_rights_s where
  "ptable_rights_s s \<equiv> ptable_rights (cur_thread s) s"

(* FIXME: move to ADT_AI.thy *)
definition ptable_attrs :: "obj_ref \<Rightarrow> 'z state \<Rightarrow> word32 \<Rightarrow> vm_attributes" where
 "ptable_attrs tcb s \<equiv>
    \<lambda>addr. case_option {} (fst o snd o snd)
             (get_page_info (\<lambda>obj. get_arch_obj (kheap s obj))
                            (get_pd_of_thread (kheap s) (arch_state s) tcb) addr)"

definition ptable_attrs_s :: "'z state \<Rightarrow> obj_ref \<Rightarrow> vm_attributes" where
 "ptable_attrs_s s \<equiv> ptable_attrs (cur_thread s) s"

definition ptable_xn_s where
  "ptable_xn_s s \<equiv>  \<lambda>addr. XNever \<in> ptable_attrs_s s addr"

definition getExMonitor :: "exclusive_monitors machine_monad" where
  "getExMonitor \<equiv> gets exclusive_state"

definition setExMonitor :: "exclusive_monitors \<Rightarrow> unit machine_monad" where
  "setExMonitor es \<equiv> modify (\<lambda>ms. ms\<lparr>exclusive_state := es\<rparr>)"


type_synonym user_state_if = "user_context \<times> user_mem \<times> device_state \<times> exclusive_monitors"

text \<open>
  A user transition gives back a possible event that is the next
  event the user wants to perform
\<close>
type_synonym user_transition_if =
  "obj_ref \<Rightarrow> vm_mapping \<Rightarrow> mem_rights \<Rightarrow> (obj_ref \<Rightarrow> bool) \<Rightarrow>
   user_state_if \<Rightarrow> (event option \<times> user_state_if) set"

definition do_user_op_if ::
  "user_transition_if \<Rightarrow> user_context \<Rightarrow> (event option \<times> user_context,'z::state_ext) s_monad" where
  "do_user_op_if uop tc =
   do
      \<comment> \<open>Get the page rights of each address (ReadOnly, ReadWrite, None, etc).\<close>
      pr \<leftarrow> gets ptable_rights_s;

      \<comment> \<open>Fetch the 'execute never' bits of the current thread's page mappings.\<close>
      pxn \<leftarrow> gets (\<lambda>s x. pr x \<noteq> {} \<and> ptable_xn_s s x);

      \<comment> \<open>Get the mapping from virtual to physical addresses.\<close>
      pl \<leftarrow> gets (\<lambda>s. restrict_map (ptable_lift_s s) {x. pr x \<noteq> {}});

      allow_read \<leftarrow> return  {y. EX x. pl x = Some y \<and> AllowRead \<in> pr x};
      allow_write \<leftarrow> return  {y. EX x. pl x = Some y \<and> AllowWrite \<in> pr x};

      \<comment> \<open>Get the current thread.\<close>
      t \<leftarrow> gets cur_thread;

      \<comment> \<open>Generate user memory by throwing away anything from global
         memory that the user doesn't have access to. (The user must
         have both (1) a mapping to the page; (2) that mapping has the
         AllowRead right.\<close>
      um \<leftarrow> gets (\<lambda>s. (user_mem s) \<circ> ptrFromPAddr);
      dm \<leftarrow> gets (\<lambda>s. (device_mem s) \<circ> ptrFromPAddr);
      ds \<leftarrow> gets (device_state \<circ> machine_state);

      es \<leftarrow> do_machine_op getExMonitor;

      \<comment> \<open>Non-deterministically execute one of the user's operations.\<close>
      u \<leftarrow> return (uop t pl pr pxn (tc, um|`allow_read, (ds \<circ> ptrFromPAddr)|` allow_read, es));
      assert (u \<noteq> {});
      (e,(tc',um',ds',es')) \<leftarrow> select u;

      \<comment> \<open>Update the changes the user made to memory into our model.
         We ignore changes that took place where they didn't have
         write permissions. (uop shouldn't be doing that --- if it is,
         uop isn't correctly modelling real hardware.)\<close>
      do_machine_op (user_memory_update (((um' |` allow_write) \<circ> addrFromPPtr) |` (-(dom ds))));

      do_machine_op (device_memory_update (((ds' |` allow_write) \<circ> addrFromPPtr) |` (dom ds)));

      \<comment> \<open>Update exclusive monitor state used by the thread.\<close>
      do_machine_op (setExMonitor es');

      return (e,tc')
   od"


named_theorems UserOp_IF_assms

lemma arch_globals_equiv_underlying_memory_update[UserOp_IF_assms, simp]:
  "arch_globals_equiv ct it kh kh' as as' (underlying_memory_update f ms) ms' =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  "arch_globals_equiv ct it kh kh' as as' ms (underlying_memory_update f ms') =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  by auto

lemma arch_globals_equiv_device_state_update[UserOp_IF_assms, simp]:
  "arch_globals_equiv ct it kh kh' as as' (device_state_update f ms) ms' =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  "arch_globals_equiv ct it kh kh' as as' ms (device_state_update f ms') =
   arch_globals_equiv ct it kh kh' as as' ms ms'"
  by auto

end

context begin interpretation Arch .

requalify_types user_transition_if

end


global_interpretation UserOp_IF_1?: UserOp_IF_1
proof goal_cases
  interpret Arch .
  case 1 show ?case
    by (unfold_locales; (fact UserOp_IF_assms)?)
qed


context Arch begin global_naming ARM

lemma requiv_get_pd_of_thread_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag (cur_thread s);
     pd_ref \<noteq> arm_global_pd (arch_state s); pd_ref' \<noteq> arm_global_pd (arch_state s');
     get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) = pd_ref;
     get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') = pd_ref' \<rbrakk>
     \<Longrightarrow> pd_ref = pd_ref'"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag (cur_thread s)")
   apply (clarsimp simp: get_pd_of_thread_eq)
  apply simp
  done

lemma requiv_get_pt_entry_eq:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag pt \<rbrakk>
     \<Longrightarrow> get_pt_entry (\<lambda>obj. get_arch_obj (kheap s obj)) pt x =
         get_pt_entry (\<lambda>obj. get_arch_obj (kheap s' obj)) pt x"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag pt")
   apply (simp add: get_pt_entry_def split: option.splits)
  apply (simp add: reads_lrefl)
  done

lemma requiv_get_pt_info_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag pt \<rbrakk>
     \<Longrightarrow> get_pt_info (\<lambda>obj. get_arch_obj (kheap s obj)) pt x =
         get_pt_info (\<lambda>obj. get_arch_obj (kheap s' obj)) pt x"
  apply (simp add: get_pt_info_def)
  apply (subst requiv_get_pt_entry_eq, simp+)
  done

lemma requiv_get_pd_entry_eq:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag pd \<rbrakk>
     \<Longrightarrow> get_pd_entry (\<lambda>obj. get_arch_obj (kheap s obj)) pd x =
         get_pd_entry (\<lambda>obj. get_arch_obj (kheap s' obj)) pd x"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag pd")
   apply (simp add: get_pd_entry_def split: option.splits)
  apply simp
  done

lemma requiv_get_page_info_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag pd; x \<notin> kernel_mappings \<rbrakk>
     \<Longrightarrow> get_page_info (\<lambda>obj. get_arch_obj (kheap s obj)) pd x =
         get_page_info (\<lambda>obj. get_arch_obj (kheap s' obj)) pd x"
  apply (simp add: get_page_info_def)
  apply (subst requiv_get_pd_entry_eq[symmetric], simp+)
  apply (clarsimp split: option.splits pde.splits)
  apply (frule pt_in_pd_same_agent, fastforce+)
  apply (rule requiv_get_pt_info_eq, simp+)
  done

lemma requiv_pd_of_thread_global_pd:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag (cur_thread s); invs s; pas_refined aag s;
     get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) = arm_global_pd (arch_state s) \<rbrakk>
     \<Longrightarrow> get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') = arm_global_pd (arch_state s')"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag (cur_thread s)")
   prefer 2
   apply simp
  apply (clarsimp simp: get_pd_of_thread_def2
                 split: option.splits kernel_object.splits cap.splits arch_cap.splits)
  apply (rename_tac tcb word word' p apool)
  apply (subgoal_tac "aag_can_read_asid aag word'")
   apply (subgoal_tac "s \<turnstile> ArchObjectCap (PageDirectoryCap word (Some word'))")
    apply (clarsimp simp: equiv_asids_def equiv_asid_def valid_cap_def)
    apply (drule_tac x=word' in spec)
    apply (clarsimp simp: word_gt_0 typ_at_eq_kheap_obj)
    apply (drule invs_valid_global_refs)
    apply (drule_tac ptr="((cur_thread s), tcb_cnode_index 1)" in valid_global_refsD2[rotated])
     apply (subst caps_of_state_tcb_cap_cases)
       apply (simp add: get_tcb_def)
      apply (simp add: dom_tcb_cap_cases[simplified])
     apply simp
    apply (simp add: cap_range_def global_refs_def)
   apply (cut_tac s=s and t="cur_thread s" and tcb=tcb in objs_valid_tcb_vtable)
     apply (fastforce simp: invs_valid_objs get_tcb_def)+
  apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag word')
                        \<in> state_asids_to_policy aag s")
   apply (frule pas_refined_Control_into_is_subject_asid)
    apply (fastforce simp: pas_refined_def)
   apply simp
  apply (cut_tac aag=aag and ptr="(cur_thread s, tcb_cnode_index 1)" in sata_asid)
    prefer 3
    apply simp
   apply (subst caps_of_state_tcb_cap_cases)
     apply (simp add: get_tcb_def)
    apply (simp add: dom_tcb_cap_cases[simplified])+
  done

lemma requiv_ptable_rights_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s' \<rbrakk>
     \<Longrightarrow> ptable_rights_s s = ptable_rights_s s'"
  apply (simp add: ptable_rights_s_def)
  apply (rule ext)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_rights_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
       apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                               vspace_cap_rights_to_auth_def)+)[4]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def)+)[4]
   apply clarsimp
   apply (frule_tac r=b in some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def)+)[4]
  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) =
                   arm_global_pd (arch_state s)")
   apply (frule requiv_pd_of_thread_global_pd)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_rights_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
  apply (case_tac "get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') =
                   arm_global_pd (arch_state s')")
   apply (drule reads_equiv_sym)
   apply (frule requiv_pd_of_thread_global_pd)
       apply ((fastforce simp: reads_equiv_def)+)[5]
  apply (simp add: ptable_rights_def)
  apply (frule requiv_get_pd_of_thread_eq)
        apply (fastforce+)[6]
  apply (frule pd_of_thread_same_agent, simp+)
  apply (subst requiv_get_page_info_eq, simp+)
  done

lemma requiv_ptable_attrs_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> ptable_attrs_s s x = ptable_attrs_s s' x"
  apply (simp add: ptable_attrs_s_def ptable_rights_s_def)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_attrs_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
       apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                               vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]
  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) =
                   arm_global_pd (arch_state s)")
   apply (frule requiv_pd_of_thread_global_pd)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_attrs_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
  apply (case_tac "get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') =
                   arm_global_pd (arch_state s')")
   apply (drule reads_equiv_sym)
   apply (frule requiv_pd_of_thread_global_pd)
       apply ((fastforce simp: reads_equiv_def)+)[5]
  apply (simp add: ptable_attrs_def)
  apply (frule requiv_get_pd_of_thread_eq, simp+)[1]
  apply (frule pd_of_thread_same_agent, simp+)[1]
  apply (subst requiv_get_page_info_eq, simp+)[1]
  done

lemma requiv_ptable_lift_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; invs s;
     invs s'; is_subject aag (cur_thread s); ptable_rights_s s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> ptable_lift_s s x = ptable_lift_s s' x"
  apply (simp add: ptable_lift_s_def ptable_rights_s_def)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_lift_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
       apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                               vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]
  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) =
                   arm_global_pd (arch_state s)")
   apply (frule requiv_pd_of_thread_global_pd)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_lift_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
  apply (case_tac "get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') =
                   arm_global_pd (arch_state s')")
   apply (drule reads_equiv_sym)
   apply (frule requiv_pd_of_thread_global_pd)
       apply ((fastforce simp: reads_equiv_def)+)[5]
  apply (simp add: ptable_lift_def)
  apply (frule requiv_get_pd_of_thread_eq, simp+)[1]
  apply (frule pd_of_thread_same_agent, simp+)[1]
  apply (subst requiv_get_page_info_eq, simp+)[1]
  done

lemma requiv_ptable_xn_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> ptable_xn_s s x = ptable_xn_s s' x"
  by (simp add: ptable_xn_s_def requiv_ptable_attrs_eq)

lemma mask_shift_le:
  "z \<le> y \<Longrightarrow> (x :: 'a :: len word) && ~~ mask z >> y = x >> y"
proof -
  assume le: "z \<le> y"
  have shifttwice: "\<And>(x :: 'a :: len word). x >> y = x >> z >> y - z"
    by (simp add: shiftr_shiftr le)
  show ?thesis
    apply (subst shifttwice)
    apply simp
    apply (simp add: shiftr_shiftr le)
    done
qed

lemma data_at_obj_range:
  "\<lbrakk> data_at sz ptr s; pspace_aligned s; valid_objs s \<rbrakk>
     \<Longrightarrow> ptr + (offset && mask (pageBitsForSize sz)) \<in> obj_range ptr (ArchObj (DataPage dev sz))"
  apply (clarsimp simp: data_at_def)
  apply (elim disjE)
   apply (clarsimp simp: obj_at_def)
   apply (drule (2) ptr_in_obj_range)
   apply (clarsimp simp: obj_bits_def obj_range_def)
   apply fastforce
  apply (clarsimp simp: obj_at_def)
  apply (drule (2) ptr_in_obj_range)
  apply (clarsimp simp: obj_bits_def obj_range_def)
  apply fastforce
  done

lemma obj_range_data_for_cong:
  "obj_range ptr (ArchObj (DataPage dev sz')) = obj_range ptr (ArchObj (DataPage False sz'))"
  by (simp add: obj_range_def)

lemma pspace_distinct_def':
  "pspace_distinct \<equiv>
     \<lambda>s. \<forall>x y ko ko'. kheap s x = Some ko \<and> kheap s y = Some ko' \<and> x \<noteq> y
                      \<longrightarrow> obj_range x ko \<inter> obj_range y ko' = {}"
  by (auto simp: pspace_distinct_def obj_range_def field_simps)

lemma data_at_disjoint_equiv:
  "\<lbrakk> ptr' \<noteq> ptr;data_at sz' ptr' s; data_at sz ptr s; valid_objs s; pspace_aligned s;
     pspace_distinct s; ptr' \<in> obj_range ptr (ArchObj (DataPage dev sz)) \<rbrakk>
     \<Longrightarrow> False"
  apply (frule (2) data_at_obj_range[where offset = 0,simplified])
  apply (clarsimp simp: data_at_def obj_at_def)
  apply (elim disjE)
  by (clarsimp dest!: spec simp: obj_at_def pspace_distinct_def'
      , erule impE, erule conjI2[OF conjI2], (fastforce+)[2]
      , fastforce cong: obj_range_data_for_cong)+

lemma ptrFromPAddr_mask_simp:
  "ptrFromPAddr z && ~~ mask (pageBitsForSize l) =
   ptrFromPAddr (z && ~~ mask (pageBitsForSize l))"
  apply (simp add: ptrFromPAddr_def field_simps)
  apply (subst mask_out_add_aligned[OF is_aligned_pptrBaseOffset])
  apply simp
  done

lemma pageBitsForSize_le_t24:
  "pageBitsForSize sz \<le> 24"
  by (cases sz, simp_all)

lemma data_at_same_size:
  assumes dat_sz':
    "data_at sz' (ptrFromPAddr base) s"
  and dat_sz:
    "data_at sz
       (ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz)) s"
  and vs:
    "pspace_distinct s" "pspace_aligned s" "valid_objs s"
  shows "sz' = sz"
proof -
  from dat_sz' and dat_sz
  have trivial:
    "sz' \<noteq> sz
     \<Longrightarrow> ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz) \<noteq>
         ptrFromPAddr base"
    by (auto simp: data_at_def obj_at_def)
  have sz_equiv: "(pageBitsForSize sz = pageBitsForSize sz') = (sz' = sz)"
    by (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits)
  show ?thesis
    apply (rule sz_equiv[THEN iffD1])
    apply (rule ccontr)
    apply (drule neq_iff[THEN iffD1])
    using dat_sz' dat_sz vs
    apply (cut_tac trivial) prefer 2
     apply (fastforce simp: sz_equiv)
    apply (frule(1) data_at_aligned)
    apply (elim disjE)
     apply (erule(5) data_at_disjoint_equiv)
     apply (unfold obj_range_def)
     apply (rule mask_in_range[THEN iffD1])
      apply (simp add: obj_bits_def)+
     apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp)
     apply (rule arg_cong[where f = ptrFromPAddr])
     apply (drule is_aligned_ptrFromPAddrD[OF _ pageBitsForSize_le_t24])
     apply (subst neg_mask_add_aligned[OF _ and_mask_less'])
       apply simp
      apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified])
     apply (simp add: is_aligned_neg_mask_eq)
    apply (drule not_sym)
    apply (erule(5) data_at_disjoint_equiv)
    apply (unfold obj_range_def)
    apply (rule mask_in_range[THEN iffD1])
     apply (simp add: obj_bits_def is_aligned_neg_mask)+
    apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp)
    apply (rule arg_cong[where f = ptrFromPAddr])
    apply (drule is_aligned_ptrFromPAddrD[OF _ pageBitsForSize_le_t24])
    apply (subst mask_lower_twice[symmetric])
     apply (erule less_imp_le_nat)
    apply (rule sym)
    apply (subst mask_lower_twice[symmetric])
     apply (erule less_imp_le_nat)
    apply (rule arg_cong[where f = "\<lambda>x. x && ~~ mask z" for z])
    apply (subst neg_mask_add_aligned[OF _ and_mask_less'])
      apply simp
     apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified])
    apply simp
    done
qed

lemma valid_pdpt_align_ptD:
  "\<lbrakk> kheap s ptr = Some (ArchObj (PageTable pt)); valid_pdpt_objs s; pt a = entry \<rbrakk>
     \<Longrightarrow> is_aligned a (pte_range_sz entry)"
  apply (drule (1) valid_pdpt_objs_ptD)
  apply (clarsimp simp: entries_align_def)
  done

lemma valid_pdpt_align_pdD:
  "\<lbrakk> kheap s ptr = Some (ArchObj (PageDirectory pd));valid_pdpt_objs s; pd a = entry \<rbrakk>
     \<Longrightarrow> is_aligned a (pde_range_sz entry)"
  apply (drule (1) valid_pdpt_objs_pdD)
  apply (clarsimp simp: entries_align_def)
  done

lemma valid_vspace_objsD2:
  "\<lbrakk> (\<exists>\<rhd> p) s; ko_at (ArchObj ao) p s; valid_vspace_objs s \<rbrakk>
     \<Longrightarrow> valid_vspace_obj ao s"
  by (clarsimp simp: valid_vspace_objsD)

lemma ptable_lift_data_consistant:
  assumes vs: "valid_state s"
  and vpdpt: "valid_pdpt_objs s"
  and pt_lift: "ptable_lift t s x = Some ptr"
  and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s"
  and misc: "get_pd_of_thread (kheap s) (arch_state s) t \<noteq> arm_global_pd (arch_state s)"
            "x \<notin> kernel_mappings"
  shows "ptable_lift t s (x && ~~ mask (pageBitsForSize sz)) =
         Some (ptr && ~~ mask (pageBitsForSize sz))"
proof -
  have aligned_stuff:
    "is_aligned (ucast ((x >> 12) && mask 8) :: word8) 4 \<Longrightarrow> (x && ~~ mask 16 >> 12) = x >> 12"
    by (simp add: is_aligned_mask mask_def) word_bitwise
  have aligned_stuff':
    "is_aligned ((ucast (x >> 20)):: 12 word) 4 \<Longrightarrow> x && ~~ mask 24 >> 20 = x >> 20"
    by (simp add: is_aligned_mask mask_def) word_bitwise
  have vs': "valid_objs s \<and> valid_vspace_objs s \<and> pspace_distinct s \<and> pspace_aligned s"
    using vs by (simp add: valid_state_def valid_pspace_def)
  have x_less_kb: "x < kernel_base"
    using misc by (simp add: kernel_mappings_def) (* FIXME: any rules exists already ? *)
  thus ?thesis
    using pt_lift dat vs'
    apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits)
    apply (clarsimp simp: get_page_info_def split: option.splits)
    apply (rename_tac base sz' attrs rights pde)
    apply (case_tac pde,simp_all)
      apply (clarsimp simp: get_pd_entry_def split: arch_kernel_obj.split_asm option.splits)
      apply (clarsimp simp: get_pt_info_def get_arch_obj_def get_pt_entry_def
                     split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
      apply (rename_tac pd_base vmattr mw pd pt)
      apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
      apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
      apply simp
      apply (drule bspec)
       apply (rule Compl_iff[THEN iffD2])
       apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
      apply (clarsimp simp: valid_pde_def obj_at_def a_type_def)
      apply (case_tac "pt (ucast ((x >> 12) && mask 8))",simp_all)
       apply (frule valid_vspace_objsD2[where p = "ptrFromPAddr p" for p,
                                        rotated,unfolded obj_at_def,simplified], simp)
        apply (rule exI)
        apply (erule vs_lookup_step)
        apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def
                         pd_shifting pd_shifting_dual obj_at_def)
        apply (rule_tac x="VSRef (x>>20) (Some APageDirectory)" in exI)
        apply (rule context_conjI,simp)
        apply (erule vs_refs_pdI)
         apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
        apply (intro allI impI)
        apply (simp add: nth_shiftr)
        apply (rule bang_big[simplified])
        apply (simp add: word_size)
       apply (frule (1) valid_pdpt_align_ptD[OF _ vpdpt])
       apply simp
       apply (drule_tac x="(ucast ((x >> 12) && mask 8))" in spec)
       apply (frule data_at_same_size[where sz=sz and sz'=ARMLargePage,rotated,simplified], simp+)
       apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                             get_arch_obj_def entries_align_def aligned_stuff mask_AND_NOT_mask
                      dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 16,simplified])
       apply (simp add: neg_mask_add_aligned[OF _ and_mask_less'] is_aligned_neg_mask_eq)
      apply (frule valid_vspace_objsD2[where p = "ptrFromPAddr p" for p,
                                       rotated,unfolded obj_at_def,simplified], simp)
       apply (rule exI)
       apply (erule vs_lookup_step)
       apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def
                        pd_shifting pd_shifting_dual obj_at_def)
       apply (rule_tac x="VSRef (x>>20) (Some APageDirectory)" in exI)
       apply (rule context_conjI,simp)
       apply (erule vs_refs_pdI)
        apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
       apply (intro allI impI)
       apply (simp add: nth_shiftr)
       apply (rule bang_big[simplified])
       apply (simp add: word_size)
      apply (frule(1) valid_pdpt_align_ptD[OF _ vpdpt])
      apply simp
      apply (drule_tac x="(ucast ((x >> 12) && mask 8))" in spec)
      apply (frule data_at_same_size[where sz=sz and sz'=ARMSmallPage,rotated,simplified], simp+)
      apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def get_arch_obj_def
                            neg_mask_add_aligned[OF _ and_mask_less'] mask_AND_NOT_mask
                     dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 12,simplified])
     apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                    split: arch_kernel_obj.split_asm option.splits)
     apply (clarsimp simp: get_pt_entry_def
                    split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
     apply (rename_tac pd_base vmattr mw pd caprights)
     apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
     apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
     apply simp
     apply (drule bspec)
      apply (rule Compl_iff[THEN iffD2])
      apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
     apply (clarsimp simp: valid_pde_def obj_at_def)
     apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
     apply (frule data_at_same_size[where sz=sz and sz'=ARMSection,rotated,simplified], simp+)
    apply (clarsimp simp: aligned_stuff' neg_mask_add_aligned[OF _ and_mask_less'] mask_AND_NOT_mask
                   dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 20,simplified])
    apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                   split: arch_kernel_obj.split_asm option.splits)
    apply (clarsimp simp: get_pt_entry_def
                   split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
    apply (rename_tac pd_base vmattr rights pd)
    apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
    apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
    apply simp
    apply (drule bspec)
     apply (rule Compl_iff[THEN iffD2])
     apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
    apply (clarsimp simp: valid_pde_def obj_at_def)
    apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
    apply (frule data_at_same_size[where sz=sz and sz'=ARMSuperSection,rotated,simplified], simp+)
    apply (clarsimp simp: aligned_stuff' neg_mask_add_aligned[OF _ and_mask_less'] mask_AND_NOT_mask
                   dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 24,simplified])
    done
qed

lemma ptable_rights_data_consistant:
  assumes vs: "valid_state s"
  and vpdpt: "valid_pdpt_objs s"
  and pt_lift: "ptable_lift t s x = Some ptr"
  and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s"
  and misc: "get_pd_of_thread (kheap s) (arch_state s) t \<noteq>
             arm_global_pd (arch_state s)" "x \<notin> kernel_mappings"
  shows "ptable_rights t s (x && ~~ mask (pageBitsForSize sz)) = ptable_rights t s x"
proof -
  have aligned_stuff:
    "is_aligned (ucast ((x >> 12) && mask 8) :: word8) 4 \<Longrightarrow> (x && ~~ mask 16 >> 12) = x >> 12"
    by (simp add: is_aligned_mask mask_def) word_bitwise
  have aligned_stuff':
    "is_aligned ((ucast (x >> 20)):: 12 word) 4 \<Longrightarrow> x && ~~ mask 24 >> 20 = x >> 20"
    by (simp add: is_aligned_mask mask_def) word_bitwise
  have vs': "valid_objs s \<and> valid_vspace_objs s \<and> pspace_distinct s \<and> pspace_aligned s"
    using vs
    by (simp add: valid_state_def valid_pspace_def)
  have x_less_kb: "x < kernel_base"
    using misc
    by (simp add: kernel_mappings_def) (* FIXME: any rules exists already ? *)
  thus ?thesis
    using pt_lift dat vs'
    apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits)
    apply (clarsimp simp: get_page_info_def split: option.splits)
    apply (rename_tac base sz' attrs rights pde)
    apply (case_tac pde, simp_all)
      apply (clarsimp simp: get_pd_entry_def split: arch_kernel_obj.split_asm option.splits)
      apply (clarsimp simp: get_pt_info_def get_arch_obj_def get_pt_entry_def
                     split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
      apply (rename_tac pd_base vmattr mw pd pt)
      apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
      apply (frule (1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
      apply simp
      apply (drule bspec)
       apply (rule Compl_iff[THEN iffD2])
       apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
      apply (clarsimp simp: valid_pde_def obj_at_def a_type_def)
      apply (case_tac "pt (ucast ((x >> 12) && mask 8))",simp_all)
       apply (frule valid_vspace_objsD2[where p = "ptrFromPAddr p" for p,
                                        rotated,unfolded obj_at_def,simplified], simp)
        apply (rule exI)
        apply (erule vs_lookup_step)
        apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def
                         pd_shifting pd_shifting_dual obj_at_def)
        apply (rule_tac x = "VSRef (x>>20) (Some APageDirectory)" in exI)
        apply (rule context_conjI,simp)
        apply (erule vs_refs_pdI)
         apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
        apply (intro allI impI)
        apply (simp add: nth_shiftr)
        apply (rule bang_big[simplified])
        apply (simp add: word_size)
       apply (frule (1) valid_pdpt_align_ptD[OF _ vpdpt])
       apply simp
       apply (drule_tac x="(ucast ((x >> 12) && mask 8))" in spec)
       apply (frule data_at_same_size[where sz=sz and sz'=ARMLargePage,rotated,simplified], simp+)
       apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                             get_arch_obj_def entries_align_def aligned_stuff mask_AND_NOT_mask
                      dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a=16,simplified])
      apply (frule valid_vspace_objsD2[where p = "ptrFromPAddr p" for p,
                                       rotated,unfolded obj_at_def,simplified], simp)
       apply (rule exI)
       apply (erule vs_lookup_step)
       apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def
                        pd_shifting pd_shifting_dual obj_at_def)
       apply (rule_tac x = "VSRef (x>>20) (Some APageDirectory)" in exI)
       apply (rule context_conjI,simp)
       apply (erule vs_refs_pdI)
        apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
       apply (intro allI impI)
       apply (simp add: nth_shiftr)
       apply (rule bang_big[simplified])
       apply (simp add: word_size)
      apply (frule(1) valid_pdpt_align_ptD[OF _ vpdpt])
      apply simp
      apply (drule_tac x="(ucast ((x >> 12) && mask 8))" in spec)
      apply (frule data_at_same_size[where sz=sz and sz'=ARMSmallPage,rotated,simplified], simp+)
      apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def get_arch_obj_def
                     dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a=12,simplified])
     apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                    split: arch_kernel_obj.split_asm option.splits)
     apply (clarsimp simp: get_pt_entry_def
                    split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
     apply (rename_tac pd_base vmattr mw pd caprights)
     apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
     apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
     apply simp
     apply (drule bspec)
      apply (rule Compl_iff[THEN iffD2])
      apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
     apply (clarsimp simp: valid_pde_def obj_at_def)
     apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
     apply (frule data_at_same_size[where sz = sz and sz' = ARMSection,rotated,simplified],
          clarsimp+)
    apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                   split: arch_kernel_obj.split_asm option.splits)
    apply (clarsimp simp: get_pt_entry_def
                   split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
    apply (rename_tac pd_base vmattr rights pd)
    apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
    apply (frule (1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
    apply simp
    apply (drule bspec)
     apply (rule Compl_iff[THEN iffD2])
     apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
    apply (clarsimp simp: valid_pde_def obj_at_def)
    apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
    apply (frule data_at_same_size[where sz=sz and sz'=ARMSuperSection,rotated,simplified], simp+)
    apply (clarsimp simp: aligned_stuff' neg_mask_add_aligned[OF _ and_mask_less'] mask_AND_NOT_mask
                   dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 24,simplified])
    done
qed

lemma user_op_access_data_at:
  "\<lbrakk> invs s; valid_pdpt_objs s;pas_refined aag s; is_subject aag tcb; ptable_lift tcb s x = Some ptr;
     data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s;
     auth \<in> vspace_cap_rights_to_auth (ptable_rights tcb s x) \<rbrakk>
     \<Longrightarrow> (pasObjectAbs aag tcb, auth,
          pasObjectAbs aag (ptrFromPAddr (ptr && ~~ mask (pageBitsForSize sz)))) \<in> pasPolicy aag"
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits)
   apply (frule some_get_page_info_kmapsD)
      apply (fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                             vspace_cap_rights_to_auth_def)+
  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) tcb = arm_global_pd (arch_state s)")
   apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits)
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply (fastforce simp: invs_valid_global_objs invs_arch_state)+
  apply (frule (3) ptable_lift_data_consistant[rotated 2])
    apply fastforce
   apply fastforce
  apply (frule (3) ptable_rights_data_consistant[rotated 2])
    apply fastforce
   apply fastforce
  apply (erule (3) user_op_access)
  apply simp
  done

lemma user_frame_at_equiv:
  "\<lbrakk> typ_at (AArch (AUserData sz)) p s; equiv_for P kheap s s'; P p \<rbrakk>
     \<Longrightarrow> typ_at (AArch (AUserData sz)) p s'"
  by (clarsimp simp: equiv_for_def obj_at_def)

lemma device_frame_at_equiv:
  "\<lbrakk> typ_at (AArch (ADeviceData sz)) p s; equiv_for P kheap s s'; P p \<rbrakk>
     \<Longrightarrow> typ_at (AArch (ADeviceData sz)) p s'"
  by (clarsimp simp: equiv_for_def obj_at_def)

lemma typ_at_user_data_at:
  "typ_at (AArch (AUserData sz)) p s \<Longrightarrow> data_at sz p s"
  by (simp add: data_at_def)

lemma typ_at_device_data_at:
  "typ_at (AArch (ADeviceData sz)) p s \<Longrightarrow> data_at sz p s"
  by (simp add: data_at_def)

lemma requiv_device_mem_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; valid_pdpt_objs s;
     valid_pdpt_objs s'; is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \<rbrakk>
     \<Longrightarrow> device_mem s (ptrFromPAddr y) = device_mem s' (ptrFromPAddr y)"
  apply (simp add: device_mem_def)
  apply (rule conjI)
   apply (erule reads_equivE)
   apply (clarsimp simp: in_device_frame_def)
   apply (rule exI)
   apply (rule device_frame_at_equiv)
     apply assumption+
   apply (erule_tac f="underlying_memory" in equiv_forE)
   apply (frule_tac auth=Read in user_op_access_data_at[where s=s])
         apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
                | intro typ_at_device_data_at)+
   apply (rule reads_read)
   apply (fastforce simp: ptrFromPAddr_mask_simp)
  apply clarsimp
  apply (frule requiv_ptable_rights_eq, fastforce+)
  apply (frule requiv_ptable_lift_eq, fastforce+)
  apply (clarsimp simp: globals_equiv_def)
  apply (erule notE)
  apply (erule reads_equivE)
  apply (clarsimp simp: in_device_frame_def)
  apply (rule exI)
  apply (rule device_frame_at_equiv)
    apply assumption+
   apply (erule_tac f="underlying_memory" in equiv_forE)
   apply (erule equiv_symmetric[THEN iffD1])
  apply (frule_tac auth=Read in user_op_access_data_at[where s=s'])
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
               | intro typ_at_device_data_at)+
  apply (rule reads_read)
  apply (fastforce simp: ptrFromPAddr_mask_simp)
  done

lemma requiv_user_mem_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; valid_pdpt_objs s;
     valid_pdpt_objs s'; is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \<rbrakk>
     \<Longrightarrow> user_mem s (ptrFromPAddr y) = user_mem s' (ptrFromPAddr y)"
  apply (simp add: user_mem_def)
  apply (rule conjI)
   apply clarsimp
   apply (rule context_conjI')
    apply (erule reads_equivE)
    apply (clarsimp simp: in_user_frame_def)
    apply (rule exI)
    apply (rule user_frame_at_equiv)
      apply assumption+
    apply (erule_tac f="underlying_memory" in equiv_forE)
    apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
          apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
                 | intro typ_at_user_data_at)+
    apply (rule reads_read)
    apply (fastforce simp: ptrFromPAddr_mask_simp)
   apply clarsimp
   apply (subgoal_tac "aag_can_read aag (ptrFromPAddr y)")
    apply (erule reads_equivE)
    apply clarsimp
    apply (erule_tac f="underlying_memory" in equiv_forE)
    apply simp
   apply (frule_tac auth=Read in user_op_access)
       apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+
   apply (rule reads_read)
   apply simp
  apply (frule requiv_ptable_rights_eq, fastforce+)
  apply (frule requiv_ptable_lift_eq, fastforce+)
  apply (clarsimp simp: globals_equiv_def)
  apply (erule notE)
  apply (erule reads_equivE)
  apply (clarsimp simp: in_user_frame_def)
  apply (rule exI)
  apply (rule user_frame_at_equiv)
    apply assumption+
   apply (erule_tac f="underlying_memory" in equiv_forE)
   apply (erule equiv_symmetric[THEN iffD1])
  apply (frule_tac auth=Read in user_op_access_data_at[where s=s'])
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
               | intro typ_at_user_data_at)+
  apply (rule reads_read)
  apply (fastforce simp: ptrFromPAddr_mask_simp)
  done

lemma ptable_rights_imp_frameD:
  "\<lbrakk> ptable_lift t s x = Some y;valid_state s;ptable_rights t s x \<noteq> {} \<rbrakk>
     \<Longrightarrow> \<exists>sz. data_at sz (ptrFromPAddr y && ~~ mask (pageBitsForSize sz)) s"
  apply (subst (asm) addrFromPPtr_ptrFromPAddr_id[symmetric])
  apply (drule ptable_rights_imp_frame)
    apply simp+
   apply (rule addrFromPPtr_ptrFromPAddr_id[symmetric])
  apply (auto simp: in_user_frame_def in_device_frame_def
             dest!: spec typ_at_user_data_at typ_at_device_data_at)
  done

lemma requiv_user_device_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; valid_pdpt_objs s;
     valid_pdpt_objs s'; is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \<rbrakk>
     \<Longrightarrow> device_state (machine_state s) (ptrFromPAddr y) =
         device_state (machine_state s') (ptrFromPAddr y)"
  apply (simp add: ptable_lift_s_def)
  apply (frule ptable_rights_imp_frameD)
    apply fastforce
   apply (fastforce simp: ptable_rights_s_def)
  apply (erule reads_equivE)
  apply clarsimp
  apply (erule_tac f="device_state" in equiv_forD)
  apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
        apply ((fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def
                | intro typ_at_user_data_at)+)[6]
  apply (rule reads_read)
  apply (frule_tac auth=Read in user_op_access)
      apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+
  done


definition context_matches_state where
  "context_matches_state pl pr pxn ms s \<equiv> case ms of (um, ds, es) \<Rightarrow>
     pl = ptable_lift_s s |` {x. pr x \<noteq> {}} \<and>
     pr = ptable_rights_s s \<and>
     pxn = (\<lambda>x. pr x \<noteq> {} \<and> ptable_xn_s s x) \<and>
     um = (user_mem s \<circ> ptrFromPAddr) |` {y. \<exists>x. pl x = Some y \<and> AllowRead \<in> pr x} \<and>
     ds = (device_state (machine_state s) \<circ> ptrFromPAddr) |`
          {y. \<exists>x. pl x = Some y \<and> AllowRead \<in> pr x} \<and>
     es = exclusive_state (machine_state s)"


lemma dmo_setExMonitor_reads_respects_g:
  "reads_respects_g aag l \<top> (do_machine_op (setExMonitor es))"
  apply (simp add: setExMonitor_def)
  apply (wp dmo_ev ev_modify)
  apply (auto simp: reads_equiv_g_def reads_equiv_def affects_equiv_def states_equiv_for_def
                    equiv_for_def equiv_asids_def equiv_asid_def globals_equiv_def idle_equiv_def
             split: if_splits)
  done

lemma dmo_getExMonitor_reads_respects_g:
  "reads_respects_g aag l (\<lambda>s. cur_thread s \<noteq> idle_thread s) (do_machine_op getExMonitor)"
  apply (simp add: getExMonitor_def)
  apply (wp dmo_ev gets_ev'')
  apply (clarsimp simp: reads_equiv_g_def globals_equiv_def)
  done

lemma getExMonitor_wp[wp]:
  "\<lbrace>\<lambda>ms. P (exclusive_state ms) ms\<rbrace> getExMonitor \<lbrace>P\<rbrace>"
  by (simp add: getExMonitor_def | wp)+


definition valid_vspace_objs_if where
  "valid_vspace_objs_if \<equiv> valid_pdpt_objs"

declare valid_vspace_objs_if_def[simp]


lemma do_user_op_reads_respects_g:
  notes split_paired_All[simp del]
  shows
    "(\<forall>pl pr pxn tc ms s. P tc s \<and> context_matches_state pl pr pxn ms s
                                \<longrightarrow> (\<exists>x. uop (cur_thread s) pl pr pxn (tc, ms) = {x}))
     \<Longrightarrow> reads_respects_g aag l (pas_refined aag and invs and valid_vspace_objs_if
                                                 and is_subject aag \<circ> cur_thread
                                                 and (\<lambda>s. cur_thread s \<noteq> idle_thread s) and P tc)
                          (do_user_op_if uop tc)"
  apply (simp add: do_user_op_if_def)
  apply (rule use_spec_ev)
  apply (rule spec_equiv_valid_add_asm)
  apply (rule spec_equiv_valid_add_rel[OF _ reads_equiv_g_refl])
  apply (rule spec_equiv_valid_add_rel'[OF _ affects_equiv_refl])
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (clarsimp simp: reads_equiv_g_def)
   apply (rule requiv_ptable_rights_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (rule ext)
   apply (clarsimp simp: reads_equiv_g_def)
   apply (case_tac "ptable_rights_s st x = {}", simp)
   apply simp
   apply (rule requiv_ptable_xn_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (subst expand_restrict_map_eq,clarsimp)
   apply (clarsimp simp: reads_equiv_g_def)
   apply (rule requiv_ptable_lift_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (clarsimp simp: reads_equiv_g_def)
   apply (rule requiv_cur_thread_eq,fastforce)
  apply (rule spec_equiv_valid_inv_gets_more[where proj="\<lambda>m. dom m \<inter> cw"
                                               and projsnd="\<lambda>m. m |` cr" for cr and cw])
   apply (rule context_conjI')
    apply (subst expand_restrict_map_eq)
    apply (clarsimp simp: reads_equiv_g_def restrict_map_def)
    apply (rule requiv_user_mem_eq)
              apply simp+
   apply fastforce
  apply (rule spec_equiv_valid_inv_gets[where proj = "\<lambda>x. ()", simplified])
  apply (rule spec_equiv_valid_inv_gets_more[where proj = "\<lambda>m. (m \<circ> ptrFromPAddr) |` cr" for cr])
   apply (rule conjI)
    apply (subst expand_restrict_map_eq)
    apply (clarsimp simp: restrict_map_def reads_equiv_g_def)
    apply (rule requiv_user_device_eq)
              apply simp+
   apply (clarsimp simp: globals_equiv_def reads_equiv_g_def)
  apply (rule spec_equiv_valid_guard_imp)
   apply (wpsimp wp: dmo_user_memory_update_reads_respects_g dmo_device_state_update_reads_respects_g
                     dmo_setExMonitor_reads_respects_g dmo_device_state_update_reads_respects_g
                     select_ev dmo_getExMonitor_reads_respects_g dmo_wp)
  apply clarsimp
  apply (rule conjI)
   apply clarsimp
   apply (drule spec)+
   apply (erule impE)
    prefer 2
    apply assumption
   apply (clarsimp simp: context_matches_state_def comp_def  reads_equiv_g_def globals_equiv_def)
  apply (clarsimp simp: reads_equiv_g_def globals_equiv_def)
  done

end

context begin interpretation Arch .

requalify_consts
  do_user_op_if
  valid_vspace_objs_if
  context_matches_state

requalify_facts
  do_user_op_reads_respects_g

end

end