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

(*
  Top level architecture related proofs.
*)

theory Arch_R
imports Untyped_R Finalise_R
begin

lemmas [datatype_schematic] = cap.sel list.sel(1) list.sel(3)

context begin interpretation Arch . (*FIXME: arch_split*)

declare arch_cap.sel [datatype_schematic]
declare is_aligned_shiftl [intro!]
declare is_aligned_shiftr [intro!]

definition
  "asid_ci_map i \<equiv>
  case i of RISCV64_A.MakePool frame slot parent base \<Rightarrow>
  RISCV64_H.MakePool frame (cte_map slot) (cte_map parent) (ucast base)"

definition
  "valid_aci' aci \<equiv> case aci of MakePool frame slot parent base \<Rightarrow>
  \<lambda>s. cte_wp_at' (\<lambda>c. cteCap c = NullCap) slot s \<and>
      cte_wp_at' (\<lambda>cte. \<exists>idx.  cteCap cte = UntypedCap False frame pageBits idx) parent s \<and>
      descendants_of' parent (ctes_of s) = {} \<and>
      slot \<noteq> parent \<and>
      ex_cte_cap_to' slot s \<and>
      sch_act_simple s \<and>
      is_aligned base asid_low_bits \<and> asid_wf base"

lemma vp_strgs':
  "valid_pspace' s \<longrightarrow> pspace_distinct' s"
  "valid_pspace' s \<longrightarrow> pspace_aligned' s"
  "valid_pspace' s \<longrightarrow> valid_mdb' s"
  by auto

lemma safe_parent_strg':
  "cte_wp_at' (\<lambda>cte. cteCap cte = UntypedCap False frame pageBits idx) p s \<and>
   descendants_of' p (ctes_of s) = {} \<and>
   valid_pspace' s
  \<longrightarrow> safe_parent_for' (ctes_of s) p (ArchObjectCap (ASIDPoolCap frame base))"
  apply (clarsimp simp: safe_parent_for'_def cte_wp_at_ctes_of)
  apply (case_tac cte)
  apply (simp add: isCap_simps)
  apply (subst conj_comms)
  apply (rule context_conjI)
   apply (drule ctes_of_valid_cap', fastforce)
   apply (clarsimp simp: valid_cap'_def capAligned_def)
   apply (drule is_aligned_no_overflow)
   apply (clarsimp simp: capRange_def asid_low_bits_def bit_simps)
  apply (clarsimp simp: sameRegionAs_def2 isCap_simps capRange_def asid_low_bits_def bit_simps)
  done

lemma descendants_of'_helper:
  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q (descendants_of' t (null_filter' (ctes_of s)))\<rbrace>
   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q (descendants_of' t (ctes_of s))\<rbrace>"
  apply (clarsimp simp:valid_def)
  apply (subst null_filter_descendants_of')
  prefer 2
   apply fastforce
  apply simp
  done

lemma createObject_typ_at':
  "\<lbrace>\<lambda>s.  koTypeOf ty = otype \<and> is_aligned ptr (objBitsKO ty) \<and>
         pspace_aligned' s \<and> pspace_no_overlap' ptr (objBitsKO ty) s\<rbrace>
   createObjects' ptr (Suc 0) ty 0
   \<lbrace>\<lambda>rv s. typ_at' otype ptr s\<rbrace>"
  supply
    is_aligned_neg_mask_eq[simp del]
    is_aligned_neg_mask_weaken[simp del]
  apply (clarsimp simp:createObjects'_def alignError_def split_def | wp hoare_unless_wp | wpc )+
  apply (clarsimp simp:obj_at'_def ko_wp_at'_def typ_at'_def pspace_distinct'_def)+
  apply (subgoal_tac "ps_clear ptr (objBitsKO ty)
    (s\<lparr>ksPSpace := \<lambda>a. if a = ptr then Some ty else ksPSpace s a\<rparr>)")
  apply (simp add:ps_clear_def)+
  apply (rule ccontr)
  apply (drule int_not_emptyD)
  apply clarsimp
  apply (unfold pspace_no_overlap'_def)
  apply (erule allE)+
  apply (erule(1) impE)
  apply (subgoal_tac "x \<in> mask_range x (objBitsKO y)")
   apply (fastforce simp: is_aligned_neg_mask_eq)
  apply (drule(1) pspace_alignedD')
  apply (clarsimp simp: is_aligned_no_overflow_mask)
  done

lemma retype_region2_ext_retype_region_ArchObject:
  "retype_region ptr n us (ArchObject x)=
  retype_region2 ptr n us (ArchObject x)"
  apply (rule ext)
  apply (simp add: retype_region_def retype_region2_def bind_assoc
                   retype_region2_ext_def retype_region_ext_def default_ext_def)
  apply (rule ext)
  apply (intro monad_eq_split_tail ext)+
     apply simp
    apply simp
   apply (simp add:gets_def get_def bind_def return_def simpler_modify_def )
   apply (rule_tac x = xc in fun_cong)
   apply (rule_tac f = do_extended_op in arg_cong)
   apply (rule ext)
   apply simp
  apply simp
  done

lemma set_cap_device_and_range_aligned:
  "is_aligned ptr sz \<Longrightarrow> \<lbrace>\<lambda>_. True\<rbrace>
    set_cap
     (cap.UntypedCap dev ptr sz idx)
     aref
    \<lbrace>\<lambda>rv s.
        \<exists>slot.
           cte_wp_at
            (\<lambda>c. cap_is_device c = dev \<and>
                 up_aligned_area ptr sz \<subseteq> cap_range c)
            slot s\<rbrace>"
  apply (subst is_aligned_neg_mask_eq[symmetric])
   apply simp
  apply (wp set_cap_device_and_range)
  done

lemma pac_corres:
  "asid_ci_map i = i' \<Longrightarrow>
  corres dc
         (einvs and ct_active and valid_aci i)
         (invs' and ct_active' and valid_aci' i')
         (perform_asid_control_invocation i)
         (performASIDControlInvocation i')"
  supply
    is_aligned_neg_mask_eq[simp del]
    is_aligned_neg_mask_weaken[simp del]
  apply (cases i)
  apply (rename_tac word1 prod1 prod2 word2)
  apply (clarsimp simp: asid_ci_map_def)
  apply (simp add: perform_asid_control_invocation_def placeNewObject_def2
                   performASIDControlInvocation_def)
  apply (rule corres_name_pre)
  apply (clarsimp simp:valid_aci_def valid_aci'_def cte_wp_at_ctes_of cte_wp_at_caps_of_state)
  apply (subgoal_tac "valid_cap' (capability.UntypedCap False word1 pageBits idx) s'")
   prefer 2
   apply (case_tac ctea)
   apply clarsimp
   apply (erule ctes_of_valid_cap')
   apply fastforce
  apply (frule valid_capAligned)
  apply (clarsimp simp: capAligned_def page_bits_def)
  apply (rule corres_guard_imp)
    apply (rule corres_split)
       prefer 2
       apply (erule detype_corres)
       apply (simp add:pageBits_def)
      apply (rule corres_split[OF _ getSlotCap_corres])
         apply (rule_tac F = " pcap = (cap.UntypedCap False word1 pageBits idxa)" in corres_gen_asm)
         apply (rule corres_split[OF _ updateFreeIndex_corres])
             apply (rule corres_split)
                prefer 2
                apply (simp add: retype_region2_ext_retype_region_ArchObject )
                apply (rule corres_retype [where ty="Inl (KOArch (KOASIDPool F))" for F,
                                           unfolded APIType_map2_def makeObjectKO_def,
                                           THEN createObjects_corres',simplified,
                                           where val = "makeObject::asidpool"])
                      apply simp
                     apply (simp add: objBits_simps obj_bits_api_def arch_kobj_size_def
                                      default_arch_object_def)+
                  apply (simp add: obj_relation_retype_def default_object_def
                                   default_arch_object_def objBits_simps)
                  apply (simp add: other_obj_relation_def asid_pool_relation_def)
                  apply (simp add: makeObject_asidpool const_def inv_def)
                 apply (rule range_cover_full)
                  apply (simp add:obj_bits_api_def arch_kobj_size_def default_arch_object_def)+
               apply (rule corres_split)
                  prefer 2
                  apply (rule cins_corres_simple, simp, rule refl, rule refl)
                 apply (rule_tac F="asid_low_bits_of word2 = 0" in corres_gen_asm)
                 apply (simp add: is_aligned_mask dc_def[symmetric])
                 apply (rule corres_split [where P=\<top> and P'=\<top> and r'="\<lambda>t t'. t = t' o ucast"])
                    prefer 2
                    apply (clarsimp simp: state_relation_def arch_state_relation_def)
                   apply (rule corres_trivial)
                   apply (rule corres_modify)
                   apply (thin_tac "x \<in> state_relation" for x)
                   apply (clarsimp simp: state_relation_def arch_state_relation_def o_def)
                   apply (rule ext)
                   apply (clarsimp simp: up_ucast_inj_eq)
                  apply wp+
              apply (strengthen safe_parent_strg[where idx = "2^pageBits"])
              apply (strengthen invs_valid_objs invs_distinct
                                invs_psp_aligned invs_mdb
                     | simp cong:conj_cong)+
              apply (wp retype_region_plain_invs[where sz = pageBits]
                        retype_cte_wp_at[where sz = pageBits])+
             apply (strengthen vp_strgs'
                    safe_parent_strg'[where idx = "2^pageBits"])
             apply (simp cong: conj_cong)
             apply (wp createObjects_valid_pspace'
                       [where sz = pageBits and ty="Inl (KOArch (KOASIDPool undefined))"])
                   apply (simp add: makeObjectKO_def)+
                 apply (simp add:objBits_simps range_cover_full valid_cap'_def)+
               apply (fastforce intro!: canonical_address_neq_mask simp: kernel_mappings_canonical)
              apply (rule in_kernel_mappings_neq_mask, (simp add: valid_cap'_def bit_simps)+)[1]
             apply (clarsimp simp:valid_cap'_def)
             apply (wp createObject_typ_at'
                       createObjects_orig_cte_wp_at'[where sz = pageBits])
             apply (rule descendants_of'_helper)
             apply (wp createObjects_null_filter'
                       [where sz = pageBits and ty="Inl (KOArch (KOASIDPool undefined))"])
            apply (clarsimp simp:is_cap_simps)
           apply (simp add: free_index_of_def)
          apply (clarsimp simp: conj_comms obj_bits_api_def arch_kobj_size_def
                                objBits_simps default_arch_object_def pred_conj_def)
          apply (clarsimp simp: conj_comms
                | strengthen invs_mdb invs_valid_pspace)+
          apply (simp add:region_in_kernel_window_def)
          apply (wp set_untyped_cap_invs_simple[where sz = pageBits]
                    set_cap_cte_wp_at
                    set_cap_caps_no_overlap[where sz = pageBits]
                    set_cap_no_overlap
                    set_cap_device_and_range_aligned[where dev = False,simplified]
                    set_untyped_cap_caps_overlap_reserved[where sz = pageBits])+
         apply (clarsimp simp: conj_comms obj_bits_api_def arch_kobj_size_def
                               objBits_simps default_arch_object_def
                               makeObjectKO_def range_cover_full
                         simp del: capFreeIndex_update.simps
                | strengthen invs_valid_pspace' invs_pspace_aligned'
                             invs_pspace_distinct'
                             exI[where x="makeObject :: asidpool"])+
         apply (wp updateFreeIndex_forward_invs'
                   updateFreeIndex_pspace_no_overlap'
                   updateFreeIndex_caps_no_overlap''
                   updateFreeIndex_descendants_of2
                   updateFreeIndex_cte_wp_at
                  updateFreeIndex_caps_overlap_reserved
             | simp add: descendants_of_null_filter' split del: if_split)+
       apply (wp get_cap_wp)+
     apply (subgoal_tac "word1 && ~~ mask pageBits = word1 \<and> pageBits \<le> word_bits \<and> word_size_bits \<le> pageBits")
      prefer 2
      apply (clarsimp simp:bit_simps word_bits_def is_aligned_neg_mask_eq)
     apply (simp only:delete_objects_rewrite)
     apply wp+
    apply (clarsimp simp: conj_comms)
    apply (clarsimp simp: conj_comms ex_disj_distrib
           | strengthen invs_valid_pspace' invs_pspace_aligned'
                        invs_pspace_distinct')+
    apply (wp deleteObjects_invs'[where p="makePoolParent i'"]
              deleteObjects_cte_wp_at'
              deleteObjects_descendants[where p="makePoolParent i'"])
    apply (clarsimp split del: if_split simp:valid_cap'_def)
    apply (wp hoare_vcg_ex_lift
              deleteObjects_caps_no_overlap''[where slot="makePoolParent i'"]
              deleteObject_no_overlap
              deleteObjects_ct_active'[where cref="makePoolParent i'"])
    apply (clarsimp simp: is_simple_cap_def valid_cap'_def max_free_index_def is_cap_simps
                    cong: conj_cong)
    apply (strengthen empty_descendants_range_in')
    apply (wp deleteObjects_descendants[where p="makePoolParent i'"]
              deleteObjects_cte_wp_at'
              deleteObjects_null_filter[where p="makePoolParent i'"])
   apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children)
   apply (subgoal_tac "detype_locale x y sa" for x y)
    prefer 2
    apply (simp add:detype_locale_def)
    apply (fastforce simp:cte_wp_at_caps_of_state descendants_range_def2
            empty_descendants_range_in invs_untyped_children)
   apply (intro conjI)
          apply (clarsimp)
         apply (erule(1) caps_of_state_valid)
         subgoal by (fastforce simp:cte_wp_at_caps_of_state descendants_range_def2 empty_descendants_range_in)
       apply (fold_subgoals (prefix))[2]
     subgoal premises prems using prems by (clarsimp simp:invs_def valid_state_def)+
     apply (clarsimp simp:cte_wp_at_caps_of_state)
    apply (drule detype_locale.non_null_present)
     apply (fastforce simp:cte_wp_at_caps_of_state)
    apply simp
   apply (frule_tac ptr = "(aa,ba)" in detype_invariants [rotated 3])
        apply fastforce
       apply simp
      apply (simp add: cte_wp_at_caps_of_state)
     apply (simp add: is_cap_simps)
    apply (simp add:empty_descendants_range_in descendants_range_def2)
   apply (frule intvl_range_conv[where bits = pageBits])
    apply (clarsimp simp:pageBits_def word_bits_def)
   apply (clarsimp simp: invs_valid_objs cte_wp_at_caps_of_state range_cover_full
                         invs_psp_aligned invs_distinct cap_master_cap_simps is_cap_simps
                         is_simple_cap_def)
   apply (clarsimp simp: conj_comms)
   apply (rule conjI, clarsimp simp: is_aligned_asid_low_bits_of_zero)
   apply (frule ex_cte_cap_protects)
        apply (simp add:cte_wp_at_caps_of_state)
       apply (simp add:empty_descendants_range_in)
      apply fastforce
     apply (rule subset_refl)
    apply fastforce
   apply (clarsimp simp: is_simple_cap_arch_def)
   apply (rule conjI, clarsimp)
   apply (rule conjI, clarsimp simp: clear_um_def)
   apply (simp add:detype_clear_um_independent)
   apply (rule conjI)
    apply clarsimp
    apply (drule_tac p = "(aa,ba)" in cap_refs_in_kernel_windowD2[OF caps_of_state_cteD])
     apply fastforce
    apply (clarsimp simp: region_in_kernel_window_def valid_cap_def
                          cap_aligned_def is_aligned_neg_mask_eq detype_def clear_um_def)
    apply fastforce
   apply (rule conjI,erule caps_no_overlap_detype[OF descendants_range_caps_no_overlapI])
     apply (clarsimp simp:is_aligned_neg_mask_eq cte_wp_at_caps_of_state)
     apply (simp add:empty_descendants_range_in)+
   apply (rule conjI, rule pspace_no_overlap_subset,
         rule pspace_no_overlap_detype[OF caps_of_state_valid])
        apply (simp add:invs_psp_aligned invs_valid_objs is_aligned_neg_mask_eq)+
   apply (clarsimp simp: detype_def clear_um_def detype_ext_def valid_sched_def valid_etcbs_def
            st_tcb_at_kh_def obj_at_kh_def st_tcb_at_def obj_at_def is_etcb_at_def)
  apply (simp add: detype_def clear_um_def)
  apply (drule_tac x = "cte_map (aa,ba)" in pspace_relation_cte_wp_atI[OF state_relation_pspace_relation])
    apply (simp add:invs_valid_objs)+
  apply clarsimp
  apply (drule cte_map_inj_eq)
       apply ((fastforce simp:cte_wp_at_caps_of_state)+)[5]
  apply (clarsimp simp:cte_wp_at_caps_of_state invs_valid_pspace' conj_comms cte_wp_at_ctes_of
                       valid_cap_simps')
  apply (strengthen refl)
  apply clarsimp
  apply (frule empty_descendants_range_in')
  apply (intro conjI,
    simp_all add: is_simple_cap'_def isCap_simps descendants_range'_def2
                  null_filter_descendants_of'[OF null_filter_simp']
                  capAligned_def asid_low_bits_def)
      apply (erule descendants_range_caps_no_overlapI')
       apply (fastforce simp:cte_wp_at_ctes_of is_aligned_neg_mask_eq)
      apply (simp add:empty_descendants_range_in')
     apply (simp add:word_bits_def bit_simps)
    apply (rule is_aligned_weaken)
     apply (rule is_aligned_shiftl_self[unfolded shiftl_t2n,where p = 1,simplified])
    apply (simp add:pageBits_def)
   apply clarsimp
   apply (drule(1) cte_cap_in_untyped_range)
        apply (fastforce simp:cte_wp_at_ctes_of)
       apply assumption+
    apply fastforce
   apply simp
  apply clarsimp
  apply (drule (1) cte_cap_in_untyped_range)
       apply (fastforce simp add: cte_wp_at_ctes_of)
      apply assumption+
    apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of)
   apply fastforce
  apply simp
  done

definition
  archinv_relation :: "arch_invocation \<Rightarrow> Arch.invocation \<Rightarrow> bool"
where
  "archinv_relation ai ai' \<equiv> case ai of
     arch_invocation.InvokePageTable pti \<Rightarrow>
       \<exists>pti'. ai' = InvokePageTable pti' \<and> page_table_invocation_map pti pti'
   | arch_invocation.InvokePage pgi \<Rightarrow>
       \<exists>pgi'. ai' = InvokePage pgi' \<and> page_invocation_map pgi pgi'
   | arch_invocation.InvokeASIDControl aci \<Rightarrow>
       \<exists>aci'. ai' = InvokeASIDControl aci' \<and> aci' = asid_ci_map aci
   | arch_invocation.InvokeASIDPool ap \<Rightarrow>
       \<exists>ap'. ai' = InvokeASIDPool ap' \<and>  ap' = asid_pool_invocation_map ap"

definition
  valid_arch_inv' :: "Arch.invocation \<Rightarrow> kernel_state \<Rightarrow> bool"
where
  "valid_arch_inv' ai \<equiv> case ai of
     InvokePageTable pti \<Rightarrow> valid_pti' pti
   | InvokePage pgi \<Rightarrow> valid_page_inv' pgi
   | InvokeASIDControl aci \<Rightarrow> valid_aci' aci
   | InvokeASIDPool ap \<Rightarrow> valid_apinv' ap"

lemma mask_vmrights_corres:
  "maskVMRights (vmrights_map R) (rightsFromWord d) =
  vmrights_map (mask_vm_rights R (data_to_rights d))"
  by (clarsimp simp: rightsFromWord_def data_to_rights_def
                     vmrights_map_def Let_def maskVMRights_def
                     mask_vm_rights_def nth_ucast
                     validate_vm_rights_def vm_read_write_def
                     vm_kernel_only_def vm_read_only_def
               split: bool.splits)

lemma vm_attributes_corres:
  "vmattributes_map (attribs_from_word w) = attribsFromWord w"
  by (clarsimp simp: attribsFromWord_def attribs_from_word_def
                     Let_def vmattributes_map_def)

lemma check_vp_corres:
  "corres (ser \<oplus> dc) \<top> \<top>
          (check_vp_alignment sz w)
          (checkVPAlignment sz w)"
  apply (simp add: check_vp_alignment_def checkVPAlignment_def)
  apply (cases sz, simp_all add: corres_returnOk unlessE_whenE is_aligned_mask)
     apply ((rule corres_guard_imp, rule corres_whenE, rule refl, auto)[1])+
  done

lemma checkVP_wpR [wp]:
  "\<lbrace>\<lambda>s. vmsz_aligned w sz \<longrightarrow> P () s\<rbrace>
  checkVPAlignment sz w \<lbrace>P\<rbrace>, -"
  apply (simp add: checkVPAlignment_def unlessE_whenE cong: vmpage_size.case_cong)
  apply (rule hoare_pre)
   apply (wp hoare_whenE_wp|wpc)+
  apply (simp add: is_aligned_mask vmsz_aligned_def)
  done

lemma asidHighBits [simp]:
  "asidHighBits = asid_high_bits"
  by (simp add: asidHighBits_def asid_high_bits_def)

declare word_unat_power [symmetric, simp del]

lemma case_option_corresE:
  assumes nonec: "corres r Pn Qn (nc >>=E f) (nc' >>=E g)"
  and     somec: "\<And>v'. corres r (Ps v') (Qs v') (sc v' >>=E f) (sc' v' >>=E g)"
  shows "corres r (case_option Pn Ps v) (case_option Qn Qs v) (case_option nc sc v >>=E f) (case_option nc' sc' v >>=E g)"
  apply (cases v)
   apply simp
   apply (rule nonec)
  apply simp
  apply (rule somec)
  done

lemma cap_relation_Untyped_eq:
  "cap_relation c (UntypedCap d p sz f) = (c = cap.UntypedCap d p sz f)"
  by (cases c) auto

declare check_vp_alignment_inv[wp del]

lemma select_ext_fa:
  "free_asid_select asid_tbl \<in> S
  \<Longrightarrow> ((select_ext (\<lambda>_. free_asid_select asid_tbl) S) :: _ det_ext_monad)
   = return (free_asid_select asid_tbl)"
  by (simp add: select_ext_def get_def gets_def bind_def assert_def return_def fail_def)

lemma select_ext_fap:
  "free_asid_pool_select p b \<in> S
  \<Longrightarrow> ((select_ext (\<lambda>_. free_asid_pool_select p b) S) :: _ det_ext_monad)
   = return (free_asid_pool_select p b)"
  by (simp add: select_ext_def get_def gets_def bind_def assert_def return_def)

lemmas vmsz_aligned_imp_aligned
    = vmsz_aligned_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN is_aligned_weaken]

lemma check_slot_corres:
  "(\<And>pte pte'. pte_relation' pte pte' \<Longrightarrow> test' pte' = test pte) \<Longrightarrow>
   corres (ser \<oplus> dc)
          (pte_at p and pspace_aligned and pspace_distinct) \<top>
          (check_slot p test)
          (checkSlot p test')"
  apply (simp add: check_slot_def checkSlot_def unlessE_whenE liftE_bindE)
  apply (rule corres_guard_imp)
    apply (rule corres_split[OF _ get_pte_corres])
      apply (rule corres_whenE, simp)
       apply (rule corres_trivial, simp)
      apply simp
     apply wpsimp+
  done

lemma vmrights_map_vm_kernel_only[simp]:
  "vmrights_map vm_kernel_only = VMKernelOnly"
  by (simp add: vmrights_map_def vm_kernel_only_def)

lemma not_in_vm_kernel_only[simp]:
  "x \<notin> vm_kernel_only"
  by (simp add: vm_kernel_only_def)

lemma vmrights_map_VMKernelOnly:
  "vmrights_map (mask_vm_rights R r) = VMKernelOnly \<Longrightarrow> mask_vm_rights R r = vm_kernel_only"
  by (auto simp: vmrights_map_def mask_vm_rights_def validate_vm_rights_def vm_read_write_def
                 vm_read_only_def split: if_splits)

lemma machine_word_len_pageBits_shift[simp]:
  "UCAST(pte_ppn_len \<rightarrow> machine_word_len) (UCAST(machine_word_len \<rightarrow> pte_ppn_len) (p >> pageBits))
   = p >> pageBits"
  apply (simp add: ucast_ucast_mask pageBits_def)
  apply word_bitwise
  apply (simp add: word_size)
  done

lemma pte_relation_make_user[simp]:
  "pte_relation'
     (make_user_pte p (attribs_from_word a) (mask_vm_rights R (data_to_rights r)))
     (makeUserPTE p (\<not>attribsFromWord a) (maskVMRights (vmrights_map R) (rightsFromWord r)))"
  by (auto simp: make_user_pte_def makeUserPTE_def attribs_from_word_def user_attr_def
                 attribsFromWord_def mask_vmrights_corres vmrights_map_VMKernelOnly)

lemma below_user_vtop_in_user_region:
  "p < user_vtop \<Longrightarrow> p \<in> user_region"
  apply (simp add: user_region_def canonical_user_def user_vtop_def pptrUserTop_def RISCV64.pptrUserTop_def)
  apply (simp add: bit_simps is_aligned_mask canonical_bit_def)
  by (word_bitwise, clarsimp simp: word_size)

lemma vmsz_aligned_user_region:
  "\<lbrakk> vmsz_aligned p sz;  p + (2 ^ pageBitsForSize sz - 1) < RISCV64_H.pptrUserTop \<rbrakk>
   \<Longrightarrow> p \<in> user_region"
  using pbfs_atleast_pageBits[of sz]
  apply (simp flip: mask_2pm1 add: vmsz_aligned_def)
  apply (simp add: user_region_def canonical_user_def pptrUserTop_def RISCV64.pptrUserTop_def)
  apply (simp add: bit_simps is_aligned_mask canonical_bit_def word_plus_and_or_coroll)
  by (word_bitwise, clarsimp simp: word_size)

lemma decode_page_inv_corres:
  "\<lbrakk>cap = arch_cap.FrameCap p R sz d opt; acap_relation cap cap';
    list_all2 cap_relation (map fst excaps) (map fst excaps');
    list_all2 (\<lambda>s s'. s' = cte_map s) (map snd excaps) (map snd excaps') \<rbrakk> \<Longrightarrow>
     corres (ser \<oplus> archinv_relation)
            (invs and valid_cap (cap.ArchObjectCap cap) and
             cte_wp_at ((=) (cap.ArchObjectCap cap)) slot and
             (\<lambda>s. \<forall>x\<in>set excaps. s \<turnstile> fst x \<and> cte_wp_at (\<lambda>_. True) (snd x) s))
            (invs' and valid_cap' (capability.ArchObjectCap cap') and
             (\<lambda>s. \<forall>x\<in>set excaps'. valid_cap' (fst x) s \<and> cte_wp_at' (\<lambda>_. True) (snd x) s))
            (decode_frame_invocation l args slot cap excaps)
            (decodeRISCVFrameInvocation l args (cte_map slot) cap' excaps')"
  apply (simp add: decode_frame_invocation_def decodeRISCVFrameInvocation_def Let_def isCap_simps
        split del: if_split)
  apply (cases "invocation_type l = ArchInvocationLabel RISCVPageMap")
   apply (case_tac "\<not>(2 < length args \<and> excaps \<noteq> [])")
    apply (auto simp: decode_fr_inv_map_def split: list.split)[1]
   apply (simp add: decode_fr_inv_map_def Let_def neq_Nil_conv)
   apply (elim exE conjE)
   apply (simp split: list.split, intro conjI impI allI, simp_all)[1]
   apply (simp add: decodeRISCVFrameInvocationMap_def)
   apply (simp split: cap.split, intro conjI impI allI, simp_all)[1]
   apply (rename_tac arch_capa)
   apply (case_tac arch_capa, simp_all)[1]
   apply (rename_tac wd opt')
   apply (case_tac opt'; simp add: mdata_map_def)
   apply (rename_tac av, case_tac av, simp)
   apply (rename_tac a v)
   apply (rule corres_guard_imp)
     apply (rule corres_splitEE)
        prefer 2
        apply (rule corres_lookup_error)
        apply (rule find_vspace_for_asid_corres[OF refl])
       apply (rule whenE_throwError_corres, simp, simp)
       apply (rule corres_splitEE[where r'=dc])
          prefer 2
          apply (rule corres_whenE)
            apply (simp add: pptr_base_def user_vtop_def pptrUserTop_def shiftl_t2n mask_def)
           apply (rule corres_trivial, simp)
          apply simp
         apply (rule corres_splitEE[where r'=dc])
            prefer 2
            apply (rule check_vp_corres)
           apply (rule corres_splitEE)
              prefer 2
              apply (simp only: corres_liftE_rel_sum)
              apply (rule lookup_pt_slot_corres)
             apply (clarsimp simp: unlessE_whenE)
             apply (rule corres_splitEE[where r'=dc])
                prefer 2
                apply datatype_schem
                apply (rule corres_whenE, simp)
                 apply (rule corres_trivial, clarsimp simp: lookup_failure_map_def)
                apply simp
               apply (rule corres_splitEE[where r'=dc])
                  prefer 2
                  apply (cases opt; clarsimp)
                   apply (fold ser_def)
                   apply (rule check_slot_corres)
                   apply fastforce
                  apply (rule corres_guard_imp)
                    apply (rule whenE_throwError_corres)
                      apply fastforce
                     apply (rule up_ucast_inj_eq[THEN arg_cong_Not, symmetric], simp)
                    apply (rule whenE_throwError_corres)
                      apply fastforce
                     apply presburger
                    apply (rule check_slot_corres)
                    apply (case_tac pte; simp add: is_PageTablePTE_def RISCV64_H.isPageTablePTE_def)
                   apply blast
                  apply blast
                 apply (rule corres_trivial, rule corres_returnOk)
                 apply (clarsimp simp: archinv_relation_def page_invocation_map_def mapping_map_def)
                apply (wpsimp simp: if_apply_def2
                              wp: validE_validE_R[OF find_vspace_for_asid_wp, simplified])+
    apply (clarsimp simp: invs_psp_aligned invs_distinct invs_vspace_objs invs_valid_asid_table
                          cte_wp_at_caps_of_state is_cap_simps)
    apply (rule conjI; clarsimp?)
     apply (clarsimp simp: valid_cap_def wellformed_mapdata_def)
    apply (rule conjI)
     apply (rule exI)+
     apply (rule conjI, erule vspace_for_asid_vs_lookup, simp)
    apply (rule conjI)
     apply (simp add: not_le vmsz_aligned_user_region[unfolded pptrUserTop_def] mask_def user_vtop_def)
    apply clarsimp
    apply (drule (1) pt_lookup_slot_vs_lookup_slotI, clarsimp)
    apply (erule vs_lookup_slot_pte_at; assumption?)
    apply (simp add: not_le vmsz_aligned_user_region[unfolded pptrUserTop_def] mask_def user_vtop_def)
   apply fastforce
  \<comment> \<open>PageUnmap\<close>
  apply (simp split del: if_split)
  apply (cases "invocation_type l = ArchInvocationLabel RISCVPageUnmap")
   apply simp
   apply (rule corres_returnOk)
   apply (clarsimp simp: archinv_relation_def page_invocation_map_def)
  \<comment> \<open>PageGetAddress\<close>
  apply (cases "invocation_type l = ArchInvocationLabel RISCVPageGetAddress")
   apply simp
   apply (rule corres_returnOk)
   apply (clarsimp simp: archinv_relation_def page_invocation_map_def)
  by (clarsimp split: invocation_label.splits arch_invocation_label.splits split del: if_split)

lemma VMReadWrite_vmrights_map[simp]: "vmrights_map vm_read_write = VMReadWrite"
  by (simp add: vmrights_map_def vm_read_write_def)

lemma gets_vspace_for_asid_is_catch:
  "gets (vspace_for_asid a) = ((liftME Some (find_vspace_for_asid a)) <catch> const (return None))"
  apply (simp add: find_vspace_for_asid_def liftME_def liftE_bindE catch_def)
  apply (rule ext)
  apply (clarsimp simp: bind_def simpler_gets_def throw_opt_def bindE_def throwError_def return_def
                        returnOk_def
                  split: option.splits)
  done

lemma maybeVSpaceForASID_corres:
  "a' = ucast a \<Longrightarrow>
   corres (=)
          (valid_vspace_objs and valid_asid_table and pspace_aligned and pspace_distinct
             and K (0 < a))
          no_0_obj'
          (gets (vspace_for_asid a)) (maybeVSpaceForASID a')"
  apply (simp add: maybeVSpaceForASID_def gets_vspace_for_asid_is_catch)
  apply (rule corres_guard_imp)
    apply (rule corres_split_catch)
       apply (rule corres_trivial, simp)
      apply (simp add: o_def)
      apply (rule find_vspace_for_asid_corres, simp)
     apply wpsimp+
  done

crunches isFinalCapability
  for no_0_obj'[wp]: no_0_obj'
  (simp: crunch_simps wp: crunch_wps)

lemma decode_page_table_inv_corres:
  "\<lbrakk>cap = arch_cap.PageTableCap p opt; acap_relation cap cap';
    list_all2 cap_relation (map fst excaps) (map fst excaps');
    list_all2 (\<lambda>s s'. s' = cte_map s) (map snd excaps) (map snd excaps') \<rbrakk> \<Longrightarrow>
     corres (ser \<oplus> archinv_relation)
            (invs and valid_cap (cap.ArchObjectCap cap) and
             cte_wp_at ((=) (cap.ArchObjectCap cap)) slot and
             (\<lambda>s. \<forall>x\<in>set excaps. s \<turnstile> fst x \<and> cte_wp_at (\<lambda>_. True) (snd x) s))
            (invs' and valid_cap' (capability.ArchObjectCap cap') and
             (\<lambda>s. \<forall>x\<in>set excaps'. valid_cap' (fst x) s \<and> cte_wp_at' (\<lambda>_. True) (snd x) s))
            (decode_page_table_invocation l args slot cap excaps)
            (decodeRISCVPageTableInvocation l args (cte_map slot) cap' excaps')"
  apply (simp add: decode_page_table_invocation_def decodeRISCVPageTableInvocation_def Let_def
                   isCap_simps
              split del: if_split)
  apply (cases "invocation_type l = ArchInvocationLabel RISCVPageTableMap")
   apply (simp add: decode_pt_inv_map_def
               split: invocation_label.split arch_invocation_label.splits split del: if_split)
   apply (simp split: list.split, intro conjI impI allI, simp_all)[1]
   apply (clarsimp simp: neq_Nil_conv Let_def decodeRISCVPageTableInvocationMap_def)
   apply (rule whenE_throwError_corres_initial; (fastforce simp: mdata_map_def)?)
   apply (simp split: cap.split arch_cap.split option.split,
             intro conjI allI impI, simp_all)[1]
   apply (rule whenE_throwError_corres_initial; simp?)
    apply (simp add: user_vtop_def pptrUserTop_def)
   apply (rule corres_guard_imp)
     apply (rule corres_splitEE)
        prefer 2
        apply (rule corres_lookup_error)
        apply (rule find_vspace_for_asid_corres[OF refl])
       apply (rule whenE_throwError_corres, simp, simp)
       apply (rule corres_splitEE)
          prefer 2
          apply (simp)
          apply (rule lookup_pt_slot_corres)
         apply clarsimp
         apply (rule corres_splitEE)
            prefer 2
            apply simp
            apply datatype_schem
            apply (rule get_pte_corres)
           apply (simp add: unlessE_whenE)
           apply (rule corres_splitEE[where r'=dc])
              prefer 2
              apply (rule corres_whenE)
                apply clarsimp
                apply (case_tac old_pte; simp)
               apply (rule corres_trivial, simp)
              apply simp
             apply (rule corres_trivial, rule corres_returnOk)
             apply (clarsimp simp: archinv_relation_def page_table_invocation_map_def
                                   ucast_ucast_mask)
             apply (subst word_le_mask_eq; simp?)
             apply (rule leq_mask_shift)
             apply (simp add: bit_simps le_mask_high_bits word_size)
            apply ((clarsimp cong: if_cong
                     | wp hoare_whenE_wp hoare_vcg_all_lift_R getPTE_wp get_pte_wp
                     | wp (once) hoare_drop_imps)+)
    apply (clarsimp simp: invs_vspace_objs invs_valid_asid_table invs_psp_aligned invs_distinct)
    apply (clarsimp simp: valid_cap_def wellformed_mapdata_def not_le below_user_vtop_in_user_region)
    apply (rule conjI)
     apply (rule exI)+
     apply (rule conjI, erule vspace_for_asid_vs_lookup, simp)
    apply clarsimp
    apply (drule (1) pt_lookup_slot_vs_lookup_slotI, clarsimp)
    apply (erule vs_lookup_slot_pte_at; simp add: below_user_vtop_in_user_region)
   apply fastforce
    \<comment> \<open>PageTableUnmap\<close>
  apply (clarsimp simp: isCap_simps)+
  apply (cases "invocation_type l = ArchInvocationLabel RISCVPageTableUnmap")
   apply (clarsimp simp: unlessE_whenE liftE_bindE)
   apply (rule stronger_corres_guard_imp)
     apply (rule corres_symb_exec_r_conj)
        apply (rule_tac F="isArchCap isPageTableCap (cteCap cteVal)"
                                 in corres_gen_asm2)
        apply (rule corres_split[OF _ final_cap_corres[where ptr=slot]])
          apply (drule mp)
           apply (clarsimp simp: isCap_simps final_matters'_def)
          apply (rule whenE_throwError_corres; simp)
          apply (rule option_corres)
            apply (cases opt; simp add: mdata_map_def)
            apply (rule corres_trivial, simp add: returnOk_def archinv_relation_def
                                                  page_table_invocation_map_def)
           apply (cases opt, clarsimp simp: mdata_map_def)
           apply (clarsimp simp: bind_bindE_assoc)
           apply (rule corres_split)
              prefer 2
              apply datatype_schem
              apply (rule maybeVSpaceForASID_corres, simp)
             apply (rule whenE_throwError_corres; simp)
             apply (rule corres_trivial, simp add: returnOk_def archinv_relation_def
                                                   page_table_invocation_map_def)
            apply (simp|wp)+
          apply (cases opt; simp add: mdata_map_def)
         apply (simp | wp getCTE_wp' | wp (once) hoare_drop_imps)+
      apply (clarsimp)
     apply (rule no_fail_pre, rule no_fail_getCTE)
     apply (erule conjunct2)
    apply (clarsimp simp: cte_wp_at_caps_of_state invs_vspace_objs
                          invs_valid_asid_table invs_psp_aligned invs_distinct)
    apply (clarsimp simp: valid_cap_def wellformed_mapdata_def)
   apply (clarsimp simp: cte_wp_at_ctes_of cap_rights_update_def acap_rights_update_def
                         cte_wp_at_caps_of_state)
   apply (drule pspace_relation_ctes_ofI[OF _ caps_of_state_cteD, rotated],
                erule invs_pspace_aligned', clarsimp+)
   apply (simp add: isCap_simps invs_no_0_obj')
  apply (simp add: isCap_simps split del: if_split)
  by (clarsimp split: invocation_label.splits arch_invocation_label.splits)

lemma dec_arch_inv_corres:
notes check_vp_inv[wp del] check_vp_wpR[wp]
  (* FIXME: check_vp_inv shadowed check_vp_wpR.  Instead,
     check_vp_wpR should probably be generalised to replace check_vp_inv. *)
shows
  "\<lbrakk> acap_relation arch_cap arch_cap';
     list_all2 cap_relation (map fst excaps) (map fst excaps');
     list_all2 (\<lambda>s s'. s' = cte_map s) (map snd excaps) (map snd excaps') \<rbrakk> \<Longrightarrow>
   corres
   (ser \<oplus> archinv_relation)
   (invs and valid_cap (cap.ArchObjectCap arch_cap) and
        cte_wp_at ((=) (cap.ArchObjectCap arch_cap)) slot and
     (\<lambda>s. \<forall>x\<in>set excaps. s \<turnstile> fst x \<and> cte_at (snd x) s))
   (invs' and valid_cap' (capability.ArchObjectCap arch_cap') and
     (\<lambda>s. \<forall>x\<in>set excaps'. s \<turnstile>' fst x \<and> cte_at' (snd x) s))
   (arch_decode_invocation (mi_label mi) args (to_bl cptr') slot
      arch_cap excaps)
   (Arch.decodeInvocation (mi_label mi) args cptr'
     (cte_map slot) arch_cap' excaps')"
  apply (simp add: arch_decode_invocation_def
                   RISCV64_H.decodeInvocation_def
                   decodeRISCVMMUInvocation_def
              split del: if_split)
  apply (cases arch_cap)
     \<comment> \<open>ASIDPoolCap\<close>
     apply (simp add: isCap_simps decodeRISCVMMUInvocation_def decode_asid_pool_invocation_def
                      decodeRISCVASIDPoolInvocation_def Let_def
                 split del: if_split)
     apply (cases "invocation_type (mi_label mi) \<noteq> ArchInvocationLabel RISCVASIDPoolAssign")
      apply (simp split: invocation_label.split arch_invocation_label.split)
     apply (rename_tac word1 word2)
     apply (cases "excaps", simp)
     apply (cases "excaps'", simp)
     apply clarsimp
     apply (case_tac a, simp_all)[1]
     apply (rename_tac arch_capa)
     apply (case_tac arch_capa, simp_all)[1]
     apply (rename_tac word3 option)
     apply (case_tac option, simp_all add: mdata_map_def)[1]
     apply (rule corres_guard_imp)
       apply (rule corres_splitEE)
          prefer 2
          apply (rule corres_trivial [where r="ser \<oplus> (\<lambda>p p'. p = p' o ucast)"])
          apply (clarsimp simp: state_relation_def arch_state_relation_def)
         apply (rule whenE_throwError_corres, simp)
           apply (simp add: lookup_failure_map_def)
          apply simp
         apply (rule_tac P="\<lambda>s. (asid_table (asid_high_bits_of word2) = Some word1 \<longrightarrow> asid_pool_at word1 s) \<and>
                                pspace_aligned s \<and> pspace_distinct s \<and> is_aligned word2 asid_low_bits" and
                         P'="\<top>" in corres_inst)
         apply (simp add: liftME_return)
         apply (rule whenE_throwError_corres_initial, simp)
          apply auto[1]
         apply (rule corres_guard_imp)
           apply (rule corres_splitEE)
              prefer 2
              apply simp
              apply (rule get_asid_pool_corres_inv'[OF refl])
             apply (simp add: bindE_assoc)
             apply (rule_tac F="is_aligned word2 asid_low_bits" in corres_gen_asm)
             apply (rule corres_splitEE)
                prefer 2
                apply (rule corres_whenE)
                  apply (subst conj_assoc [symmetric])
                  apply (subst assocs_empty_dom_comp [symmetric])
                  apply (erule dom_ucast_eq)
                 apply (rule corres_trivial)
                 apply simp
                apply simp
               apply (rule_tac F="- dom pool \<inter> {x. ucast x + word2 \<noteq> 0} \<noteq> {}" in corres_gen_asm)
               apply (frule dom_hd_assocsD)
               apply (simp add: select_ext_fap[simplified free_asid_pool_select_def]
                                free_asid_pool_select_def)
               apply (simp add: returnOk_liftE[symmetric])
               apply (rule corres_returnOk)
               apply (simp add: archinv_relation_def asid_pool_invocation_map_def)
              apply (rule hoare_pre, wp hoare_whenE_wp)
              apply (clarsimp simp: ucast_fst_hd_assocs)
             apply (wp hoareE_TrueI hoare_whenE_wp getASID_wp | simp)+
          apply ((clarsimp simp: p2_low_bits_max | rule TrueI impI)+)[2]
        apply (wp hoare_whenE_wp getASID_wp)+
      apply (auto simp: valid_cap_def)[1]
     apply auto[1]
    \<comment> \<open>ASIDControlCap\<close>
    apply (simp add: isCap_simps decodeRISCVMMUInvocation_def decode_asid_control_invocation_def
                     Let_def decodeRISCVASIDControlInvocation_def
                split del: if_split)
    apply (cases "invocation_type (mi_label mi) \<noteq> ArchInvocationLabel RISCVASIDControlMakePool")
     apply (simp split: invocation_label.split arch_invocation_label.split)
    apply (subgoal_tac "length excaps' = length excaps")
     prefer 2
     apply (simp add: list_all2_iff)
    apply (cases args, simp)
    apply (rename_tac a0 as)
    apply (case_tac as, simp)
    apply (rename_tac a1 as')
    apply (cases excaps, simp)
    apply (rename_tac excap0 exs)
    apply (case_tac exs)
     apply (auto split: list.split)[1]
    apply (rename_tac excap1 exss)
    apply (case_tac excap0)
    apply (rename_tac c0 slot0)
    apply (case_tac excap1)
    apply (rename_tac c1 slot1)
    apply (clarsimp simp: Let_def split del: if_split)
    apply (cases excaps', simp)
    apply (case_tac list, simp)
    apply (rename_tac c0' exs' c1'  exss')
    apply (clarsimp split del: if_split)
    apply (rule corres_guard_imp)
      apply (rule corres_splitEE [where r'="\<lambda>p p'. p = p' o ucast"])
         prefer 2
         apply (rule corres_trivial)
         apply (clarsimp simp: state_relation_def arch_state_relation_def)
        apply (rule corres_splitEE)
           prefer 2
           apply (rule corres_whenE)
             apply (subst assocs_empty_dom_comp [symmetric])
             apply (simp add: o_def)
             apply (rule dom_ucast_eq_8)
            apply (rule corres_trivial, simp, simp)
          apply (simp split del: if_split)
          apply (rule_tac F="- dom (asidTable \<circ> ucast) \<inter> {x. x \<le> 2 ^ asid_high_bits - 1} \<noteq> {}" in corres_gen_asm)
          apply (drule dom_hd_assocsD)
          apply (simp add: select_ext_fa[simplified free_asid_select_def]
                     free_asid_select_def o_def returnOk_liftE[symmetric] split del: if_split)
          apply (thin_tac "fst a \<notin> b \<and> P" for a b P)
          apply (case_tac "isUntypedCap a \<and> capBlockSize a = objBits (makeObject::asidpool) \<and> \<not> capIsDevice a")
           prefer 2
           apply (rule corres_guard_imp)
             apply (rule corres_trivial)
             apply (case_tac ad; simp add: isCap_simps split del: if_split)
              apply (case_tac x21; simp split del: if_split)
              apply (clarsimp simp: objBits_simps split del: if_split)
             apply clarsimp
            apply (rule TrueI)+
          apply (clarsimp simp: isCap_simps cap_relation_Untyped_eq lookupTargetSlot_def
                                objBits_simps bindE_assoc split_def)
          apply (rule corres_splitEE)
             prefer 2
             apply (rule ensure_no_children_corres, rule refl)
            apply (rule corres_splitEE)
               prefer 2
               apply (erule lsfc_corres, rule refl)
              apply (rule corres_splitEE)
                 prefer 2
                 apply (rule ensure_empty_corres)
                 apply clarsimp
                apply (rule corres_returnOk[where P="\<top>"])
                apply (clarsimp simp add: archinv_relation_def asid_ci_map_def split_def)
                apply (clarsimp simp add: ucast_assocs[unfolded o_def] split_def
                                          filter_map asid_high_bits_def)
                apply (simp add: ord_le_eq_trans [OF word_n1_ge])
               apply (wp hoare_drop_imps)+
     apply (simp add: o_def validE_R_def)
     apply (fastforce simp: asid_high_bits_def)
    apply clarsimp
    apply (simp add: null_def split_def asid_high_bits_def  word_le_make_less)
    apply (subst hd_map, assumption)
    (* need abstract guard to show list nonempty *)
    apply (simp add: word_le_make_less)
    apply (simp add: ucast_ucast_mask2 is_down)
    apply (frule hd_in_set)
    apply clarsimp
    apply (prop_tac "\<forall>x::machine_word. x < 2^asid_high_bits \<longrightarrow> x && mask asid_high_bits = x")
     apply (clarsimp simp: and_mask_eq_iff_le_mask le_mask_iff_lt_2n[THEN iffD1] asid_high_bits_def)
    apply (simp add: asid_high_bits_def)
    apply (erule allE, erule (1) impE)
    apply (simp add: ucast_shiftl)
    apply (subst ucast_ucast_len)
     apply (drule hd_in_set)
     apply (rule shiftl_less_t2n; simp add: asid_low_bits_def)
    apply (fastforce)

   \<comment> \<open>PageCap\<close>
   apply (rename_tac word cap_rights vmpage_size option)
   apply (simp add: isCap_simps decodeRISCVMMUInvocation_def Let_def split del: if_split)
   apply (rule decode_page_inv_corres; simp)

  \<comment> \<open>PageTableCap\<close>
  apply (simp add: isCap_simps decodeRISCVMMUInvocation_def Let_def  split del: if_split)
  apply (rule decode_page_table_inv_corres; simp)
  done

lemma inv_arch_corres:
  "archinv_relation ai ai' \<Longrightarrow>
   corres (intr \<oplus> (=))
     (einvs and ct_active and valid_arch_inv ai)
     (invs' and ct_active' and valid_arch_inv' ai')
     (arch_perform_invocation ai) (Arch.performInvocation ai')"
  apply (clarsimp simp: arch_perform_invocation_def
                        RISCV64_H.performInvocation_def
                        performRISCVMMUInvocation_def)
  apply (clarsimp simp: archinv_relation_def)
  apply (cases ai)
     apply (clarsimp simp: archinv_relation_def performRISCVMMUInvocation_def)
     apply (rule corres_guard_imp, rule corres_split_nor, rule corres_trivial, simp)
         apply (rule perform_page_table_corres; wpsimp)
        apply wpsimp+
      apply (fastforce simp: valid_arch_inv_def)
     apply (fastforce simp: valid_arch_inv'_def)
    apply (clarsimp simp: archinv_relation_def)
    apply (rule corres_guard_imp, rule corres_split_nor, rule corres_trivial, simp)
        apply (rule perform_page_corres; wpsimp)
       apply wpsimp+
     apply (fastforce simp: valid_arch_inv_def)
    apply (fastforce simp: valid_arch_inv'_def)
   apply (clarsimp simp: archinv_relation_def)
   apply (rule corres_guard_imp, rule corres_split_nor, rule corres_trivial, simp)
       apply (rule pac_corres; wpsimp)
      apply wpsimp+
    apply (fastforce simp: valid_arch_inv_def)
   apply (fastforce simp: valid_arch_inv'_def)
  apply (clarsimp simp: archinv_relation_def)
  apply (rule corres_guard_imp, rule corres_split_nor, rule corres_trivial, simp)
      apply (rule pap_corres; wpsimp)
     apply wpsimp+
   apply (fastforce simp: valid_arch_inv_def)
  apply (fastforce simp: valid_arch_inv'_def)
  done

lemma asid_pool_typ_at_ext':
  "asid_pool_at' = obj_at' (\<top>::asidpool \<Rightarrow> bool)"
  apply (rule ext)+
  apply (simp add: typ_at_to_obj_at_arches)
  done

lemma st_tcb_strg':
  "st_tcb_at' P p s \<longrightarrow> tcb_at' p s"
  by (auto simp: pred_tcb_at')

lemma performASIDControlInvocation_tcb_at':
  "\<lbrace>st_tcb_at' active' p and invs' and ct_active' and valid_aci' aci\<rbrace>
  performASIDControlInvocation aci
  \<lbrace>\<lambda>y. tcb_at' p\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: performASIDControlInvocation_def split: asidcontrol_invocation.splits)
  apply (clarsimp simp: valid_aci'_def cte_wp_at_ctes_of cong: conj_cong)
  apply (wp static_imp_wp  |simp add:placeNewObject_def2)+
      apply (wp createObjects_orig_obj_at2' updateFreeIndex_pspace_no_overlap' getSlotCap_wp static_imp_wp)+
   apply (clarsimp simp: projectKO_opts_defs)
   apply (strengthen st_tcb_strg' [where P=\<top>])
   apply (wp deleteObjects_invs_derivatives[where p="makePoolParent aci"]
     hoare_vcg_ex_lift deleteObjects_cte_wp_at'[where d=False]
     deleteObjects_st_tcb_at'[where p="makePoolParent aci"] static_imp_wp
     updateFreeIndex_pspace_no_overlap' deleteObject_no_overlap[where d=False])+
  apply (case_tac ctea)
  apply (clarsimp)
  apply (frule ctes_of_valid_cap')
   apply (simp add:invs_valid_objs')+
  apply (clarsimp simp:valid_cap'_def capAligned_def cte_wp_at_ctes_of)
  apply (strengthen refl order_refl
                    pred_tcb'_weakenE[mk_strg I E])
  apply (clarsimp simp: conj_comms invs_valid_pspace' isCap_simps
                        descendants_range'_def2 empty_descendants_range_in')
  apply (frule ctes_of_valid', clarsimp, simp,
    drule capFreeIndex_update_valid_cap'[where fb="2 ^ pageBits", rotated -1],
    simp_all)
   apply (simp add: pageBits_def is_aligned_def untypedBits_defs)
  apply (simp add: valid_cap_simps' range_cover_def objBits_simps untypedBits_defs
                   capAligned_def unat_eq_0 and_mask_eq_iff_shiftr_0[symmetric]
                   word_bw_assocs)
  apply clarsimp
  apply (drule(1) cte_cap_in_untyped_range,
         fastforce simp add: cte_wp_at_ctes_of, assumption, simp_all)
   apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of)
  apply clarsimp
  done

lemma invokeArch_tcb_at':
  "\<lbrace>invs' and valid_arch_inv' ai and ct_active' and st_tcb_at' active' p\<rbrace>
     Arch.performInvocation ai
   \<lbrace>\<lambda>rv. tcb_at' p\<rbrace>"
  apply (simp add: RISCV64_H.performInvocation_def performRISCVMMUInvocation_def)
  apply (wpsimp simp: performRISCVMMUInvocation_def pred_tcb_at' valid_arch_inv'_def
                  wp: performASIDControlInvocation_tcb_at')
  done

lemma pspace_no_overlap_queuesL1 [simp]:
  "pspace_no_overlap' w sz (ksReadyQueuesL1Bitmap_update f s) = pspace_no_overlap' w sz s"
  by (simp add: pspace_no_overlap'_def)

lemma pspace_no_overlap_queuesL2 [simp]:
  "pspace_no_overlap' w sz (ksReadyQueuesL2Bitmap_update f s) = pspace_no_overlap' w sz s"
  by (simp add: pspace_no_overlap'_def)

crunch pspace_no_overlap'[wp]: setThreadState "pspace_no_overlap' w s"
  (simp: unless_def)

lemma sts_cte_cap_to'[wp]:
  "\<lbrace>ex_cte_cap_to' p\<rbrace> setThreadState st t \<lbrace>\<lambda>rv. ex_cte_cap_to' p\<rbrace>"
  by (wp ex_cte_cap_to'_pres)

lemma sts_valid_arch_inv':
  "\<lbrace>valid_arch_inv' ai\<rbrace> setThreadState st t \<lbrace>\<lambda>rv. valid_arch_inv' ai\<rbrace>"
  apply (cases ai, simp_all add: valid_arch_inv'_def)
     apply (clarsimp simp: valid_pti'_def split: page_table_invocation.splits)
     apply (rule conjI|clarsimp|wpsimp)+
    apply (rename_tac page_invocation)
    apply (case_tac page_invocation, simp_all add: valid_page_inv'_def)[1]
       apply (wp  |simp)+
   apply (clarsimp simp: valid_aci'_def split: asidcontrol_invocation.splits)
   apply (clarsimp simp: cte_wp_at_ctes_of)
   apply (rule hoare_pre, wp)
   apply clarsimp
  apply (clarsimp simp: valid_apinv'_def split: asidpool_invocation.splits)
  apply (rule hoare_pre, wp)
  apply simp
  done

lemma inv_ASIDPool: "inv ASIDPool = (\<lambda>v. case v of ASIDPool a \<Rightarrow> a)"
  apply (rule ext)
  apply (case_tac v)
  apply simp
  apply (rule inv_f_f, rule inj_onI)
  apply simp
  done

lemma eq_arch_update':
  "ArchObjectCap cp = cteCap cte \<Longrightarrow> is_arch_update' (ArchObjectCap cp) cte"
  by (clarsimp simp: is_arch_update'_def isCap_simps)

lemma decode_page_inv_wf[wp]:
  "cap = (arch_capability.FrameCap word vmrights vmpage_size d option) \<Longrightarrow>
      \<lbrace>invs' and valid_cap' (capability.ArchObjectCap cap ) and
        cte_wp_at' ((=) (capability.ArchObjectCap cap) \<circ> cteCap) slot and
        (\<lambda>s. \<forall>x\<in>set excaps. cte_wp_at' ((=) (fst x) \<circ> cteCap) (snd x) s) and
        sch_act_simple\<rbrace>
       decodeRISCVFrameInvocation label args slot cap excaps
       \<lbrace>valid_arch_inv'\<rbrace>, -"
  apply (simp add: decodeRISCVFrameInvocation_def Let_def isCap_simps
             cong: if_cong split del: if_split)
  apply (wpsimp simp: decodeRISCVFrameInvocationMap_def valid_arch_inv'_def valid_page_inv'_def
                      checkSlot_def if_apply_def2
                  wp: getPTE_wp hoare_vcg_all_lift lookupPTSlot_inv
         | wp (once) hoare_drop_imps)+
  apply ((rule conjI; clarsimp)+;
           (clarsimp simp: cte_wp_at_ctes_of,
            (drule_tac t="cteCap _" in sym)+,
            (drule ctes_of_valid', fastforce)+,
            clarsimp simp: valid_cap'_def ptBits_def pageBits_def
                           is_arch_update'_def isCap_simps capAligned_def wellformed_mapdata'_def
                           vmsz_aligned_user_region not_le))
  done

lemma below_pptrUserTop_in_user_region:
  "p < RISCV64_H.pptrUserTop \<Longrightarrow> p \<in> user_region"
  apply (simp add: user_region_def canonical_user_def pptrUserTop_def RISCV64.pptrUserTop_def)
  apply (simp add: bit_simps is_aligned_mask canonical_bit_def)
  by (word_bitwise, clarsimp simp: word_size)

lemma decode_page_table_inv_wf[wp]:
  "arch_cap = PageTableCap word option \<Longrightarrow>
       \<lbrace>invs' and valid_cap' (capability.ArchObjectCap arch_cap) and
        cte_wp_at' ((=) (capability.ArchObjectCap arch_cap) \<circ> cteCap) slot and
        (\<lambda>s. \<forall>x\<in>set excaps. cte_wp_at' ((=) (fst x) \<circ> cteCap) (snd x) s) and
        sch_act_simple\<rbrace>
       decodeRISCVPageTableInvocation label args slot arch_cap excaps
       \<lbrace>valid_arch_inv'\<rbrace>, - "
  supply if_cong[cong] if_split [split del]
  apply (clarsimp simp: decodeRISCVPageTableInvocation_def Let_def isCap_simps)
  apply (wpsimp simp: decodeRISCVPageTableInvocationMap_def valid_arch_inv'_def valid_pti'_def
                      maybeVSpaceForASID_def o_def if_apply_def2
                wp: getPTE_wp hoare_vcg_all_lift hoare_vcg_const_imp_lift
                    lookupPTSlot_inv isFinalCapability_inv
         | wp (once) hoare_drop_imps)+
  apply (clarsimp simp: not_le isCap_simps cte_wp_at_ctes_of eq_arch_update')
  apply (drule_tac t="cteCap cte" in sym)
  apply (simp add: valid_cap'_def capAligned_def)
  apply (clarsimp simp: is_arch_update'_def isCap_simps
                  split: if_split)
  apply (rule conjI; clarsimp)
  apply (drule_tac t="cteCap ctea" in sym)
  apply (drule ctes_of_valid', fastforce)+
  apply (clarsimp simp: valid_cap'_def)
  apply (simp add: wellformed_mapdata'_def below_pptrUserTop_in_user_region neg_mask_user_region)
  done

lemma capMaster_isPageTableCap:
  "capMasterCap cap' = capMasterCap cap \<Longrightarrow>
   isArchCap isPageTableCap cap' = isArchCap isPageTableCap cap"
  by (simp add: capMasterCap_def isArchCap_def isPageTableCap_def
           split: capability.splits arch_capability.splits)

lemma arch_decodeInvocation_wf[wp]:
  shows "\<lbrace>invs' and valid_cap' (ArchObjectCap arch_cap) and
    cte_wp_at' ((=) (ArchObjectCap arch_cap) o cteCap) slot and
    (\<lambda>s. \<forall>x \<in> set excaps. cte_wp_at' ((=) (fst x) o cteCap) (snd x) s) and
    (\<lambda>s. \<forall>x \<in> set excaps. \<forall>r \<in> cte_refs' (fst x) (irq_node' s). ex_cte_cap_to' r s) and
    (\<lambda>s. \<forall>x \<in> set excaps. s \<turnstile>' fst x) and
    sch_act_simple\<rbrace>
   Arch.decodeInvocation label args cap_index slot arch_cap excaps
   \<lbrace>valid_arch_inv'\<rbrace>,-"
  apply (cases arch_cap)
     apply (simp add: decodeRISCVMMUInvocation_def RISCV64_H.decodeInvocation_def
                       Let_def split_def isCap_simps  decodeRISCVASIDControlInvocation_def
                  cong: if_cong invocation_label.case_cong arch_invocation_label.case_cong list.case_cong prod.case_cong
                  split del: if_split)
     apply (rule hoare_pre)
      apply ((wp whenE_throwError_wp ensureEmptySlot_stronger|
              wpc|
              simp add: valid_arch_inv'_def valid_aci'_def is_aligned_shiftl_self
                           split del: if_split)+)[1]
          apply (rule_tac Q'=
                      "\<lambda>rv. K (fst (hd [p\<leftarrow>assocs asidTable . fst p \<le> 2 ^ asid_high_bits - 1 \<and> snd p = None])
                               << asid_low_bits \<le> 2 ^ asid_bits - 1) and
                            real_cte_at' rv and
                            ex_cte_cap_to' rv and
                            cte_wp_at' (\<lambda>cte. \<exists>idx. cteCap cte = (UntypedCap False frame pageBits idx)) (snd (excaps!0)) and
                            sch_act_simple and
                            (\<lambda>s. descendants_of' (snd (excaps!0)) (ctes_of s) = {}) "
                            in hoare_post_imp_R)
           apply (simp add: lookupTargetSlot_def)
           apply wp
          apply (clarsimp simp: cte_wp_at_ctes_of asid_wf_def mask_def)
         apply (simp split del: if_split)
         apply (wp ensureNoChildren_sp whenE_throwError_wp|wpc)+
     apply clarsimp
     apply (rule conjI)
      apply (clarsimp simp: null_def neq_Nil_conv)
      apply (drule filter_eq_ConsD)
      apply clarsimp
      apply (rule shiftl_less_t2n)
       apply (simp add: asid_bits_def asid_low_bits_def asid_high_bits_def)
       apply unat_arith
      apply (simp add: asid_bits_def)
     apply clarsimp
     apply (rule conjI, fastforce)
     apply (clarsimp simp: cte_wp_at_ctes_of objBits_simps)

    \<comment> \<open>ASIDPool cap\<close>
    apply (simp add: decodeRISCVMMUInvocation_def RISCV64_H.decodeInvocation_def
                     Let_def split_def isCap_simps decodeRISCVASIDPoolInvocation_def
               cong: if_cong split del: if_split)
    apply (wpsimp simp: valid_arch_inv'_def valid_apinv'_def wp: getASID_wp cong: if_cong)
    apply (clarsimp simp: word_neq_0_conv valid_cap'_def valid_arch_inv'_def valid_apinv'_def)
    apply (rule conjI)
     apply (erule cte_wp_at_weakenE')
     apply (simp, drule_tac t="cteCap c" in sym, simp add: isCap_simps)
    apply (subst (asm) conj_assoc [symmetric])
    apply (subst (asm) assocs_empty_dom_comp [symmetric])
    apply (drule dom_hd_assocsD)
    apply (simp add: capAligned_def asid_wf_def mask_def)
    apply (elim conjE)
    apply (subst field_simps, erule is_aligned_add_less_t2n)
      apply assumption
     apply (simp add: asid_low_bits_def asid_bits_def)
      apply assumption

   \<comment> \<open>PageCap\<close>
   apply (simp add: decodeRISCVMMUInvocation_def isCap_simps RISCV64_H.decodeInvocation_def
              cong: if_cong split del: if_split)
   apply (wp, simp+)

  \<comment> \<open>PageTableCap\<close>
  apply (simp add: decodeRISCVMMUInvocation_def isCap_simps RISCV64_H.decodeInvocation_def
             cong: if_cong split del: if_split)
  apply (wpsimp, simp+)
  done

crunch nosch[wp]: setMRs "\<lambda>s. P (ksSchedulerAction s)"
    (ignore: getRestartPC setRegister transferCapsToSlots
   wp: hoare_drop_imps hoare_vcg_split_case_option
        mapM_wp'
   simp: split_def zipWithM_x_mapM)

crunch nosch [wp]: performRISCVMMUInvocation "\<lambda>s. P (ksSchedulerAction s)"
  (simp: crunch_simps
   wp: crunch_wps getObject_cte_inv getASID_wp)

lemmas setObject_cte_st_tcb_at' [wp] = setCTE_pred_tcb_at' [unfolded setCTE_def]

crunch st_tcb_at': performPageTableInvocation,
                   performPageInvocation,
                   performASIDPoolInvocation "st_tcb_at' P t"
  (wp: crunch_wps getASID_wp getObject_cte_inv simp: crunch_simps pteAtIndex_def)

lemma performASIDControlInvocation_st_tcb_at':
  "\<lbrace>st_tcb_at' (P and (\<noteq>) Inactive and (\<noteq>) IdleThreadState) t and
    valid_aci' aci and invs' and ct_active'\<rbrace>
    performASIDControlInvocation aci
  \<lbrace>\<lambda>y. st_tcb_at' P t\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: performASIDControlInvocation_def split: asidcontrol_invocation.splits)
  apply (clarsimp simp: valid_aci'_def cte_wp_at_ctes_of cong: conj_cong)
  apply (rule hoare_pre)
   apply (wp createObjects_orig_obj_at'[where P="P \<circ> tcbState", folded st_tcb_at'_def]
             updateFreeIndex_pspace_no_overlap' getSlotCap_wp
             hoare_vcg_ex_lift
             deleteObjects_cte_wp_at' deleteObjects_invs_derivatives
             deleteObjects_st_tcb_at'
             static_imp_wp
        | simp add: placeNewObject_def2)+
  apply (case_tac ctea)
  apply (clarsimp)
  apply (frule ctes_of_valid_cap')
   apply (simp add:invs_valid_objs')+
  apply (clarsimp simp:valid_cap'_def capAligned_def cte_wp_at_ctes_of)
  apply (rule conjI)
    apply clarsimp
    apply (drule (1) cte_cap_in_untyped_range)
        apply (fastforce simp add: cte_wp_at_ctes_of)
       apply assumption+
      subgoal by (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of)
     subgoal by fastforce
    apply simp
   apply (rule conjI,assumption)
  apply (clarsimp simp:invs_valid_pspace' objBits_simps range_cover_full descendants_range'_def2
                       isCap_simps)
  apply (intro conjI)
               apply (fastforce simp:empty_descendants_range_in')+
       apply clarsimp
       apply (drule (1) cte_cap_in_untyped_range)
           apply (fastforce simp add: cte_wp_at_ctes_of)
          apply assumption+
         apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of)
        apply fastforce
       apply simp
  apply auto
  done

lemmas arch_finalise_cap_aligned' = ArchRetypeDecls_H_RISCV64_H_finaliseCap_aligned'

lemmas arch_finalise_cap_distinct' = ArchRetypeDecls_H_RISCV64_H_finaliseCap_distinct'

crunch st_tcb_at' [wp]: "Arch.finaliseCap" "st_tcb_at' P t"
  (wp: crunch_wps getASID_wp simp: crunch_simps)

lemma invs_asid_table_strengthen':
  "invs' s \<and> asid_pool_at' ap s \<and> asid \<le> 2 ^ asid_high_bits - 1 \<longrightarrow>
   invs' (s\<lparr>ksArchState :=
            riscvKSASIDTable_update (\<lambda>_. (riscvKSASIDTable \<circ> ksArchState) s(asid \<mapsto> ap)) (ksArchState s)\<rparr>)"
  apply (clarsimp simp: invs'_def valid_state'_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_global_refs'_def global_refs'_def)
  apply (clarsimp simp: valid_arch_state'_def)
  apply (clarsimp simp: valid_asid_table'_def ran_def mask_def)
  apply (rule conjI)
   apply (clarsimp split: if_split_asm)
   apply (fastforce simp: mask_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_pspace'_def)
  apply (simp add: valid_machine_state'_def)
  done

lemma ex_cte_not_in_untyped_range:
  "\<lbrakk>(ctes_of s) cref = Some (CTE (capability.UntypedCap d ptr bits idx) mnode);
    descendants_of' cref (ctes_of s) = {}; invs' s;
    ex_cte_cap_wp_to' (\<lambda>_. True) x s; valid_global_refs' s\<rbrakk>
   \<Longrightarrow> x \<notin> mask_range ptr bits"
  apply clarsimp
  apply (drule(1) cte_cap_in_untyped_range)
   apply (fastforce simp:cte_wp_at_ctes_of)+
  done

lemma kernel_mappings_canonical_pt_base:
  "x \<in> kernel_mappings \<Longrightarrow> canonical_address (table_base x)"
  apply (simp add: kernel_mappings_def pptr_base_def RISCV64.pptrBase_def canonical_address_range
                   canonical_bit_def bit_simps)
  apply (word_bitwise, clarsimp simp: word_size)
  done

lemma performASIDControlInvocation_invs' [wp]:
  "\<lbrace>invs' and ct_active' and valid_aci' aci\<rbrace>
  performASIDControlInvocation aci \<lbrace>\<lambda>y. invs'\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: performASIDControlInvocation_def valid_aci'_def
    placeNewObject_def2 cte_wp_at_ctes_of
    split: asidcontrol_invocation.splits)
  apply (rename_tac w1 w2 w3 w4 cte ctea idx)
  apply (case_tac ctea)
  apply (clarsimp)
  apply (frule ctes_of_valid_cap')
   apply fastforce
  apply (rule hoare_pre)
   apply (wp hoare_vcg_const_imp_lift)
       apply (strengthen invs_asid_table_strengthen')
       apply (wp cteInsert_simple_invs)
      apply (wp createObjects'_wp_subst[OF
                createObjects_no_cte_invs[where sz = pageBits and ty="Inl (KOArch (KOASIDPool pool))" for pool]]
                createObjects_orig_cte_wp_at'[where sz = pageBits]  hoare_vcg_const_imp_lift
         |simp add: makeObjectKO_def asid_pool_typ_at_ext' valid_cap'_def cong: rev_conj_cong
         |strengthen safe_parent_strg'[where idx= "2^ pageBits"])+
      apply (rule hoare_vcg_conj_lift)
       apply (rule descendants_of'_helper)
       apply (wp createObjects_null_filter'
                  [where sz = pageBits and ty="Inl (KOArch (KOASIDPool ap))" for ap]
                 createObjects_valid_pspace'
                  [where sz = pageBits and ty="Inl (KOArch (KOASIDPool ap))" for ap]
          | simp add: makeObjectKO_def asid_pool_typ_at_ext' valid_cap'_def
                cong: rev_conj_cong)+
       apply (simp add: objBits_simps valid_cap'_def capAligned_def range_cover_full)
      apply (wp  createObjects'_wp_subst[OF createObjects_ex_cte_cap_to[where sz = pageBits]]
                 createObjects_orig_cte_wp_at'[where sz = pageBits]
                 hoare_vcg_const_imp_lift
         |simp add: makeObjectKO_def asid_pool_typ_at_ext' valid_cap'_def
                    isCap_simps
                    canonical_address_neq_mask
               cong: rev_conj_cong
         |strengthen safe_parent_strg'[where idx = "2^ pageBits"]
         | rule in_kernel_mappings_neq_mask
         | simp add: bit_simps kernel_mappings_canonical_pt_base[unfolded bit_simps])+
     apply (simp add:asid_pool_typ_at_ext'[symmetric])
     apply (wp createObject_typ_at')
    apply (simp add: objBits_simps valid_cap'_def
         capAligned_def range_cover_full makeObjectKO_def
         asid_pool_typ_at_ext'
         cong: rev_conj_cong)
    apply (clarsimp simp:conj_comms
                         descendants_of_null_filter'
      | strengthen invs_pspace_aligned' invs_pspace_distinct'
          invs_pspace_aligned' invs_valid_pspace')+
    apply (wp updateFreeIndex_forward_invs'
           updateFreeIndex_cte_wp_at
           updateFreeIndex_pspace_no_overlap'
           updateFreeIndex_caps_no_overlap''
           updateFreeIndex_descendants_of2
           updateFreeIndex_caps_overlap_reserved
           updateCap_cte_wp_at_cases static_imp_wp
           getSlotCap_wp)+
  apply (clarsimp simp:conj_comms ex_disj_distrib is_aligned_mask
           | strengthen invs_valid_pspace' invs_pspace_aligned'
                        invs_pspace_distinct' empty_descendants_range_in')+
  apply (wp deleteObjects_invs'[where p="makePoolParent aci"]
            hoare_vcg_ex_lift
            deleteObjects_caps_no_overlap''[where slot="makePoolParent aci"]
            deleteObject_no_overlap
            deleteObjects_cap_to'[where p="makePoolParent aci"]
            deleteObjects_ct_active'[where cref="makePoolParent aci"]
            deleteObjects_descendants[where p="makePoolParent aci"]
            deleteObjects_cte_wp_at'
            deleteObjects_null_filter[where p="makePoolParent aci"])
  apply (frule valid_capAligned)
  apply (clarsimp simp: invs_mdb' invs_valid_pspace' capAligned_def
                        cte_wp_at_ctes_of is_simple_cap'_def isCap_simps)
  apply (strengthen refl ctes_of_valid_cap'[mk_strg I E])
  apply (clarsimp simp: conj_comms invs_valid_objs')
  apply (frule_tac ptr="w1" in descendants_range_caps_no_overlapI'[where sz = pageBits])
    apply (fastforce simp: cte_wp_at_ctes_of)
   apply (simp add:empty_descendants_range_in')
  apply (frule(1) if_unsafe_then_capD'[OF _ invs_unsafe_then_cap',rotated])
   apply (fastforce simp:cte_wp_at_ctes_of)
  apply (drule ex_cte_not_in_untyped_range[rotated -2])
      apply (simp add:invs_valid_global')+
  apply (drule ex_cte_not_in_untyped_range[rotated -2])
      apply (simp add:invs_valid_global')+
  apply (subgoal_tac "is_aligned (2 ^ pageBits) minUntypedSizeBits")
   prefer 2
   apply (rule is_aligned_weaken)
    apply (rule is_aligned_shiftl_self[unfolded shiftl_t2n,where p = 1, simplified])
   apply (simp add: pageBits_def untypedBits_defs)
  apply (frule_tac cte="CTE (capability.UntypedCap False a b c) m" for a b c m in valid_global_refsD', clarsimp)
  apply (simp add: Int_commute)
  by (auto simp:empty_descendants_range_in' objBits_simps max_free_index_def
                    asid_low_bits_def word_bits_def
                    range_cover_full descendants_range'_def2 is_aligned_mask
                    null_filter_descendants_of'[OF null_filter_simp'] bit_simps
                    valid_cap_simps' mask_def kernel_mappings_canonical)

lemma arch_performInvocation_invs':
  "\<lbrace>invs' and ct_active' and valid_arch_inv' invocation\<rbrace>
  Arch.performInvocation invocation
  \<lbrace>\<lambda>rv. invs'\<rbrace>"
  unfolding RISCV64_H.performInvocation_def
  by (cases invocation, simp_all add: performRISCVMMUInvocation_def valid_arch_inv'_def; wpsimp)

end

end


(*  Title:      HOL/Auth/n_g2kAbsAfter_lemma_inv__82_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__82_on_rules imports n_g2kAbsAfter_lemma_on_inv__82
begin
section{*All lemmas on causal relation between inv__82*}
lemma lemma_inv__82_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__82  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_AStore_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__82) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__82) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory "HoareTripleForStorage"

imports "HoareTripleForInstructions"
begin

lemma storage_inst_advance [simp] :
"program_content (cctx_program co_ctx) (vctx_pc x1) = Some (Storage m) \<Longrightarrow>
 k = vctx_pc x1 \<Longrightarrow>
 vctx_pc (vctx_advance_pc co_ctx x1) = vctx_pc x1 + 1"
by (simp add: vctx_next_instruction_def
 vctx_advance_pc_def inst_size_def inst_code.simps)

lemma update_storage_preserves_pc [simp] :
"vctx_pc (vctx_update_storage idx new x1) = vctx_pc x1"
by (simp add: vctx_update_storage_def)

lemma update_storage_updates [simp] :
"vctx_storage (vctx_update_storage idx new x1) idx = new"
by (simp add: vctx_update_storage_def)

lemma update_storage_preserves_gas [simp] :
  "vctx_gas (vctx_update_storage idx new x1) = vctx_gas x1"
by (simp add: vctx_update_storage_def)

lemma some_list_gotcha :
  "       rev ta ! fst x2 = snd x2 \<longrightarrow> \<not> fst x2 < length ta \<Longrightarrow>
       x2 \<noteq> (Suc (length ta), idx) \<Longrightarrow>
       x2 \<noteq> (length ta, new) \<Longrightarrow>
       (fst x2 < length ta \<and> rev ta ! fst x2 = snd x2 \<or>
        length ta \<le> fst x2 \<and> [new, idx] ! (fst x2 - length ta) = snd x2) \<and>
       fst x2 < Suc (Suc (length ta)) \<Longrightarrow>
       elm = StackElm x2 \<Longrightarrow> False"
apply(case_tac x2; auto)
 apply(case_tac "a - length ta"; simp)
 apply(rename_tac smaller)
 apply(case_tac smaller; simp)
apply(case_tac "a - length ta"; simp)
apply(rename_tac smaller)
apply(case_tac smaller; simp)
  done

lemma next_state_noop[simp]:
  "next_state stopper c net (InstructionToEnvironment x y z) = (InstructionToEnvironment x y z)"
  by (simp add: next_state_def)+

lemmas hoare_simps = stateelm_means_simps stateelm_equiv_simps
       next_state_def rev_nth_simps instruction_sem_simps gas_value_simps
      inst_numbers_simps instruction_failure_result_def
      advance_pc_simps

method hoare_sep uses sep simp dest split =
 ((sep_simp simp: sep)+,
  clarsimp simp: simp dest:dest split:split)

lemma sstore_gas_triple :
  "triple net {OutOfGas}
          (\<langle> h \<le> 1024\<rangle>
           ** stack_height (h + 2)
           ** stack (h + 1) idx
           ** stack h new
           ** program_counter k ** storage idx old
           ** gas_pred g ** continuing)
          {(k, Storage SSTORE)}
          (stack_height h
           ** program_counter (k + 1) ** storage idx new **
           gas_pred (g - Csstore old new) ** continuing)"
  apply (clarsimp simp: triple_def)
  apply(rule_tac x = 1 in exI)
  apply (clarsimp simp add: program_sem.simps next_state_def failed_for_reasons_def)
  apply(case_tac presult ; (solves \<open>(hoare_sep sep: evm_sep simp:   stateelm_means_simps dest: stateelm_dest)\<close>) ?)
  apply (hoare_sep sep: evm_sep
                   simp: instruction_result_as_set_def  sstore_def
                         vctx_update_storage_def hoare_simps
                  split:if_splits)
  apply (erule_tac P=rest in back_subst)
  apply(rule Set.equalityI; clarify)
  apply(rename_tac elm)
  apply(simp add: vctx_update_storage_def)
  apply (case_tac elm; simp add: hoare_simps split:if_splits)
  using some_list_gotcha gasprice_advance_pc apply blast
  apply(rename_tac elm)
  apply (simp add: set_diff_eq)
  apply (case_tac elm; simp add: hoare_simps  split:if_splits)
  apply auto
done

lemma sload_gas_triple :
  "triple net {OutOfGas}
          (\<langle> h \<le> 1023 \<and> unat bn \<ge> 2463000 \<and> at_least_eip150 net\<rangle>
           ** block_number_pred bn ** stack_height (h + 1)
           ** stack h idx
           ** program_counter k ** storage idx w ** gas_pred g **  account_existence c existence ** continuing)
          {(k, Storage SLOAD)}
          (block_number_pred bn ** stack_height (h + 1) ** stack h w
           ** program_counter (k + 1) ** storage idx w ** gas_pred (g - Gsload net) **  account_existence c existence ** continuing )"
apply(clarsimp simp add: triple_def)
  apply(rule_tac x = 1 in exI)
  apply(clarsimp simp add: program_sem.simps next_state_def failed_for_reasons_def)
  apply(case_tac presult;  (solves \<open>(hoare_sep sep: evm_sep simp:  set_diff_eq stateelm_means_simps dest: stateelm_dest)\<close>)?)
  apply clarsimp
  apply(hoare_sep sep: evm_sep
                   simp: instruction_result_as_set_def  sstore_def
                         vctx_update_storage_def hoare_simps set_diff_eq
                  split:if_split_asm)
  apply(erule_tac P=rest in back_subst)
  apply(rule  Set.equalityI; clarify)
  apply(simp)
  apply(rename_tac elm)
  apply(case_tac elm; simp add: hoare_simps split:if_splits)
  apply(rename_tac pair)
  apply(case_tac pair; fastforce)
  apply(simp)
  apply(rename_tac elm)
  apply(case_tac elm; simp add: hoare_simps split:if_splits)
  apply(rename_tac pair)
  apply(case_tac pair; fastforce)
done

end


(*  Title:      JinjaThreads/MM/JMM_Heap.thy
    Author:     Andreas Lochbihler
*)

section \<open>Locales for heap operations with set of allocated addresses\<close>

theory JMM_Heap
imports
  "../Common/WellForm"
  SC_Completion
  HB_Completion
begin

definition w_addrs :: "('addr \<times> addr_loc \<Rightarrow> 'addr val set) \<Rightarrow> 'addr set"
where "w_addrs vs = {a. \<exists>adal. Addr a \<in> vs adal}"

lemma w_addrs_empty [simp]: "w_addrs (\<lambda>_. {}) = {}"
by(simp add: w_addrs_def)

locale allocated_heap_base = heap_base +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  fixes allocated :: "'heap \<Rightarrow> 'addr set"

locale allocated_heap =
  allocated_heap_base +
  heap +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  and allocated :: "'heap \<Rightarrow> 'addr set"
  and P :: "'m prog"

  assumes allocated_empty: "allocated empty_heap = {}"
  and allocate_allocatedD:
  "(h', a) \<in> allocate h hT \<Longrightarrow> allocated h' = insert a (allocated h) \<and> a \<notin> allocated h"
  and heap_write_allocated_same:
  "heap_write h a al v h' \<Longrightarrow> allocated h' = allocated h"
begin

lemma allocate_allocated_mono: "(h', a) \<in> allocate h C \<Longrightarrow> allocated h \<subseteq> allocated h'"
by(simp_all add: allocate_allocatedD)

lemma
  shows start_addrs_allocated: "allocated start_heap = set start_addrs"
  and distinct_start_addrs': "distinct start_addrs"
proof -
  { fix h ads b and xs :: "cname list"
    let "?start_addrs h ads b xs" = "fst (snd (foldl create_initial_object (h, ads, b) xs))"
    let "?start_heap h ads b xs" = "fst (foldl create_initial_object (h, ads, b) xs)"
    assume "allocated h = set ads"
    hence "allocated (?start_heap h ads b xs) = set (?start_addrs h ads b xs) \<and>
           (distinct ads \<longrightarrow> distinct (?start_addrs h ads b xs))"
      (is "?concl xs h ads b")
    proof(induct xs arbitrary: h ads b)
      case Nil thus ?case by auto
    next
      case (Cons x xs)
      note ads = \<open>allocated h = set ads\<close>
      show ?case
      proof(cases "b \<and> allocate h (Class_type x) \<noteq> {}")
        case False thus ?thesis using ads
          by(simp add: create_initial_object_simps zip_append1)
      next
        case [simp]: True
        then obtain h' a'
          where h'a': "(SOME ha. ha \<in> allocate h (Class_type x)) = (h', a')"
          and new_obj: "(h', a') \<in> allocate h (Class_type x)"
          by(cases "(SOME ha. ha \<in> allocate h (Class_type x))")(auto simp del: True dest: allocate_Eps)

        from new_obj have "allocated h' = insert a' (allocated h)" "a' \<notin> allocated h"
          by(auto dest: allocate_allocatedD)
        with ads have "allocated h' = set (ads @ [a'])" by auto
        hence "?concl xs h' (ads @ [a']) True" by(rule Cons)
        moreover have "a' \<notin> set ads" using \<open>a' \<notin> allocated h\<close> ads by blast
        ultimately show ?thesis by(simp add: create_initial_object_simps new_obj h'a')
      qed
    qed }
  from this[of empty_heap "[]" True initialization_list]
  show "allocated start_heap = set start_addrs"
    and distinct_start_addrs: "distinct start_addrs"
    unfolding start_heap_def start_addrs_def start_heap_data_def
    by(auto simp add: allocated_empty)
qed

lemma w_addrs_start_heap_obs: "w_addrs (w_values P vs (map NormalAction start_heap_obs)) \<subseteq> w_addrs vs"
proof -
  { fix xs
    let ?NewObj = "\<lambda>a C. NewHeapElem a (Class_type C) :: ('addr, 'thread_id) obs_event"
    let "?start_heap_obs xs" = "map (\<lambda>(C, a). ?NewObj a C) xs"
    have "w_addrs (w_values P vs (map NormalAction (?start_heap_obs xs))) \<subseteq> w_addrs vs"
      (is "?concl xs")
    proof(induct xs arbitrary: vs)
      case Nil thus ?case by simp
    next
      case (Cons x xs)
      have "w_addrs (w_values P vs (map NormalAction (map (\<lambda>(C, a). ?NewObj a C) (x # xs))))
        = w_addrs (w_values P (w_value P vs (NormalAction (?NewObj (snd x) (fst x)))) (map NormalAction (map (\<lambda>(C, a). ?NewObj a C) xs)))"
        by(simp add: split_beta)
      also have "\<dots> \<subseteq> w_addrs (w_value P vs (NormalAction (?NewObj (snd x) (fst x))))" by(rule Cons)
      also have "\<dots> \<subseteq> w_addrs vs"
        by(auto simp add: w_addrs_def default_val_not_Addr Addr_not_default_val)
      finally show ?case .
    qed }
  thus ?thesis by(simp add: start_heap_obs_def)
qed

end

context heap_base begin

lemma addr_loc_default_conf:
  "P \<turnstile> class_type_of CTn has F:T (fm) in C
  \<Longrightarrow> P,h \<turnstile> addr_loc_default P CTn (CField C F) :\<le> T"
apply(cases CTn)
 apply simp
apply(frule has_field_decl_above)
apply simp
done

definition vs_conf :: "'m prog \<Rightarrow> 'heap \<Rightarrow> ('addr \<times> addr_loc \<Rightarrow> 'addr val set) \<Rightarrow> bool"
where "vs_conf P h vs \<longleftrightarrow> (\<forall>ad al v. v \<in> vs (ad, al) \<longrightarrow> (\<exists>T. P,h \<turnstile> ad@al : T \<and> P,h \<turnstile> v :\<le> T))"

lemma vs_confD:
  "\<lbrakk> vs_conf P h vs; v \<in> vs (ad, al) \<rbrakk> \<Longrightarrow> \<exists>T. P,h \<turnstile> ad@al : T \<and> P,h \<turnstile> v :\<le> T"
unfolding vs_conf_def by blast

lemma vs_conf_insert_iff:
  "vs_conf P h (vs((ad, al) := insert v (vs (ad, al))))
  \<longleftrightarrow> vs_conf P h vs \<and> (\<exists>T. P,h \<turnstile> ad@al : T \<and> P,h \<turnstile> v :\<le> T)"
by(auto 4 3 elim: vs_confD intro: vs_confI split: if_split_asm)

end

context heap begin

lemma vs_conf_hext: "\<lbrakk> vs_conf P h vs; h \<unlhd> h' \<rbrakk> \<Longrightarrow> vs_conf P h' vs"
by(blast intro!: vs_confI intro: conf_hext addr_loc_type_hext_mono dest: vs_confD)

lemma vs_conf_allocate:
  "\<lbrakk> vs_conf P h vs; (h', a) \<in> allocate h hT; is_htype P hT \<rbrakk>
  \<Longrightarrow> vs_conf P h' (w_value P vs (NormalAction (NewHeapElem a hT)))"
apply(drule vs_conf_hext)
 apply(erule hext_allocate)
apply(auto intro!: vs_confI simp add: addr_locs_def split: if_split_asm htype.split_asm)
apply(auto 3 3 intro: addr_loc_type.intros defval_conf dest: allocate_SomeD elim: has_field_is_class vs_confD)
apply(rule exI conjI addr_loc_type.intros|drule allocate_SomeD|erule has_field_is_class|simp)+
done

end

text \<open>
  \<open>heap_read_typeable\<close> must not be defined in @{term heap_conf_base} (where it should be) because
  this would lead to duplicate definitions of \<open>heap_read_typeable\<close> in contexts where @{term heap_conf_base}
  is imported twice with different parameters, e.g., @{term P} and @{term "J2JVM P"} in @{term "J_JVM_heap_conf_read"}.
\<close>

context heap_base begin

definition heap_read_typeable :: "('heap \<Rightarrow> bool) \<Rightarrow> 'm prog \<Rightarrow> bool"
where "heap_read_typeable hconf P \<longleftrightarrow> (\<forall>h ad al v T. hconf h \<longrightarrow> P,h \<turnstile> ad@al : T \<longrightarrow> P,h \<turnstile> v :\<le> T \<longrightarrow> heap_read h ad al v)"

lemma heap_read_typeableI:
  "(\<And>h ad al v T. \<lbrakk> P,h \<turnstile> ad@al : T; P,h \<turnstile> v :\<le> T; hconf h \<rbrakk> \<Longrightarrow> heap_read h ad al v) \<Longrightarrow> heap_read_typeable hconf P"
unfolding heap_read_typeable_def by blast

lemma heap_read_typeableD:
  "\<lbrakk> heap_read_typeable hconf P; P,h \<turnstile> ad@al : T; P,h \<turnstile> v :\<le> T; hconf h \<rbrakk> \<Longrightarrow> heap_read h ad al v"
unfolding heap_read_typeable_def by blast

end

context heap_base begin

definition heap_read_typed :: "'m prog \<Rightarrow> 'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
where "heap_read_typed P h ad al v \<longleftrightarrow> heap_read h ad al v \<and> (\<forall>T. P,h \<turnstile> ad@al : T \<longrightarrow> P,h \<turnstile> v :\<le> T)"

lemma heap_read_typedI:
  "\<lbrakk> heap_read h ad al v; \<And>T. P,h \<turnstile> ad@al : T \<Longrightarrow> P,h \<turnstile> v :\<le> T \<rbrakk> \<Longrightarrow> heap_read_typed P h ad al v"
unfolding heap_read_typed_def by blast

lemma heap_read_typed_into_heap_read:
  "heap_read_typed P h ad al v \<Longrightarrow> heap_read h ad al v"
unfolding heap_read_typed_def by blast

lemma heap_read_typed_typed:
  "\<lbrakk> heap_read_typed P h ad al v; P,h \<turnstile> ad@al : T \<rbrakk> \<Longrightarrow> P,h \<turnstile> v :\<le> T"
unfolding heap_read_typed_def by blast

end

context heap_conf begin

lemma heap_conf_read_heap_read_typed:
  "heap_conf_read addr2thread_id thread_id2addr empty_heap allocate typeof_addr (heap_read_typed P) heap_write hconf P"
proof
  fix h a al v T
  assume "heap_read_typed P h a al v" "P,h \<turnstile> a@al : T"
  thus "P,h \<turnstile> v :\<le> T" by(rule heap_read_typed_typed)
qed

end

context heap begin

lemma start_addrs_dom_w_values:
  assumes wf: "wf_syscls P"
  and a: "a \<in> set start_addrs"
  and adal: "P,start_heap \<turnstile> a@al : T"
  shows "w_values P (\<lambda>_. {}) (map NormalAction start_heap_obs) (a, al) \<noteq> {}"
proof -
  from a obtain CTn where CTn: "NewHeapElem a CTn \<in> set start_heap_obs"
    unfolding in_set_start_addrs_conv_NewHeapElem ..
  then obtain obs obs' where obs: "start_heap_obs = obs @ NewHeapElem a CTn # obs'" by(auto dest: split_list)
  have "w_value P (w_values P (\<lambda>_. {}) (map NormalAction obs)) (NormalAction (NewHeapElem a CTn)) (a, al) \<noteq> {}"
  proof(cases CTn)
    case [simp]: (Class_type C)
    with wf CTn have "typeof_addr start_heap a = \<lfloor>Class_type C\<rfloor>"
      by(auto intro: NewHeapElem_start_heap_obsD)
    with adal show ?thesis by cases auto
  next
    case [simp]: (Array_type T n)
    with wf CTn have "typeof_addr start_heap a = \<lfloor>Array_type T n\<rfloor>"
      by(auto dest: NewHeapElem_start_heap_obsD)
    with adal show ?thesis by cases(auto dest: has_field_decl_above)
  qed
  moreover have "w_value P (w_values P (\<lambda>_. {}) (map NormalAction obs)) (NormalAction (NewHeapElem a CTn :: ('addr, 'thread_id) obs_event))
    (a, al) \<subseteq> w_values P (\<lambda>_. {}) (map NormalAction start_heap_obs) (a, al)"
    by(simp add: obs del: w_value.simps)(rule w_values_mono)
  ultimately show ?thesis by blast
qed

end

end


(*  Title:      HOL/Auth/n_g2kAbsAfter_lemma_inv__76_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__76_on_rules imports n_g2kAbsAfter_lemma_on_inv__76
begin
section{*All lemmas on causal relation between inv__76*}
lemma lemma_inv__76_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__76  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_AStore_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__76) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__76) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end