(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

theory ArchVSpaceEntries_AI
imports "../VSpaceEntries_AI"
begin

context Arch begin global_naming ARM (*FIXME: arch_split*)

lemma a_type_pdD:
  "a_type ko = AArch APageDirectory \<Longrightarrow> \<exists>pd. ko = ArchObj (PageDirectory pd)"
  by (clarsimp)

primrec
  pde_range_sz :: "pde \<Rightarrow> nat"
where
    "pde_range_sz (InvalidPDE) = 0"
  | "pde_range_sz (SectionPDE ptr x y z) = 0"
  | "pde_range_sz (SuperSectionPDE ptr x z) = 4"
  | "pde_range_sz (PageTablePDE ptr x z) = 0"

primrec
  pte_range_sz :: "pte \<Rightarrow> nat"
where
    "pte_range_sz (InvalidPTE) = 0"
  | "pte_range_sz (LargePagePTE ptr x y) = 4"
  | "pte_range_sz (SmallPagePTE ptr x y) = 0"

primrec
  pde_range :: "pde \<Rightarrow> 12 word \<Rightarrow> 12 word set"
where
    "pde_range (InvalidPDE) p = {}"
  | "pde_range (SectionPDE ptr x y z) p = {p}"
  | "pde_range (SuperSectionPDE ptr x z) p =
     (if is_aligned p 4 then {x. x && ~~ mask 4 = p && ~~ mask 4} else {p})"
  | "pde_range (PageTablePDE ptr x z) p = {p}"

primrec
  pte_range :: "pte \<Rightarrow> word8 \<Rightarrow> word8 set"
where
    "pte_range (InvalidPTE) p = {}"
  | "pte_range (LargePagePTE ptr x y) p =
       (if is_aligned p 4 then {x. x && ~~ mask 4 = p && ~~ mask 4} else {p})"
  | "pte_range (SmallPagePTE ptr x y) p = {p}"

abbreviation "valid_pt_entries \<equiv> \<lambda>pt. valid_entries pte_range pt"

abbreviation "valid_pd_entries \<equiv> \<lambda>pd. valid_entries pde_range pd"

definition
  obj_valid_pdpt :: "kernel_object \<Rightarrow> bool"
where
 "obj_valid_pdpt obj \<equiv> case obj of
    ArchObj (PageTable pt) \<Rightarrow> valid_pt_entries pt \<and> entries_align pte_range_sz pt
  | ArchObj (PageDirectory pd) \<Rightarrow> valid_pd_entries pd \<and> entries_align pde_range_sz pd
  | _ \<Rightarrow> True"

lemmas obj_valid_pdpt_simps[simp]
    = obj_valid_pdpt_def
        [split_simps Structures_A.kernel_object.split
                     arch_kernel_obj.split]

abbreviation
  valid_pdpt_objs :: "'z state \<Rightarrow> bool"
where
 "valid_pdpt_objs s \<equiv> \<forall>x \<in> ran (kheap s). obj_valid_pdpt x"

lemma valid_pdpt_init[iff]:
  "valid_pdpt_objs init_A_st"
proof -
  have P: "valid_pd_entries (global_pd :: 12 word \<Rightarrow> _)"
    by (clarsimp simp: valid_entries_def)
  also have Q: "entries_align pde_range_sz (global_pd :: 12 word \<Rightarrow> _)"
    by (clarsimp simp: entries_align_def)
  thus ?thesis using P
    by (auto simp: init_A_st_def init_kheap_def
            elim!: ranE split: if_split_asm)
qed

lemma set_object_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs and K (obj_valid_pdpt obj)\<rbrace>
      set_object ptr obj
   \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: set_object_def, wp)
  apply (auto simp: fun_upd_def[symmetric] del: ballI elim: ball_ran_updI)
  done

crunch valid_pdpt_objs[wp]: cap_insert, cap_swap_for_delete,empty_slot "valid_pdpt_objs"
  (wp: crunch_wps simp: crunch_simps ignore:set_object)

crunch valid_pdpt_objs[wp]: flush_page "valid_pdpt_objs"
  (wp: crunch_wps simp: crunch_simps)

lemma shift_0x3C_set:
  "\<lbrakk> is_aligned p 6; 8 \<le> bits; bits < 32; len_of TYPE('a) = bits - 2 \<rbrakk> \<Longrightarrow>
   (\<lambda>x. ucast (x + p && mask bits >> 2) :: ('a :: len) word) ` set [0 :: word32 , 4 .e. 0x3C]
        = {x. x && ~~ mask 4 = ucast (p && mask bits >> 2)}"
  apply (clarsimp simp: upto_enum_step_def word_shift_by_2 image_image)
  apply (subst image_cong[where N="{x. x < 2 ^ 4}"])
    apply (safe, simp_all)[1]
     apply (drule plus_one_helper2, simp_all)[1]
    apply (drule minus_one_helper3, simp_all)[1]
   apply (rule_tac f="\<lambda>x. ucast (x && mask bits >> 2)" in arg_cong)
   apply (rule trans[OF add.commute is_aligned_add_or], assumption)
   apply (rule shiftl_less_t2n, simp_all)[1]
  apply safe
   apply (frule upper_bits_unset_is_l2p_32[THEN iffD2, rotated])
    apply (simp add: word_bits_conv)
   apply (rule word_eqI)
   apply (simp add: word_ops_nth_size word_size nth_ucast nth_shiftr
                    nth_shiftl neg_mask_bang
                    word_bits_conv)
   apply (safe, simp_all add: is_aligned_nth)[1]
   apply (drule_tac x="Suc (Suc n)" in spec)
   apply simp
  apply (rule_tac x="ucast x && mask 4" in image_eqI)
   apply (rule word_eqI)
   apply (drule_tac x=n in word_eqD)
   apply (simp add: word_ops_nth_size word_size nth_ucast nth_shiftr
                    nth_shiftl)
   apply (safe, simp_all)
  apply (rule order_less_le_trans, rule and_mask_less_size)
   apply (simp_all add: word_size)
  done

lemma mapM_x_store_pte_updates:
  "\<forall>x \<in> set xs. f x && ~~ mask pt_bits = p \<Longrightarrow>
   \<lbrace>\<lambda>s. (\<not> page_table_at p s \<longrightarrow> Q s) \<and>
        (\<forall>pt. ko_at (ArchObj (PageTable pt)) p s
           \<longrightarrow> Q (s \<lparr> kheap := (kheap s) (p := Some (ArchObj (PageTable (\<lambda>y. if y \<in> (\<lambda>x.
         ucast (f x && mask pt_bits >> 2)) ` set xs then pte else pt y)))) \<rparr>))\<rbrace>
     mapM_x (\<lambda>x. store_pte (f x) pte) xs
   \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_x_Nil)
   apply wp
   apply (clarsimp simp: obj_at_def)
   apply (simp add: a_type_def fun_upd_idem
             split: Structures_A.kernel_object.split_asm if_split_asm
                    arch_kernel_obj.split_asm)
  apply (simp add: mapM_x_Cons)
  apply (rule hoare_seq_ext, assumption)
  apply (thin_tac "valid P f Q" for P f Q)
  apply (simp add: store_pte_def set_pt_def set_object_def)
  apply (wp get_pt_wp get_object_wp)
  apply (clarsimp simp: obj_at_def a_type_simps)
  apply (erule rsubst[where P=Q])
  apply (rule abstract_state.fold_congs[OF refl refl])
  apply (rule ext, clarsimp)
  apply (rule ext, clarsimp)
  done

lemma valid_pt_entries_invalid[simp]:
  "valid_pt_entries (\<lambda>x. InvalidPTE)"
   by (simp add:valid_entries_def)

lemma valid_pd_entries_invalid[simp]:
  "valid_pd_entries (\<lambda>x. InvalidPDE)"
  by (simp add:valid_entries_def)

lemma entries_align_pte_update:
 "\<lbrakk>entries_align pte_range_sz pt;
  (\<forall>y. (P y) \<longrightarrow> is_aligned y (pte_range_sz pte))\<rbrakk>
  \<Longrightarrow> entries_align pte_range_sz (\<lambda>y. if (P y) then pte else pt y)"
  by (simp add:entries_align_def)

lemma entries_align_pde_update:
 "\<lbrakk>entries_align pde_range_sz pd;
  (\<forall>y. (P y) \<longrightarrow> is_aligned y (pde_range_sz pde))\<rbrakk>
  \<Longrightarrow> entries_align pde_range_sz (\<lambda>y. if (P y) then pde else pd y)"
  by (simp add:entries_align_def)

lemma valid_pdpt_objs_pdD:
  "\<lbrakk>valid_pdpt_objs s;
    kheap s ptr = Some (ArchObj (arch_kernel_obj.PageDirectory pd))\<rbrakk>
   \<Longrightarrow> valid_pd_entries pd \<and> entries_align pde_range_sz pd"
  by (fastforce simp:ran_def)

lemma valid_pdpt_objs_ptD:
  "\<lbrakk>valid_pdpt_objs s;
    kheap s ptr = Some (ArchObj (arch_kernel_obj.PageTable pt))\<rbrakk>
   \<Longrightarrow> valid_pt_entries pt \<and> entries_align pte_range_sz pt"
  by (fastforce simp:ran_def)

lemma mapM_x_store_invalid_pte_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and K (is_aligned p 6) \<rbrace>
     mapM_x (\<lambda>x. store_pte (x + p) InvalidPTE) [0, 4 .e. 0x3C]
   \<lbrace>\<lambda>_. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_gen_asm)+
  apply (rule hoare_pre, rule_tac p="p && ~~ mask pt_bits" in mapM_x_store_pte_updates)
   apply clarsimp
   apply (rule mask_out_first_mask_some[where n=6])
    apply (drule_tac d=x in is_aligned_add_helper)
     apply (drule subsetD[OF upto_enum_step_subset])
     apply simp
     apply (erule order_le_less_trans, simp)
    apply (simp add: field_simps)
   apply (simp add: pt_bits_def pageBits_def)
  apply (clarsimp simp: ranI elim!: ranE split: if_split_asm)
  apply (intro conjI)
   apply (simp add: shift_0x3C_set pt_bits_def pageBits_def)
   apply (rule valid_entries_overwrite_groups
    [where S = "{x. x && ~~ mask 4 = ucast (p && mask 10 >> 2)}"])
      apply (fastforce simp add: obj_at_def ran_def)
     apply simp
    apply clarsimp
    apply (case_tac v)
      apply (simp split:if_splits)+
   apply (clarsimp)
   apply (case_tac v, simp_all split:if_splits)
    apply (intro conjI impI)
     apply (rule disjointI)
     apply (clarsimp)+
  apply (rule entries_align_pte_update)
   apply (clarsimp simp:obj_at_def)
   apply (drule(1) valid_pdpt_objs_ptD)
   apply simp
  apply (simp)
  done

lemma mapM_x_store_pde_updates:
  "\<forall>x \<in> set xs. f x && ~~ mask pd_bits = p \<Longrightarrow>
   \<lbrace>\<lambda>s. (\<not> page_directory_at p s \<longrightarrow> Q s) \<and>
        (\<forall>pd. ko_at (ArchObj (PageDirectory pd)) p s
           \<longrightarrow> Q (s \<lparr> kheap := (kheap s) (p := Some (ArchObj (PageDirectory (\<lambda>y. if y \<in> (\<lambda>x.
         ucast (f x && mask pd_bits >> 2)) ` set xs then pde else pd y)))) \<rparr>))\<rbrace>
     mapM_x (\<lambda>x. store_pde (f x) pde) xs
   \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_x_Nil)
   apply wp
   apply (clarsimp simp: obj_at_def)
   apply (simp add: a_type_def fun_upd_idem
             split: Structures_A.kernel_object.split_asm if_split_asm
                    arch_kernel_obj.split_asm)
  apply (simp add: mapM_x_Cons)
  apply (rule hoare_seq_ext, assumption)
  apply (thin_tac "valid P f Q" for P f Q)
  apply (simp add: store_pde_def set_pd_def set_object_def)
  apply (wp get_pd_wp get_object_wp)
  apply (clarsimp simp: obj_at_def a_type_simps)
  apply (erule rsubst[where P=Q])
  apply (rule abstract_state.fold_congs[OF refl refl])
  apply (rule ext, clarsimp)
  apply (rule ext, clarsimp)
  done

lemma mapM_x_store_pde_valid_pdpt_objs:
  "\<lbrace>valid_pdpt_objs and K (is_aligned p 6)\<rbrace>
     mapM_x (\<lambda>x. store_pde (x + p) InvalidPDE) [0, 4 .e. 0x3C]
   \<lbrace>\<lambda>_. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_gen_asm)+
  apply (rule hoare_pre, rule_tac p="p && ~~ mask pd_bits" in mapM_x_store_pde_updates)
   apply clarsimp
   apply (rule mask_out_first_mask_some[where n=6])
    apply (drule_tac d=x in is_aligned_add_helper)
     apply (drule subsetD[OF upto_enum_step_subset])
     apply simp
     apply (erule order_le_less_trans, simp)
    apply (simp add: field_simps)
   apply (simp add: pd_bits_def pageBits_def)
  apply (clarsimp simp: ranI elim!: ranE split: if_split_asm)
  apply (simp add: shift_0x3C_set pd_bits_def pageBits_def)
  apply (rule conjI)
   apply (rule_tac valid_entries_overwrite_groups
    [where S = "{x. x && ~~ mask 4 = ucast (p && mask 14 >> 2)}"])
      apply (fastforce simp add: obj_at_def ran_def)
     apply fastforce
    apply clarsimp
    apply (case_tac v, simp_all split:if_splits)
    apply clarsimp
    apply (case_tac v, simp_all split:if_splits)
   apply (intro conjI impI allI)
   apply (rule disjointI)
   apply clarsimp
  apply (rule entries_align_pde_update)
   apply (clarsimp simp:obj_at_def)
   apply (drule valid_pdpt_objs_pdD)
    apply (simp add:pd_bits_def pageBits_def)
   apply simp
  apply simp
  done

lemma store_invalid_pde_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and
    (\<lambda>s. \<forall>pd. ko_at (ArchObj (PageDirectory pd)) (p && ~~ mask pd_bits) s
      \<longrightarrow> pde = InvalidPDE)\<rbrace>
       store_pde p pde \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: store_pde_def set_pd_def, wp get_object_wp)
  apply (clarsimp simp: obj_at_def)
   apply (intro conjI)
   apply (rule valid_entries_overwrite_0, simp_all)
   apply (fastforce simp: ran_def)
  apply (simp add:fun_upd_def)
  apply (rule entries_align_pde_update)
   apply (drule(1) valid_pdpt_objs_pdD)
   apply simp
  apply simp
  done

lemma store_pde_non_master_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and
        (\<lambda>s. \<forall>pd. ko_at (ArchObj (PageDirectory pd)) (p && ~~ mask pd_bits) s
        \<longrightarrow> (pde_range_sz (pd (ucast (p && mask pd_bits >> 2) && ~~ mask 4)) = 0
        \<and> pde_range_sz pde = 0))\<rbrace>
       store_pde p pde \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: store_pde_def set_pd_def, wp get_object_wp)
  apply (clarsimp simp: obj_at_def)
  apply (intro conjI)
   apply (rule valid_entries_overwrite_0)
    apply (fastforce simp:ran_def)
   apply (drule bspec)
    apply fastforce
   apply (case_tac "pd pa")
    apply simp_all
     apply (case_tac pde,simp_all)
    apply (case_tac pde,simp_all)
   apply (case_tac pde,simp_all)
    apply (clarsimp simp: is_aligned_neg_mask_eq)+
  apply (simp add:fun_upd_def)
  apply (rule entries_align_pde_update)
   apply (drule(1) valid_pdpt_objs_pdD,simp)
  apply simp
  done

lemma store_invalid_pte_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and
        (\<lambda>s. \<forall>pt. ko_at (ArchObj (PageTable pt)) (p && ~~ mask pt_bits) s
        \<longrightarrow> pte = InvalidPTE)\<rbrace>
       store_pte p pte \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: store_pte_def set_pt_def, wp get_object_wp)
  apply (clarsimp simp: obj_at_def)
   apply (intro conjI)
   apply (rule valid_entries_overwrite_0, simp_all)
   apply (fastforce simp: ran_def)
  apply (simp add:fun_upd_def)
  apply (rule entries_align_pte_update)
   apply (drule (1) valid_pdpt_objs_ptD,simp)
  apply simp
  done

lemma store_pte_non_master_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and
        (\<lambda>s. \<forall>pt. ko_at (ArchObj (PageTable pt)) (p && ~~ mask pt_bits) s
        \<longrightarrow> (pte_range_sz (pt (ucast (p && mask pt_bits >> 2) && ~~ mask 4)) = 0
        \<and> pte_range_sz pte = 0))\<rbrace>
       store_pte p pte \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: store_pte_def set_pt_def, wp get_object_wp)
  apply (clarsimp simp: obj_at_def)
  apply (intro conjI)
   apply (rule valid_entries_overwrite_0)
    apply (fastforce simp:ran_def)
   apply (drule bspec)
    apply fastforce
   apply (case_tac "pt pa")
     apply simp
    apply (case_tac pte,simp_all)
    apply (clarsimp simp: is_aligned_neg_mask_eq)
   apply (case_tac pte,simp_all)
  apply (simp add:fun_upd_def)
  apply (rule entries_align_pte_update)
   apply (drule (1) valid_pdpt_objs_ptD,simp)
  apply simp
  done

lemma unmap_page_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs\<rbrace> unmap_page sz asid vptr pptr \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: unmap_page_def mapM_discarded
             cong: vmpage_size.case_cong)
  apply (wp)
    prefer 2
    apply (rule valid_validE[OF find_pd_for_asid_inv])
   apply (rule hoare_pre)
    apply (wp get_object_wp get_pte_wp get_pde_wp lookup_pt_slot_inv_any
              store_invalid_pte_valid_pdpt
              store_invalid_pde_valid_pdpt
              mapM_x_store_invalid_pte_valid_pdpt mapM_x_store_pde_valid_pdpt_objs
                 | simp add: mapM_x_map
                 | wpc | simp add: check_mapping_pptr_def)+
   apply (simp add: fun_upd_def[symmetric] is_aligned_mask[symmetric])
  apply assumption
  done

crunch valid_pdpt_objs[wp]: flush_table "valid_pdpt_objs"
  (wp: crunch_wps simp: crunch_simps)

crunch kheap[wp]: flush_table "\<lambda>s. P (kheap s)"
  (wp: crunch_wps simp: crunch_simps)

lemma unmap_page_table_valid_pdpt_objs[wp]:
  notes hoare_pre [wp_pre del]
  shows "\<lbrace>valid_pdpt_objs\<rbrace> unmap_page_table asid vptr pt \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: unmap_page_table_def)
  apply (wp get_object_wp store_invalid_pde_valid_pdpt | wpc)+
  apply (simp add: obj_at_def)
  apply (simp add: page_table_mapped_def)
  apply (wp get_pde_wp | wpc)+
  apply simp
  apply (rule hoare_post_impErr, rule valid_validE,
         rule find_pd_for_asid_inv, simp_all)
  done

crunch valid_pdpt_objs[wp]: finalise_cap, cap_swap_for_delete, empty_slot "valid_pdpt_objs"
  (wp: crunch_wps select_wp preemption_point_inv simp: crunch_simps unless_def ignore:set_object)

lemma preemption_point_valid_pdpt_objs[wp]:
  "\<lbrace>valid_pdpt_objs\<rbrace> preemption_point \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  by (wp preemption_point_inv | simp)+

lemmas cap_revoke_preservation_valid_pdpt_objs = cap_revoke_preservation[OF _,
                                                          where E=valid_pdpt_objs,
                                                          simplified, THEN validE_valid]

lemmas rec_del_preservation_valid_pdpt_objs = rec_del_preservation[OF _ _ _ _,
                                                    where P=valid_pdpt_objs, simplified]

crunch valid_pdpt_objs[wp]: cap_delete, cap_revoke "valid_pdpt_objs"
  (wp: rec_del_preservation_valid_pdpt_objs cap_revoke_preservation_valid_pdpt_objs)

crunch valid_pdpt_objs[wp]: invalidate_tlb_by_asid, page_table_mapped
   "valid_pdpt_objs"

lemma mapM_x_copy_pde_updates:
  "\<lbrakk> \<forall>x \<in> set xs. f x && ~~ mask pd_bits = 0; is_aligned p pd_bits;
               is_aligned p' pd_bits \<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. (\<not> page_directory_at p s \<longrightarrow> Q s) \<and> (\<not> page_directory_at p' s \<longrightarrow> Q s) \<and>
        (\<forall>pd pd'. ko_at (ArchObj (PageDirectory pd)) p s
                \<and> ko_at (ArchObj (PageDirectory pd')) p' s
           \<longrightarrow> Q (s \<lparr> kheap := (kheap s) (p' := Some (ArchObj (PageDirectory (\<lambda>y. if y \<in> (\<lambda>x.
         ucast (f x && mask pd_bits >> 2)) ` set xs then pd y else pd' y)))) \<rparr>))\<rbrace>
     mapM_x (\<lambda>x. get_pde (p + f x) >>= store_pde (p' + f x)) xs
   \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_x_Nil)
   apply wp
   apply (clarsimp simp: obj_at_def fun_upd_idem dest!: a_type_pdD)
  apply (simp add: mapM_x_Cons)
  apply wp
   apply (thin_tac "valid P f Q" for P f Q)
   apply (simp add: store_pde_def set_pd_def set_object_def
              cong: bind_cong split del: if_split)
   apply (wp get_object_wp get_pde_wp)
  apply (clarsimp simp: obj_at_def a_type_simps mask_out_add_aligned[symmetric]
             split del: if_split)
  apply (simp add: a_type_simps, safe)
   apply (erule rsubst[where P=Q])
   apply (rule abstract_state.fold_congs[OF refl refl])
   apply (rule ext, clarsimp)
   apply (rule ext, simp)
  apply (erule rsubst[where P=Q])
  apply (rule abstract_state.fold_congs[OF refl refl])
  apply (rule ext, clarsimp)
  apply (rule ext, simp add: mask_add_aligned)
  done

lemma copy_global_mappings_valid_pdpt_objs[wp]:
  notes hoare_pre [wp_pre del]
  shows
  "\<lbrace>valid_pdpt_objs and valid_arch_state and pspace_aligned
            and K (is_aligned p pd_bits)\<rbrace>
       copy_global_mappings p \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: copy_global_mappings_def)
  apply wp
   apply (rule_tac P="is_aligned global_pd pd_bits" in hoare_gen_asm)
   apply (rule mapM_x_copy_pde_updates, simp_all)
   apply (clarsimp simp: mask_eq_x_eq_0[symmetric])
   apply (rule less_mask_eq, rule shiftl_less_t2n,
          simp_all add: pd_bits_def pageBits_def)[1]
   apply (drule plus_one_helper2, simp+)
  apply wp
  apply (clarsimp simp: invs_aligned_pdD ranI
                 elim!: ranE split: if_split_asm)
  apply (intro conjI)
   apply (rule_tac S="{x. ucast x \<ge> (kernel_base >> 20)}"
                 in valid_entries_partial_copy)
      apply (fastforce simp: obj_at_def ran_def)
     apply (fastforce simp: obj_at_def ran_def)
    apply (clarsimp simp:image_def)
    apply (subst (asm) less_mask_eq)
     apply (rule shiftl_less_t2n)
      apply (simp add:pd_bits_def pageBits_def word_le_make_less)
     apply (simp add:pd_bits_def pageBits_def)
    apply (subst (asm) shiftl_shiftr1)
     apply simp
    apply (simp add:word_size)
    apply (subst (asm) less_mask_eq)
     apply (simp add:pd_bits_def pageBits_def le_less_trans)
    apply (case_tac v)
      apply (simp add:ucast_ucast_len pd_bits_def pageBits_def le_less_trans)+
    apply (clarsimp split:if_splits)
     apply (simp add:kernel_base_shift_cast_le)
     apply (simp add:kernel_base_def)
     apply (cut_tac y1 = xb and x1 = "0xE00::12 word" in ucast_le_migrate[THEN iffD1,rotated -1])
        apply simp
       apply (simp add:word_size le_less_trans)
      apply (simp add:word_size)
     apply (drule aligned_le_sharp[where n = 4 and a = "0xE00::12 word"])
      apply (simp add:kernel_base_def is_aligned_def)
     apply (erule order_trans)
     apply (erule subst)
     apply (simp add:word_and_le2)
    apply (subst ucast_ucast_len)
     apply (simp,word_bitwise)
    apply simp
   apply (clarsimp simp:image_def)
   apply (rule disjointI)
   apply clarsimp
   apply (drule_tac x = "ucast x" in spec)
   apply (erule impE)
    apply (simp add:pd_bits_def pageBits_def)
    apply word_bitwise
   apply (subgoal_tac "kernel_base >> 20 \<le> ucast x")
    apply simp
    apply (subst (asm) less_mask_eq)
     apply (rule shiftl_less_t2n)
      apply (simp add:pd_bits_def pageBits_def word_le_make_less)
      apply word_bitwise
     apply (simp add:pd_bits_def pageBits_def)
    apply (subst (asm) shiftl_shiftr1)
     apply simp
    apply (simp add:word_size)
    apply (subst (asm) less_mask_eq)
     apply (rule less_le_trans[OF ucast_less])
      apply simp
     apply simp
    apply word_bitwise
   apply (case_tac v,simp_all)
   apply (clarsimp split:if_splits)
   apply (drule aligned_le_sharp[where n = 4])
    apply (simp add:kernel_base_def is_aligned_def)
   apply (simp add:word_size kernel_base_def pd_bits_def pageBits_def)
   apply word_bitwise
   apply simp
  apply (clarsimp simp:obj_at_def)
  apply (subst (asm) is_aligned_neg_mask_eq
    [where p = p and n = pd_bits,symmetric])
   apply simp
  apply (drule(1) valid_pdpt_objs_pdD[rotated])+
  apply (clarsimp simp:entries_align_def)
  done

lemma in_pte_rangeD:
  "x \<in> pte_range v y \<Longrightarrow> x && ~~ mask 4 = y && ~~ mask 4"
  by (case_tac v,simp_all split:if_splits)

lemma in_pde_rangeD:
  "x \<in> pde_range v y \<Longrightarrow> x && ~~ mask 4 = y && ~~ mask 4"
  by (case_tac v,simp_all split:if_splits)

lemma mapM_x_store_pte_valid_pdpt2:
  "\<lbrace>valid_pdpt_objs and K (is_aligned ptr pt_bits)\<rbrace>
     mapM_x (\<lambda>x. store_pte x InvalidPTE) [ptr, ptr + 4 .e. ptr + 2 ^ pt_bits - 1]
   \<lbrace>\<lambda>_. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_gen_asm)+
  apply (rule mapM_x_wp')
  apply (simp add:store_pte_def set_pt_def)
  apply (wp get_pt_wp get_object_wp)
  apply (clarsimp simp: mask_in_range
    split:Structures_A.kernel_object.splits
    arch_kernel_obj.splits)
  apply (rule conjI)
   apply (rule valid_entries_overwrite_0)
    apply (fastforce simp:ran_def obj_at_def)
   apply simp
  apply (simp add:fun_upd_def obj_at_def)
  apply (rule entries_align_pte_update)
   apply (drule (1) valid_pdpt_objs_ptD,simp)
  apply simp
  done

lemma mapM_x_store_pde_valid_pdpt2:
  "\<lbrace>valid_pdpt_objs and K (is_aligned pd pd_bits)\<rbrace>
       mapM_x (\<lambda>x. store_pde ((x << 2) + pd) pde.InvalidPDE)
        [0.e.(kernel_base >> 20) - 1]
       \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (rule mapM_x_wp')
  apply (simp add:store_pde_def set_pd_def)
  apply (wp get_pd_wp get_object_wp)
  apply (clarsimp simp: mask_in_range
    split:Structures_A.kernel_object.splits
    arch_kernel_obj.splits)
  apply (rule conjI)
   apply (rule valid_entries_overwrite_0)
    apply (fastforce simp:ran_def obj_at_def)
   apply simp
  apply (simp add:fun_upd_def obj_at_def)
  apply (rule entries_align_pde_update)
   apply (drule (1) valid_pdpt_objs_pdD,simp)
  apply simp
  done

lemma non_invalid_in_pde_range:
  "pde \<noteq> InvalidPDE
  \<Longrightarrow> x \<in> pde_range pde x"
  by (case_tac pde,simp_all)

lemma non_invalid_in_pte_range:
  "pte \<noteq> InvalidPTE
  \<Longrightarrow> x \<in> pte_range pte x"
  by (case_tac pte,simp_all)

crunch valid_pdpt_objs[wp]: cancel_badged_sends "valid_pdpt_objs"
  (simp: crunch_simps filterM_mapM wp: crunch_wps ignore: filterM)

crunch valid_pdpt_objs[wp]: cap_move, cap_insert "valid_pdpt_objs"

lemma invoke_cnode_valid_pdpt_objs[wp]:
  "\<lbrace>valid_pdpt_objs and invs and valid_cnode_inv i\<rbrace> invoke_cnode i \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: invoke_cnode_def)
  apply (rule hoare_pre)
   apply (wp get_cap_wp | wpc | simp split del: if_split)+
  done

lemma as_user_valid_pdpt_objs[wp]:
  "\<lbrace>valid_pdpt_objs\<rbrace> as_user t m \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: as_user_def split_def)
  apply wp
  apply simp
  done

crunch valid_pdpt_objs[wp]: invoke_tcb "valid_pdpt_objs"
  (wp: check_cap_inv crunch_wps simp: crunch_simps
       ignore: check_cap_at)

lemma invoke_domain_valid_pdpt_objs[wp]:
  "\<lbrace>valid_pdpt_objs\<rbrace> invoke_domain t d \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  by (simp add: invoke_domain_def | wp)+

crunch valid_pdpt_objs[wp]: set_extra_badge, transfer_caps_loop "valid_pdpt_objs"
  (wp: transfer_caps_loop_pres)

crunch valid_pdpt_objs[wp]: send_ipc, send_signal,
    do_reply_transfer, invoke_irq_control, invoke_irq_handler "valid_pdpt_objs"
  (wp: crunch_wps simp: crunch_simps
         ignore: clearMemory const_on_failure set_object)

lemma valid_pdpt_objs_trans_state[simp]: "valid_pdpt_objs (trans_state f s) = valid_pdpt_objs s"
  apply (simp add: obj_valid_pdpt_def)
  done

lemma retype_region_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs\<rbrace> retype_region ptr bits o_bits type dev \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: retype_region_def split del: if_split)
  apply (wp | simp only: valid_pdpt_objs_trans_state trans_state_update[symmetric])+
  apply (clarsimp simp: retype_addrs_fold foldr_upd_app_if ranI
                 elim!: ranE split: if_split_asm simp del:fun_upd_apply)
  apply (simp add: default_object_def default_arch_object_def
            split: Structures_A.kernel_object.splits
    Structures_A.apiobject_type.split aobject_type.split)+
  apply (simp add:entries_align_def)
  done

lemma detype_valid_pdpt[elim!]:
  "valid_pdpt_objs s \<Longrightarrow> valid_pdpt_objs (detype S s)"
  by (auto simp add: detype_def ran_def)

crunch valid_pdpt_objs[wp]: create_cap "valid_pdpt_objs"
  (ignore: clearMemory simp: crunch_simps unless_def)

lemma init_arch_objects_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and pspace_aligned and valid_arch_state
           and K (\<exists>us sz. orefs = retype_addrs ptr type n us
               \<and> range_cover ptr sz (obj_bits_api type us) n)\<rbrace>
     init_arch_objects type ptr n obj_sz orefs
   \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_gen_asm)+
  apply (clarsimp simp: init_arch_objects_def
             split del: if_split)
  apply (rule hoare_pre)
   apply (wp | wpc)+
     apply (rule_tac Q="\<lambda>rv. valid_pdpt_objs and pspace_aligned and valid_arch_state"
                  in hoare_post_imp, simp)
     apply (rule mapM_x_wp')
     apply (rule hoare_pre, wp copy_global_mappings_valid_pdpt_objs)
     apply clarsimp
     apply (drule_tac sz=sz in retype_addrs_aligned)
        apply (simp add:range_cover_def)
       apply (drule range_cover.sz,simp add:word_bits_def)
      apply (simp add:range_cover_def)
     apply (clarsimp simp:obj_bits_api_def pd_bits_def pageBits_def
       arch_kobj_size_def default_arch_object_def range_cover_def)+
   apply wp
  apply simp
  done

lemma delete_objects_valid_pdpt:
  "\<lbrace>valid_pdpt_objs\<rbrace> delete_objects ptr bits \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  by (rule delete_objects_reduct) (wp detype_valid_pdpt)

crunch valid_pdpt[wp]: reset_untyped_cap "valid_pdpt_objs"
  (wp: mapME_x_inv_wp crunch_wps simp: crunch_simps unless_def)

lemma invoke_untyped_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs and invs and ct_active
          and valid_untyped_inv ui\<rbrace>
       invoke_untyped ui
   \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_pre, rule invoke_untyped_Q)
      apply (wp init_arch_objects_valid_pdpt | simp)+
     apply (auto simp: post_retype_invs_def split: if_split_asm)[1]
    apply (wp | simp)+
  done

crunch valid_pdpt_objs[wp]: perform_asid_pool_invocation,
     perform_asid_control_invocation "valid_pdpt_objs"
  (ignore: delete_objects wp: delete_objects_valid_pdpt static_imp_wp)

abbreviation (input)
  "safe_pt_range \<equiv> \<lambda>slots s. obj_at (\<lambda>ko. \<exists>pt. ko = ArchObj (PageTable pt)
                                    \<and> (\<forall>x\<in>set (tl slots). pt (ucast (x && mask pt_bits >> 2))
                                      = pte.InvalidPTE))
                              (hd slots && ~~ mask pt_bits) s"

abbreviation (input)
  "safe_pd_range \<equiv> \<lambda>slots s. obj_at (\<lambda>ko. \<exists>pd. ko = ArchObj (PageDirectory pd)
                                    \<and> (\<forall>x\<in>set (tl slots). pd (ucast (x && mask pd_bits >> 2))
                                      = pde.InvalidPDE))
                              (hd slots && ~~ mask pd_bits) s"

definition
  "page_inv_entries_pre entries \<equiv>
   let slots = (case entries of Inl (pte, slots) \<Rightarrow> slots | Inr (pde, slots) \<Rightarrow> slots)
   in (if \<exists>sl. slots = [sl]
    then case entries of
        Inl (pte, _) \<Rightarrow> obj_at (\<lambda>ko. \<exists>pt pte. ko = ArchObj (PageTable pt)
                     \<and> pt (ucast (hd slots && mask pt_bits >> 2) && ~~ mask 4) = pte
                     \<and> pte_range_sz pte = 0)
                 (hd slots && ~~ mask pt_bits)
            and K (pte_range_sz pte = 0)
      | Inr (pde, _) \<Rightarrow> obj_at (\<lambda>ko. \<exists>pd pde. ko = ArchObj (PageDirectory pd)
                     \<and> pd (ucast (head slots && mask pd_bits >> 2) && ~~ mask 4)
                            = pde \<and> pde_range_sz pde = 0)
                 (hd slots && ~~ mask pd_bits)
           and K (pde_range_sz pde = 0)
    else  (\<lambda>s. (\<exists>p. is_aligned p 6 \<and> slots = map (\<lambda>x. x + p) [0, 4 .e. 0x3C])))
   and K (case entries of Inl (pte,slots) \<Rightarrow> pte \<noteq> InvalidPTE
     | Inr (pde,slots) \<Rightarrow> pde \<noteq> InvalidPDE)"

definition
  "page_inv_entries_safe entries \<equiv>
   let slots = (case entries of Inl (pte, slots) \<Rightarrow> slots | Inr (pde, slots) \<Rightarrow> slots)
   in if \<exists>sl. slots = [sl]
    then case entries of
        Inl (pte, _) \<Rightarrow> obj_at (\<lambda>ko. \<exists>pt pte. ko = ArchObj (PageTable pt)
                     \<and> pt (ucast (hd slots && mask pt_bits >> 2) && ~~ mask 4) = pte
                     \<and> pte_range_sz pte = 0)
                 (hd slots && ~~ mask pt_bits)
            and K (pte_range_sz pte = 0)
      | Inr (pde, _) \<Rightarrow> obj_at (\<lambda>ko. \<exists>pd pde. ko = ArchObj (PageDirectory pd)
                     \<and> pd (ucast (head slots && mask pd_bits >> 2) && ~~ mask 4)
                            = pde \<and> pde_range_sz pde = 0)
                 (hd slots && ~~ mask pd_bits)
           and K (pde_range_sz pde = 0)
    else  (\<lambda>s. (\<exists>p. is_aligned p 6 \<and> slots = map (\<lambda>x. x + p) [0, 4 .e. 0x3C]
                  \<and> (case entries of
                     Inl (pte, _) \<Rightarrow> safe_pt_range slots s
                   | Inr (pde, _) \<Rightarrow> safe_pd_range slots s
                     )))"

definition
  "page_inv_duplicates_valid iv \<equiv> case iv of
         PageMap asid cap ct_slot entries \<Rightarrow>
            page_inv_entries_safe entries
       | PageRemap asid entries \<Rightarrow>
            page_inv_entries_safe entries
       | _ \<Rightarrow> \<top>"

lemma pte_range_interD:
 "pte_range pte p \<inter> pte_range pte' p' \<noteq> {}
  \<Longrightarrow> pte \<noteq> InvalidPTE \<and> pte' \<noteq> InvalidPTE
      \<and> p && ~~ mask 4 = p' && ~~ mask 4"
  apply (drule int_not_emptyD)
  apply (case_tac pte,simp_all split:if_splits)
   apply (case_tac pte',simp_all split:if_splits)
   apply clarsimp
   apply (case_tac pte',simp_all split:if_splits)
  apply (case_tac pte', simp_all split:if_splits)
  done

lemma pde_range_interD:
 "pde_range pde p \<inter> pde_range pde' p' \<noteq> {}
  \<Longrightarrow> pde \<noteq> InvalidPDE \<and> pde' \<noteq> InvalidPDE
      \<and> p && ~~ mask 4 = p' && ~~ mask 4"
  apply (drule int_not_emptyD)
  apply (case_tac pde,simp_all split:if_splits)
     apply (case_tac pde',simp_all split:if_splits)
    apply (case_tac pde',simp_all split:if_splits)
   apply clarsimp
   apply (case_tac pde', simp_all split:if_splits)
  apply (case_tac pde', simp_all split:if_splits)
  done

lemma pte_range_sz_le:
  "(pte_range_sz pte) \<le> 4"
  by (case_tac pte,simp_all)

lemma pde_range_sz_le:
  "(pde_range_sz pde) \<le> 4"
  by (case_tac pde,simp_all)

(* BUG , revisit the following lemmas , moved from ArchAcc_R.thy *)
lemma mask_pd_bits_shift_ucast_align[simp]:
  "is_aligned (ucast (p && mask pd_bits >> 2)::12 word) 4 =
   is_aligned ((p::word32) >> 2) 4"
  by (clarsimp simp: is_aligned_mask mask_def pd_bits) word_bitwise

lemma mask_pt_bits_shift_ucast_align[simp]:
  "is_aligned (ucast (p && mask pt_bits >> 2)::word8) 4 =
   is_aligned ((p::word32) >> 2) 4"
  by (clarsimp simp: is_aligned_mask mask_def pt_bits_def pageBits_def)
     word_bitwise

lemma store_pte_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and page_inv_entries_safe (Inl (pte, slots))\<rbrace>
       store_pte (hd slots) pte \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp:page_inv_entries_safe_def split:if_splits)
   apply (clarsimp simp:store_pte_def set_pt_def)
   apply (wp get_pt_wp get_object_wp)
   apply (clarsimp simp:obj_at_def
     split:pte.splits arch_kernel_obj.splits)
  apply (rule conjI)
    apply (drule(1) valid_pdpt_objs_ptD)
    apply (rule valid_entries_overwrite_0)
     apply simp
    apply (case_tac pte)
     apply simp+
    apply (case_tac "pta p",simp_all)
    apply (clarsimp simp: is_aligned_neg_mask_eq)
   apply (simp add:fun_upd_def)
   apply (rule entries_align_pte_update)
    apply (drule (1) valid_pdpt_objs_ptD,simp)
   apply simp
  apply (simp add:hd_map_simp upto_enum_def upto_enum_step_def)
  apply (clarsimp simp:store_pte_def set_pt_def)
  apply (wp get_pt_wp get_object_wp)
  apply (clarsimp simp:obj_at_def
     split:pte.splits arch_kernel_obj.splits)
  apply (drule(1) valid_pdpt_objs_ptD)
  apply (rule conjI)
   apply (rule valid_entries_overwrite_0)
    apply simp
   apply (rule ccontr)
   apply (drule pte_range_interD)
   apply clarsimp
   apply (simp add:ucast_neg_mask)
   apply (subst (asm) is_aligned_neg_mask_eq[where n = 4])
    apply (rule is_aligned_shiftr[OF is_aligned_andI1])
    apply simp
   apply (drule_tac x = "((p && ~~ mask pt_bits)  + ((ucast pa) << 2))" in bspec)
    apply (clarsimp simp: tl_map_simp upto_0_to_n2 image_def)
    apply (rule_tac x = "unat (((ucast pa)::word32) - (p && mask pt_bits >> 2))" in bexI)
     apply (simp add:ucast_nat_def shiftl_t2n mask_out_sub_mask)
     apply (subst shiftl_t2n[where n = 2,simplified field_simps,simplified,symmetric])
     apply (subst shiftr_shiftl1)
      apply simp+
     apply (subst is_aligned_neg_mask_eq)
      apply (erule is_aligned_andI1[OF is_aligned_weaken])
      apply simp
     apply simp
    apply simp
    apply (drule_tac s = "ucast (p && mask pt_bits >> 2)" in sym)
    apply (simp add:mask_out_sub_mask field_simps)
    apply (drule_tac f = "ucast::(word8\<Rightarrow>word32)" in arg_cong)
    apply (simp add:ucast_pt_index pt_bits_def pageBits_def)
    apply (simp add:unat_ucast_8_32)
    apply (rule conjI)
     apply (subgoal_tac "unat (pa && mask 4)\<noteq> 0")
      apply simp
     apply (simp add:unat_gt_0)
    apply (rule unat_less_helper)
    apply (rule le_less_trans[OF word_and_le1])
    apply (simp add:mask_def)
   apply (simp add:field_simps neg_mask_add_mask)
   apply (thin_tac "ucast y = x" for y x)
   apply (subst (asm) less_mask_eq[where n = pt_bits])
    apply (rule shiftl_less_t2n)
     apply (simp add:pt_bits_def pageBits_def)
     apply word_bitwise
    apply (simp add:pt_bits_def pageBits_def)
   apply (subst (asm) shiftl_shiftr_id)
    apply simp
   apply (simp,word_bitwise)
   apply (simp add:ucast_ucast_id)
  apply (simp add:fun_upd_def entries_align_def)
  apply (rule is_aligned_weaken[OF _ pte_range_sz_le])
  apply (simp add:is_aligned_shiftr)
  done

lemma store_pde_valid_pdpt:
  "\<lbrace>valid_pdpt_objs and page_inv_entries_safe (Inr (pde, slots))\<rbrace>
       store_pde (hd slots) pde \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp:page_inv_entries_safe_def split:if_splits)
   apply (clarsimp simp:store_pde_def set_pd_def)
   apply (wp get_pd_wp get_object_wp)
   apply (clarsimp simp:obj_at_def
     split:pde.splits arch_kernel_obj.splits)
   apply (drule(1) valid_pdpt_objs_pdD)
   apply (rule conjI)
    apply (rule valid_entries_overwrite_0)
     apply simp
    apply (case_tac pde,simp_all)
     apply (case_tac "pda p",simp_all)
     apply (clarsimp simp: is_aligned_neg_mask_eq)
    apply (case_tac "pda p",simp_all)
    apply (clarsimp simp: is_aligned_neg_mask_eq)
   apply (simp add:fun_upd_def)
   apply (rule entries_align_pde_update)
    apply simp+
  apply (simp add:hd_map_simp upto_enum_def upto_enum_step_def)
  apply (clarsimp simp:store_pde_def set_pd_def)
  apply (wp get_pd_wp get_object_wp)
  apply (clarsimp simp:obj_at_def
     split:pde.splits arch_kernel_obj.splits)
  apply (drule(1) valid_pdpt_objs_pdD)
  apply (rule conjI)
   apply (rule valid_entries_overwrite_0)
    apply simp
   apply (rule ccontr)
   apply (drule pde_range_interD)
   apply clarsimp
   apply (simp add:ucast_neg_mask)
   apply (subst (asm) is_aligned_neg_mask_eq[where n = 4])
    apply (rule is_aligned_shiftr[OF is_aligned_andI1])
    apply simp
   apply (drule_tac x = "((p && ~~ mask pd_bits)  + ((ucast pa) << 2))" in bspec)
    apply (clarsimp simp: tl_map_simp upto_0_to_n2 image_def)
    apply (rule_tac x = "unat (((ucast pa)::word32) - (p && mask pd_bits >> 2))" in bexI)
     apply (simp add:ucast_nat_def shiftl_t2n mask_out_sub_mask)
     apply (subst shiftl_t2n[where n = 2,simplified field_simps,simplified,symmetric])
     apply (subst shiftr_shiftl1)
      apply simp+
     apply (subst is_aligned_neg_mask_eq)
      apply (erule is_aligned_andI1[OF is_aligned_weaken])
      apply simp
     apply simp
    apply simp
    apply (drule_tac s = "ucast (p && mask pd_bits >> 2)" in sym)
    apply (simp add:mask_out_sub_mask field_simps)
    apply (drule_tac f = "ucast::(12 word\<Rightarrow>word32)" in arg_cong)
    apply (simp add:ucast_pd_index pd_bits_def pageBits_def)
    apply (simp add:unat_ucast_12_32)
    apply (rule conjI)
     apply (subgoal_tac "unat (pa && mask 4)\<noteq> 0")
      apply simp
     apply (simp add:unat_gt_0)
    apply (rule unat_less_helper)
    apply (rule le_less_trans[OF word_and_le1])
    apply (simp add:mask_def)
   apply (simp add:field_simps neg_mask_add_mask)
   apply (thin_tac "ucast y = x" for y x)
   apply (subst (asm) less_mask_eq[where n = pd_bits])
    apply (rule shiftl_less_t2n)
     apply (simp add:pd_bits_def pageBits_def)
     apply word_bitwise
    apply (simp add:pd_bits_def pageBits_def)
   apply (subst (asm) shiftl_shiftr_id)
     apply simp
    apply (simp,word_bitwise)
   apply (simp add:ucast_ucast_id)
  apply (simp add:entries_align_def)
  apply (rule is_aligned_weaken[OF _ pde_range_sz_le])
  apply (simp add:is_aligned_shiftr)
  done

lemma set_cap_page_inv_entries_safe:
  "\<lbrace>page_inv_entries_safe x\<rbrace> set_cap y z \<lbrace>\<lambda>_. page_inv_entries_safe x\<rbrace>"
  apply (simp add:page_inv_entries_safe_def set_cap_def split_def
    get_object_def set_object_def)
  apply (wp | wpc)+
  apply (case_tac x)
  apply (auto simp:obj_at_def
    Let_def split:if_splits option.splits)
  done

crunch valid_pdpt[wp]: pte_check_if_mapped, pde_check_if_mapped "valid_pdpt_objects"

lemma perform_page_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs and valid_page_inv pinv and page_inv_duplicates_valid pinv\<rbrace>
        perform_page_invocation pinv \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: perform_page_invocation_def page_inv_duplicates_valid_def)
  apply (cases pinv,
         simp_all add: mapM_discarded page_inv_entries_safe_def
            split: sum.split arch_cap.split option.split,
         safe intro!: hoare_gen_asm hoare_gen_asm[unfolded K_def],
         simp_all add: mapM_x_Nil mapM_x_Cons mapM_x_map)
            apply (wp store_pte_valid_pdpt store_pde_valid_pdpt get_master_pte_wp get_master_pde_wp
                      store_pte_non_master_valid_pdpt store_pde_non_master_valid_pdpt
                      mapM_x_wp'[OF store_invalid_pte_valid_pdpt
                        [where pte=pte.InvalidPTE, simplified]]
                      mapM_x_wp'[OF store_invalid_pde_valid_pdpt
                        [where pde=pde.InvalidPDE, simplified]]
                      set_cap_page_inv_entries_safe
                      hoare_vcg_imp_lift[OF set_cap_arch_obj_neg] hoare_vcg_all_lift
                 | clarsimp simp: cte_wp_at_weakenE[OF _ TrueI] obj_at_def
                                  pte_range_sz_def pde_range_sz_def swp_def valid_page_inv_def
                                  valid_slots_def page_inv_entries_safe_def pte_check_if_mapped_def
                                  pde_check_if_mapped_def
                           split: pte.splits pde.splits
                 | wp_once hoare_drop_imps)+
  done

definition
  "pti_duplicates_valid iv \<equiv>
   case iv of PageTableMap cap ct_slot pde pd_slot
     \<Rightarrow> obj_at (\<lambda>ko. \<exists>pd pde. ko = ArchObj (PageDirectory pd)
                     \<and> pd (ucast (pd_slot && mask pd_bits >> 2) && ~~ mask 4)
                            = pde \<and> pde_range_sz pde = 0)
                 (pd_slot && ~~ mask pd_bits)

           and K (pde_range_sz pde = 0)
  | _ \<Rightarrow> \<top>"

definition
  "invocation_duplicates_valid i \<equiv>
   case i of
     InvokeArchObject (InvokePage pgi) \<Rightarrow> page_inv_duplicates_valid pgi
   | InvokeArchObject (InvokePageTable pti) \<Rightarrow> pti_duplicates_valid pti
   | _ \<Rightarrow> \<top>"

lemma perform_page_table_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs and valid_pti pinv and pti_duplicates_valid pinv\<rbrace>
      perform_page_table_invocation pinv \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: perform_page_table_invocation_def split_def
             cong: page_table_invocation.case_cong
                   option.case_cong cap.case_cong arch_cap.case_cong)
  apply (rule hoare_pre)
   apply (wp store_pde_non_master_valid_pdpt hoare_vcg_ex_lift
             set_cap_arch_obj mapM_x_store_pte_valid_pdpt2
              | wpc
              | simp add: swp_def
              | strengthen all_imp_ko_at_from_ex_strg)+
  apply (clarsimp simp: pti_duplicates_valid_def valid_pti_def)
  apply (auto simp: obj_at_def cte_wp_at_caps_of_state valid_cap_simps
                    cap_aligned_def pt_bits_def pageBits_def
            intro!: inj_onI)
  done

lemma perform_page_directory_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs and valid_pdi pinv\<rbrace>
      perform_page_directory_invocation pinv \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: perform_page_directory_invocation_def split_def)
  apply (rule hoare_pre)
   apply (wp | wpc | simp)+
  done

lemma perform_invocation_valid_pdpt[wp]:
  "\<lbrace>invs and ct_active and valid_invocation i and valid_pdpt_objs
           and invocation_duplicates_valid i\<rbrace>
      perform_invocation blocking call i
         \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (cases i, simp_all)
  apply (wp send_signal_interrupt_states | simp)+
  apply (clarsimp simp: invocation_duplicates_valid_def)
  apply (wp | wpc | simp)+
  apply (simp add: arch_perform_invocation_def)
  apply (rule hoare_pre)
  apply (wp | wpc | simp)+
  apply (auto simp: valid_arch_inv_def invocation_duplicates_valid_def)
  done

lemma neg_mask_pt_6_4:
  "(ptr && mask pt_bits >> 2) && ~~ mask 4 =
   (ptr::word32) && ~~ mask 6 && mask pt_bits >> 2"
  apply (simp add:pt_bits_def pageBits_def)
  apply word_bitwise
  apply (simp add:word_size)
  done

lemma neg_mask_pd_6_4:
  "(ptr && mask pd_bits >> 2) && ~~ mask 4 =
   (ptr::word32) && ~~ mask 6 && mask pd_bits >> 2"
  apply (simp add:pd_bits_def pageBits_def)
  apply word_bitwise
  apply (simp add:word_size)
  done

lemma mask_out_same_pt:
  "\<lbrakk>is_aligned p 6; x < 2 ^ 6 \<rbrakk> \<Longrightarrow> p + x && ~~ mask pt_bits = p && ~~ mask pt_bits"
  apply (subst mask_lower_twice[symmetric,where n = 6])
   apply (simp add:pt_bits_def pageBits_def)
  apply (simp add:is_aligned_add_helper)
  done

lemma mask_out_same_pd:
  "\<lbrakk>is_aligned p 6; x < 2 ^ 6 \<rbrakk> \<Longrightarrow> p + x && ~~ mask pd_bits = p && ~~ mask pd_bits"
  apply (subst mask_lower_twice[symmetric,where n = 6])
   apply (simp add:pd_bits_def pageBits_def)
  apply (simp add:is_aligned_add_helper)
  done

lemma ensure_safe_mapping_ensures[wp]:
  "\<lbrace>valid_pdpt_objs and (case entries of (Inl (SmallPagePTE _ _ _, [_])) \<Rightarrow> \<top>
                  | (Inl (SmallPagePTE _ _ _, _)) \<Rightarrow> \<bottom>
                  | (Inl (LargePagePTE _ _ _, [])) \<Rightarrow> \<bottom>
                  | (Inr (SectionPDE _ _ _ _, [_])) \<Rightarrow> \<top>
                  | (Inr (SuperSectionPDE _ _ _, [])) \<Rightarrow> \<bottom>
                  | (Inr (SectionPDE _ _ _ _, _)) \<Rightarrow> \<bottom>
                  | _ \<Rightarrow> page_inv_entries_pre entries)\<rbrace>
     ensure_safe_mapping entries
   \<lbrace>\<lambda>rv. page_inv_entries_safe entries\<rbrace>,-"
  proof -
    have [simp]:
      "\<And>s a. page_inv_entries_pre (Inl (pte.InvalidPTE, a)) s \<Longrightarrow>
      page_inv_entries_safe (Inl (pte.InvalidPTE, a)) s"
      apply (clarsimp simp:page_inv_entries_pre_def page_inv_entries_safe_def
        split:if_splits)
      done
    have name_pre:
      "\<And>F P Q. (\<And>s. P s \<Longrightarrow> \<lbrace>op = s \<rbrace> F \<lbrace>Q\<rbrace>, -) \<Longrightarrow> \<lbrace>P\<rbrace> F \<lbrace>Q\<rbrace>,-"
      apply (simp add:validE_R_def validE_def)
      apply (rule hoare_name_pre_state)
      apply assumption
      done
    have mask_neg_mask_order[simp]:
      "\<And>a m n. a && ~~ mask m && mask n = a && mask n && ~~ mask m"
       by (simp add:word_bw_comms word_bw_lcs)
    have align_entry_ptD:
      "\<And>pt m x xb xc. \<lbrakk>pt m = pte.LargePagePTE x xb xc; entries_align pte_range_sz pt\<rbrakk>
       \<Longrightarrow> is_aligned m 4"
      apply (simp add:entries_align_def)
      apply (drule_tac x = m in spec,simp)
      done
    have align_entry_pdD:
      "\<And>pd m x xb xc. \<lbrakk>pd m = pde.SuperSectionPDE x xb xc; entries_align pde_range_sz pd\<rbrakk>
       \<Longrightarrow> is_aligned m 4"
      apply (simp add:entries_align_def)
      apply (drule_tac x = m in spec,simp)
      done
    have pt_offset_bitwise[simp]:"\<And>a. (ucast ((a::word32) && mask pt_bits && ~~ mask 6  >> 2)::word8)
      = (ucast (a  && mask pt_bits >> 2)::word8) && ~~ mask 4"
    apply (simp add:pt_bits_def pageBits_def mask_def)
    apply word_bitwise
    done
    have pd_offset_bitwise[simp]:"\<And>a. (ucast ((a::word32) && mask pd_bits && ~~ mask 6  >> 2)::12 word)
      = (ucast (a  && mask pd_bits >> 2)::12 word) && ~~ mask 4"
    apply (simp add:pt_bits_def pageBits_def mask_def pd_bits_def)
    apply word_bitwise
    done
    have mask_neq_0:
      "\<And>z zs xa p g. \<lbrakk>[0 :: word32, 4 .e. 0x3C] = z # zs; xa \<in> set zs; is_aligned p 6; 6 \<le> g\<rbrakk>
         \<Longrightarrow> (p + xa && mask g >> 2) && mask 4 \<noteq> 0"
     apply (rule ccontr)
      apply (simp add:is_aligned_mask[symmetric])
       apply (drule is_aligned_shiftl[where n = 6 and m = 2,simplified])
      apply (subst (asm) shiftr_shiftl1)
       apply simp+
      apply (subst (asm) is_aligned_neg_mask_eq)
       apply (rule is_aligned_andI1)
       apply (erule aligned_add_aligned)
        apply (clarsimp simp :upto_enum_def upto_enum_step_def
         Fun.comp_def upto_0_to_n2 is_aligned_mult_triv2[where n = 2,simplified])
       apply simp
      apply (simp add:is_aligned_mask mask_twice
        pt_bits_def pageBits_def min_def)
      apply (subst (asm) is_aligned_mask[symmetric])
      apply (subst (asm) is_aligned_add_helper)
       apply simp
      apply (clarsimp simp :upto_enum_def upto_enum_step_def
         Fun.comp_def upto_0_to_n2)
      apply (subst shiftl_t2n
        [where n = 2,simplified field_simps,simplified,symmetric])+
      apply (rule shiftl_less_t2n[where m = 6,simplified])
       apply (rule word_of_nat_less)
       apply simp
      apply simp
     apply (clarsimp simp :upto_enum_def upto_enum_step_def
         Fun.comp_def upto_0_to_n2)
     apply (cut_tac x = "of_nat x" and n = 2 in word_power_nonzero_32)
        apply (simp add:word_of_nat_less word_bits_def)+
      apply (simp add: of_nat_neq_0)
     apply simp
     done
    have neq_pt_offset: "\<And>z zs xa (p::word32). \<lbrakk>[0 , 4 .e. 0x3C] = z # zs;
        xa \<in> set zs;is_aligned p 6 \<rbrakk> \<Longrightarrow>
        ucast (p + xa && mask pt_bits >> 2) && ~~ mask 4 \<noteq> ((ucast (p + xa && mask pt_bits >> 2))::word8)"
      apply (rule ccontr)
      apply (simp add:mask_out_sub_mask ucast_and_mask[symmetric])
      apply (drule arg_cong[where f = unat])
      apply (simp add:unat_ucast)
      apply (subst (asm) mod_less)
       apply (rule unat_less_helper)
       apply (rule le_less_trans[OF word_and_le1])
       apply (simp add:mask_def)
      apply (simp add:unat_eq_0)
      apply (drule(2) mask_neq_0[of _ _ _ _ pt_bits])
       apply (simp add:pt_bits_def pageBits_def)+
      done
    have neq_pd_offset: "\<And>z zs xa (p::word32). \<lbrakk>[0 , 4 .e. 0x3C] = z # zs;
        xa \<in> set zs;is_aligned p 6 \<rbrakk> \<Longrightarrow>
        ucast (p + xa && mask pd_bits >> 2) && ~~ mask 4 \<noteq> ((ucast (p + xa && mask pd_bits >> 2)) :: 12 word)"
      apply (simp add:mask_out_sub_mask)
      apply (rule ccontr)
      apply (simp add:mask_out_sub_mask ucast_and_mask[symmetric])
      apply (drule arg_cong[where f = unat])
      apply (simp add:unat_ucast)
      apply (subst (asm) mod_less)
       apply (rule unat_less_helper)
       apply (rule le_less_trans[OF word_and_le1])
       apply (simp add:mask_def)
      apply (simp add:unat_eq_0)
      apply (drule(2) mask_neq_0[of _ _ _ _ pd_bits])
       apply (simp add:pd_bits_def pageBits_def)+
      done
    have invalid_pteI:
      "\<And>a pt x y z. \<lbrakk>valid_pt_entries pt; (a && ~~ mask 4) \<noteq> a;
       pt (a && ~~ mask 4) = pte.LargePagePTE x y z \<rbrakk>
       \<Longrightarrow> pt a = pte.InvalidPTE"
      apply (drule(1) valid_entriesD[rotated])
      apply (case_tac "pt a"; simp add:mask_lower_twice is_aligned_neg_mask split:if_splits)
      apply fastforce
      done
    have invalid_pdeI:
      "\<And>a pd x y z. \<lbrakk>valid_pd_entries pd; (a && ~~ mask 4) \<noteq> a;
       pd (a && ~~ mask 4) = pde.SuperSectionPDE x y z \<rbrakk>
       \<Longrightarrow> pd a = pde.InvalidPDE"
      apply (drule(1) valid_entriesD[rotated])
      apply (case_tac "pd a",
        simp_all add:mask_lower_twice is_aligned_neg_mask
        split:if_splits)
      apply fastforce
      done
    have inj[simp]:
      "\<And>p. is_aligned (p::word32) 6 \<Longrightarrow> inj_on (\<lambda>x. toEnum x * 4 + p) {Suc 0..<16}"
      apply (clarsimp simp:inj_on_def)
      apply (subst (asm) shiftl_t2n[where n = 2,simplified field_simps,simplified,symmetric])+
      apply (drule arg_cong[where f = "\<lambda>x. x >> 2"])
      apply (simp add:shiftl_shiftr_id word_of_nat_less)
      apply (simp add:of_nat_inj)
      done

  show ?thesis
  apply (rule name_pre)
  apply (case_tac entries)
   apply (case_tac a, case_tac aa)
     apply (simp add:page_inv_entries_pre_def page_inv_entries_safe_def
       | wp | intro conjI impI)+
     apply (simp split:list.splits add:page_inv_entries_pre_def)+
    apply (rename_tac obj_ref vm_attributes cap_rights slot slots)
    apply (elim conjE exE)
    apply (subst mapME_x_Cons)
    apply simp
    apply wp
     apply (rule_tac Q' = "\<lambda>r s. \<forall>x \<in> set slots. obj_at
                (\<lambda>ko. \<exists>pt. ko = ArchObj (PageTable pt) \<and>
                 pt (ucast (x && mask pt_bits >> 2)) = pte.InvalidPTE)
                (hd (slot # slots) && ~~ mask pt_bits) s" in hoare_post_imp_R)
      apply (wp mapME_x_accumulate_checks[where Q = "\<lambda>s. valid_pdpt_objs s"] )
          apply (wp get_master_pte_wp| wpc | simp)+
         apply clarsimp
         apply (frule_tac x = xa in mask_out_same_pt)
          apply (clarsimp simp:upto_enum_def upto_enum_step_def upto_0_to_n2)
          apply (erule notE)
          apply (subst shiftl_t2n[where n = 2,simplified field_simps,simplified,symmetric])
          apply (rule shiftl_less_t2n[where m = 6,simplified])
           apply (simp add:word_of_nat_less)
          apply simp
         apply (frule_tac x = z in mask_out_same_pt)
          apply (clarsimp simp:upto_enum_def upto_enum_step_def upto_0_to_n2)
         apply (clarsimp simp:field_simps obj_at_def
           split:pte.splits)
         apply (intro conjI impI)
           apply (clarsimp)
           apply (drule(1) valid_pdpt_objs_ptD)
           apply (frule align_entry_ptD,simp)
           apply (simp add:is_aligned_neg_mask_eq)
          apply clarsimp
          apply (drule(1) valid_pdpt_objs_ptD,clarify)
          apply (erule(4) invalid_pteI[OF _ neq_pt_offset])
         apply clarsimp
         apply (drule(1) valid_pdpt_objs_ptD,clarify)
         apply (frule align_entry_ptD,simp)
         apply (simp add:is_aligned_neg_mask_eq)
        apply (wp hoare_drop_imps |wpc|simp)+
      apply (clarsimp simp:upto_enum_def upto_enum_step_def
        upto_0_to_n2 Fun.comp_def distinct_map)
     apply (intro exI conjI,fastforce+)
     apply (simp add:obj_at_def hd_map_simp
         upto_0_to_n2 upto_enum_def upto_enum_step_def)
     apply (frule_tac x = 1 in bspec,fastforce+)
    apply ((wp hoare_drop_imps |wpc|simp)+)[1]
   apply (simp add:page_inv_entries_pre_def page_inv_entries_safe_def
       | wp | intro conjI impI)+
    apply (simp split:list.splits add:page_inv_entries_pre_def mapME_singleton)
    apply (wp get_master_pte_wp |wpc | simp)+
    apply (clarsimp simp:obj_at_def split:pte.splits)
   apply (clarsimp simp:page_inv_entries_safe_def split:list.splits)
  apply (simp split:list.splits add:page_inv_entries_pre_def mapME_singleton)
  apply (case_tac b,case_tac a)
     apply ((simp add:page_inv_entries_pre_def page_inv_entries_safe_def
       | wp | intro conjI impI)+)[1]
    apply simp
    apply wp[1]
   apply (simp split:list.splits add:page_inv_entries_pre_def mapME_singleton)
   apply (wp get_master_pde_wp | wpc | simp)+
   apply (clarsimp simp:obj_at_def page_inv_entries_safe_def
     split:pde.splits)
  apply (simp split:list.splits if_splits
    add:page_inv_entries_pre_def Let_def page_inv_entries_safe_def)
  apply (elim conjE exE)
  apply (subst mapME_x_Cons)
  apply simp
  apply wp
   apply (rule_tac Q' = "\<lambda>r s. \<forall>x \<in> set x22. obj_at
       (\<lambda>ko. \<exists>pd. ko = ArchObj (PageDirectory pd) \<and>
       pd (ucast (x && mask pd_bits >> 2)) = pde.InvalidPDE)
       (hd (x21 # x22) && ~~ mask pd_bits) s" in hoare_post_imp_R)
    apply (wp mapME_x_accumulate_checks[where Q = "\<lambda>s. valid_pdpt_objs s"] )
        apply (wp get_master_pde_wp| wpc | simp)+
       apply clarsimp
       apply (frule_tac x = xa in mask_out_same_pd)
        apply (clarsimp simp:upto_enum_def upto_enum_step_def upto_0_to_n2)
        apply (erule notE)
        apply (subst shiftl_t2n[where n = 2,simplified field_simps,simplified,symmetric])
        apply (rule shiftl_less_t2n[where m = 6,simplified])
         apply (simp add:word_of_nat_less)
        apply simp
       apply (frule_tac x = z in mask_out_same_pd)
        apply (clarsimp simp:upto_enum_def upto_enum_step_def upto_0_to_n2)
       apply (clarsimp simp:field_simps obj_at_def
           split:pde.splits)
       apply (drule(1) valid_pdpt_objs_pdD)
       apply (intro conjI impI)
          apply clarsimp
          apply (frule(1) align_entry_pdD)
          apply (simp add:is_aligned_neg_mask_eq)
         apply clarsimp
         apply (frule(1) align_entry_pdD)
         apply (simp add:is_aligned_neg_mask_eq)
        apply clarsimp
        apply (frule(1) align_entry_pdD)
        apply (simp add:is_aligned_neg_mask_eq)
       apply clarsimp
       apply (erule(4) invalid_pdeI[OF _ neq_pd_offset])
      apply (wp hoare_drop_imps |wpc|simp)+
    apply (clarsimp simp:upto_enum_def upto_enum_step_def
        upto_0_to_n2 Fun.comp_def distinct_map)
   apply (intro exI conjI,fastforce+)
   apply (simp add:obj_at_def hd_map_simp
     upto_0_to_n2 upto_enum_def upto_enum_step_def)
   apply (frule_tac x = 1 in bspec,fastforce+)
  apply (wp get_master_pde_wp | simp | wpc)+
  done
qed

lemma create_mapping_entries_safe[wp]:
  "\<lbrace>\<exists>\<rhd>pd and K (vmsz_aligned vptr sz) and K (is_aligned pd pd_bits)
          and K (vptr < kernel_base)
          and valid_arch_objs and pspace_aligned and
          (\<exists>\<rhd> (lookup_pd_slot pd vptr && ~~ mask pd_bits))\<rbrace>
      create_mapping_entries ptr vptr sz rights attrib pd
   \<lbrace>\<lambda>entries. case entries of (Inl (SmallPagePTE _ _ _, [_])) \<Rightarrow> \<top>
                  | (Inl (SmallPagePTE _ _ _, _)) \<Rightarrow> \<bottom>
                  | (Inl (LargePagePTE _ _ _, [])) \<Rightarrow> \<bottom>
                  | (Inr (SectionPDE _ _ _ _, [_])) \<Rightarrow> \<top>
                  | (Inr (SectionPDE _ _ _ _, _)) \<Rightarrow> \<bottom>
                  | (Inr (SuperSectionPDE _ _ _, [])) \<Rightarrow> \<bottom>
                  | _ \<Rightarrow> page_inv_entries_pre entries\<rbrace>,-"
  apply (cases sz, simp_all)
     defer 2
     apply (wp | simp)+
   apply (simp split:list.split)
   apply (subgoal_tac "lookup_pd_slot pd vptr \<le> lookup_pd_slot pd vptr + 0x3C")
    apply (clarsimp simp:upto_enum_def not_less upto_enum_step_def
      page_inv_entries_pre_def Let_def)
    apply (clarsimp simp:upto_enum_step_def upto_enum_def
                     map_eq_Cons_conv upt_eq_Cons_conv)
    apply (drule_tac x = "lookup_pd_slot pd vptr" in spec)
    apply (subst (asm) upto_0_to_n2)
     apply simp
    apply clarsimp
    apply (drule lookup_pd_slot_aligned_6)
     apply (simp add:pd_bits_def pageBits_def)
    apply simp
   apply clarsimp
   apply (erule is_aligned_no_wrap'[OF lookup_pd_slot_aligned_6])
    apply (simp add:pd_bits pageBits_def)
   apply simp
  apply (wp get_pde_wp | simp add:lookup_pt_slot_def | wpc)+
  apply (clarsimp simp:upto_enum_def upto_enum_step_def
    page_inv_entries_pre_def Let_def )
  apply (drule_tac ref = refa in valid_arch_objsD)
    apply (simp add:obj_at_def)
   apply simp
  apply (simp)
  apply (drule_tac x = "ucast (lookup_pd_slot pd vptr && mask pd_bits >> 2)"
    in bspec)
   apply simp
   apply (erule(1) less_kernel_base_mapping_slots)
  apply (clarsimp simp:not_less[symmetric] split:list.splits)
  apply (clarsimp simp:page_inv_entries_pre_def
    Let_def upto_enum_step_def upto_enum_def)
  apply (subst (asm) upto_0_to_n2)
   apply simp
  apply (clarsimp simp:not_less[symmetric])
  apply (subgoal_tac
    "(\<exists>xa xb. pda (ucast (lookup_pd_slot pd vptr && mask pd_bits >> 2))
     = pde.PageTablePDE x xa xb)
     \<longrightarrow> is_aligned (ptrFromPAddr x + ((vptr >> 12) && 0xFF << 2)) 6")
   apply clarsimp
   apply (subgoal_tac "
     ptrFromPAddr x + ((vptr >> 12) && 0xFF << 2) \<le>
     ptrFromPAddr x + ((vptr >> 12) && 0xFF << 2) + 0x3C")
    apply (clarsimp simp:not_less[symmetric])
   apply (erule is_aligned_no_wrap')
   apply simp
  apply clarsimp
  apply (rule aligned_add_aligned)
    apply (erule(1) pt_aligned)
   apply (rule is_aligned_shiftl[OF is_aligned_andI1])
   apply (rule is_aligned_shiftr)
   apply (simp add:vmsz_aligned_def)
  apply simp
  done

lemma arch_decode_invocation_valid_pdpt[wp]:
  notes find_pd_for_asid_inv[wp del]
  shows
  "\<lbrace>invs and valid_cap (cap.ArchObjectCap cap) and valid_pdpt_objs \<rbrace>
   arch_decode_invocation label args cap_index slot cap excaps
   \<lbrace>invocation_duplicates_valid o Invocations_A.InvokeArchObject\<rbrace>,-"
  proof -
    have bitwise:"\<And>a. (ucast (((a::word32) && ~~ mask 6) && mask 14 >> 2)::12 word)
      = (ucast (a  && mask 14 >> 2)::12 word) && ~~ mask 4"
      apply (simp add:mask_def)
      apply word_bitwise
      done
    have sz:
      "\<And>vmpage_size. \<lbrakk>args ! 0 + 2 ^ pageBitsForSize vmpage_size - 1 < kernel_base;
        vmsz_aligned (args ! 0) vmpage_size\<rbrakk>
       \<Longrightarrow> args ! 0 < kernel_base"
      apply (rule le_less_trans[OF is_aligned_no_overflow])
       apply (simp add:vmsz_aligned_def)
      apply simp
      done
  show ?thesis
  apply (simp add: arch_decode_invocation_def
              Let_def split_def get_master_pde_def
              split del: if_split
                   cong: arch_cap.case_cong if_cong cap.case_cong
                         option.case_cong)
  apply (rule hoare_pre)
   apply ((wp get_pde_wp
             ensure_safe_mapping_ensures[THEN hoare_post_imp_R]
             create_mapping_entries_safe check_vp_wpR
             find_pd_for_asid_aligned_pd_bits
               [unfolded pd_bits_def pageBits_def,simplified]
             | wpc
             | simp add: invocation_duplicates_valid_def unlessE_def whenE_def
                         pti_duplicates_valid_def page_inv_duplicates_valid_def
                         mask_lower_twice pd_bits_def bitwise pageBits_def
                         not_le sz
                    del: hoare_True_E_R
                     split del: if_split
             | simp only: obj_at_def)+)
         apply (rule_tac Q'="\<lambda>rv. \<exists>\<rhd> rv and K (is_aligned rv pd_bits) and
                  (\<exists>\<rhd> (lookup_pd_slot rv (args ! 0) && ~~ mask pd_bits)) and
                     valid_arch_objs and pspace_aligned and valid_pdpt_objs"
                     and f="find_pd_for_asid p" for p
                    in hoare_post_imp_R)
          apply (wp| simp)+
         apply (fastforce simp:pd_bits_def pageBits_def)
        apply ((wp get_pde_wp
             ensure_safe_mapping_ensures[THEN hoare_post_imp_R]
             create_mapping_entries_safe check_vp_wpR
             find_pd_for_asid_aligned_pd_bits
               [unfolded pd_bits_def pageBits_def,simplified]
             | wpc
             | simp add: invocation_duplicates_valid_def unlessE_def whenE_def
                         pti_duplicates_valid_def page_inv_duplicates_valid_def
                         mask_lower_twice pd_bits_def bitwise pageBits_def
                         not_le sz
                    del: hoare_True_E_R
                     split del: if_split
             | simp only: obj_at_def)+)
         apply (rule_tac Q'="\<lambda>rv. \<exists>\<rhd> rv and K (is_aligned rv pd_bits) and
                  (\<exists>\<rhd> (lookup_pd_slot rv (snd pa) && ~~ mask pd_bits)) and
                     valid_arch_objs and pspace_aligned and valid_pdpt_objs and
                     K ((snd pa) < kernel_base)"
                     and f="find_pd_for_asid p" for p
                    in hoare_post_imp_R)
          apply (wp| simp)+
         apply (auto simp:pd_bits_def pageBits_def)[1]
        apply ((wp get_pde_wp
             ensure_safe_mapping_ensures[THEN hoare_post_imp_R]
             create_mapping_entries_safe check_vp_wpR
             find_pd_for_asid_aligned_pd_bits
               [unfolded pd_bits_def pageBits_def,simplified]
             | wpc
             | simp add: invocation_duplicates_valid_def unlessE_def whenE_def
                         pti_duplicates_valid_def page_inv_duplicates_valid_def
                         mask_lower_twice pd_bits_def bitwise pageBits_def
                         not_le sz
                    del: hoare_True_E_R
                     split del: if_split
             | simp only: obj_at_def)+)
         apply (rule hoare_post_imp_R[where P=\<top>])
          apply (rule hoare_True_E_R)
         apply auto[1]
        apply ((wp
             | wpc
             | simp add: invocation_duplicates_valid_def unlessE_def whenE_def
                         pti_duplicates_valid_def page_inv_duplicates_valid_def
                     del: hoare_True_E_R
                     split del: if_split
             | simp only: obj_at_def)+)
  apply (auto simp:valid_cap_simps)
  done
qed

lemma decode_invocation_valid_pdpt[wp]:
  "\<lbrace>invs and valid_cap cap and valid_pdpt_objs\<rbrace> decode_invocation label args cap_index slot cap excaps
   \<lbrace>invocation_duplicates_valid\<rbrace>,-"
  apply (simp add: decode_invocation_def split del: if_split)
  apply (rule hoare_pre)
   apply (wp | wpc
            | simp only: invocation_duplicates_valid_def o_def uncurry_def split_def
                         Invocations_A.invocation.simps)+
  apply clarsimp
  done

crunch valid_pdpt_objs[wp]: handle_fault, reply_from_kernel "valid_pdpt_objs"
  (simp: crunch_simps wp: crunch_wps)

lemma invocation_duplicates_valid_exst_update[simp]:
  "invocation_duplicates_valid i (trans_state f s) = invocation_duplicates_valid i s"
  apply (clarsimp simp add: invocation_duplicates_valid_def pti_duplicates_valid_def page_inv_duplicates_valid_def page_inv_entries_safe_def split: sum.splits invocation.splits arch_invocation.splits kernel_object.splits page_table_invocation.splits page_invocation.splits)+
  done

lemma set_thread_state_duplicates_valid[wp]:
  "\<lbrace>invocation_duplicates_valid i\<rbrace> set_thread_state t st \<lbrace>\<lambda>rv. invocation_duplicates_valid i\<rbrace>"
  apply (simp add: set_thread_state_def set_object_def)
  apply (wp|simp)+
  apply (clarsimp simp: invocation_duplicates_valid_def pti_duplicates_valid_def
                        page_inv_duplicates_valid_def page_inv_entries_safe_def
                        Let_def
                 dest!: get_tcb_SomeD
                 split: Invocations_A.invocation.split arch_invocation.split_asm
                        page_table_invocation.split
                        page_invocation.split sum.split
                        )
  apply (auto simp add: obj_at_def page_inv_entries_safe_def)
  done

lemma handle_invocation_valid_pdpt[wp]:
  "\<lbrace>valid_pdpt_objs and invs and ct_active\<rbrace>
        handle_invocation calling blocking \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
  apply (simp add: handle_invocation_def)
  apply (wp syscall_valid set_thread_state_ct_st
               | simp add: split_def | wpc
               | wp_once hoare_drop_imps)+
  apply (auto simp: ct_in_state_def elim: st_tcb_ex_cap)
  done

crunch valid_pdpt[wp]: handle_event, activate_thread,switch_to_thread,
       switch_to_idle_thread "valid_pdpt_objs"
  (simp: crunch_simps wp: crunch_wps alternative_valid select_wp OR_choice_weak_wp select_ext_weak_wp
      ignore: without_preemption getActiveIRQ resetTimer ackInterrupt
              getFAR getDFSR getIFSR OR_choice set_scheduler_action
              clearExMonitor)

lemma schedule_valid_pdpt[wp]: "\<lbrace>valid_pdpt_objs\<rbrace> schedule :: (unit,unit) s_monad \<lbrace>\<lambda>_. valid_pdpt_objs\<rbrace>"
  apply (simp add: schedule_def allActiveTCBs_def)
  apply (wp alternative_wp select_wp)
  apply simp
  done

lemma call_kernel_valid_pdpt[wp]:
  "\<lbrace>invs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running s) and valid_pdpt_objs\<rbrace>
      (call_kernel e) :: (unit,unit) s_monad
   \<lbrace>\<lambda>_. valid_pdpt_objs\<rbrace>"
  apply (cases e, simp_all add: call_kernel_def)
      apply (rule hoare_pre)
       apply (wp | simp | wpc
                 | rule conjI | clarsimp simp: ct_in_state_def
                 | erule pred_tcb_weakenE
                 | wp_once hoare_drop_imps)+
  done

end

end


section "Implementation Language with Loops"
theory impl_language_loops
  imports Main
    "HOL-Library.Monad_Syntax"
    repliss_sem
    ZFC_utils
    "fuzzyrule.fuzzy_goal_cases"
begin

text "We need to hide some ZFC constants so that the normal ones are still visible:"

hide_const (open) "ZFC_in_HOL.set"

text "So far, we have assumed that procedure implementations are given by arbitrary state machines.
Here we define an implementation language using a shallow embedding with the monad syntax package.
"

text_raw \<open>\DefineSnippet{io_defs_types}{\<close>
type_synonym iref = nat
type_synonym 'v store = "iref \<rightharpoonup> 'v"
text_raw \<open>}%EndSnippet\<close>

datatype 'a ref = Ref (iref:iref)
instantiation ref :: (type) small begin
instance proof
  obtain V_of :: "nat \<Rightarrow> V" and A :: "V" where "inj V_of" and "range V_of \<subseteq> elts A"
    by (metis infinite_\<omega> infinite_countable_subset)

  have "\<exists>(V_of::'a ref \<Rightarrow> V) A. inj V_of \<and> range V_of \<subseteq> elts A"
  proof (intro conjI exI)
    show "inj (V_of \<circ> iref)"
      by (metis (mono_tags, lifting) \<open>inj V_of\<close> comp_apply injD inj_on_def ref.expand)

    show " range (V_of \<circ> iref) \<subseteq> elts A"
      using \<open>range V_of \<subseteq> elts A\<close> by auto
  qed

  show "small (UNIV::'a ref set)"
    by (meson \<open>\<exists>V_of A. inj V_of \<and> range V_of \<subseteq> elts A\<close> down small_image_iff)

qed
end

text \<open>The typeclass natConvert is the dual to the typeclass countable.
A natConvert type is at least as big as the natural numbers, so any natural number can be converted
to the type using fromNat.
\<close>
class natConvert =
  fixes fromNat :: "nat \<Rightarrow> 'a"
  assumes fromNat_inj: "inj fromNat"

definition "toNat \<equiv> the_inv fromNat"

lemma "toNat (fromNat x) = x"
  by (simp add: fromNat_inj the_inv_f_f toNat_def)

instantiation ref :: (type) natConvert begin
definition [simp]: "fromNat_ref = Ref"
instance
  apply standard
  using injI by fastforce
end

datatype ('c,'b) loopResult = Continue 'c | Break 'b

text_raw \<open>\DefineSnippet{io_defs_datatype}{\<close>
datatype ('a,'op, 'any) io =
    WaitLocalStep "'any store \<Rightarrow> bool \<times> 'any store \<times> ('a,'op, 'any) io"
  | WaitBeginAtomic "('a,'op, 'any) io"
  | WaitEndAtomic "('a,'op, 'any) io"
  | WaitNewId "'any \<Rightarrow> bool" "'any \<Rightarrow> ('a,'op, 'any) io"
  | WaitDbOperation 'op "'any \<Rightarrow> ('a,'op, 'any) io"
  | WaitReturn "'a"
  | Loop 'any "V" "'any \<Rightarrow> ('a,'op, 'any) io"
text_raw \<open>}%EndSnippet\<close>

\<comment> \<open>body is an @{typ \<open>'any \<Rightarrow> (('any,'any) loopResult, 'op, 'any) io\<close>} encoded a type V.
                                            Had to use dynamic typing here as Isabelle has no GADTs. \<close>

text "Actually show that we can embedd io into ZFCs V type:"

function (domintros) io_to_V :: "('a::embeddable,'op::embeddable, 'any::small) io \<Rightarrow> V" where
  "io_to_V (WaitLocalStep n)  = to_V (0::nat, to_V (\<lambda>s. let (a,b,c) = n s in to_V (a, b, io_to_V c)))"
| "io_to_V (WaitBeginAtomic n)  =  to_V (1::nat, io_to_V n)"
| "io_to_V (WaitEndAtomic n)  = to_V (2::nat, io_to_V n) "
| "io_to_V (WaitNewId P n)  =  to_V (3::nat, to_V (P, (\<lambda>x. io_to_V (n x))))"
| "io_to_V (WaitDbOperation op n)  =  to_V (4::nat, to_V (op, (\<lambda>x. io_to_V (n x))))"
| "io_to_V (WaitReturn s)  =  to_V (5::nat, to_V s)"
| "io_to_V (Loop i body n)  =  to_V (6::nat, to_V (i, body, (\<lambda>x. io_to_V (n x))))"
  by (pat_completeness, auto)
termination
proof auto
  show "io_to_V_dom x" for x
    apply (induct x, auto simp add: io_to_V.domintros)
    by (metis io_to_V.domintros(1) range_eqI)
qed

lemma fun_cong2: "f = g \<Longrightarrow> \<forall>x. f x = g x"
  by simp

lemma io_to_V_inj: "inj io_to_V"
proof
  fix x y :: "('a::embeddable,'op::embeddable, 'any::small) io"
  assume a0: "x \<in> UNIV"
    and a1: "y \<in> UNIV"
    and a2: "io_to_V x = io_to_V y"

  from `io_to_V x = io_to_V y`
  show "x = y"
  proof (induct x arbitrary: y)
    case (WaitLocalStep a y)
    show ?case
    proof (cases y)
      fix c
      assume " y = WaitLocalStep c"
      hence h: "io_to_V (WaitLocalStep a) = io_to_V (WaitLocalStep c)"
        using WaitLocalStep.prems by blast
      from h have eq1: "fst (a x) = fst (c x)" for x
        by (auto dest!: to_V_use_inj fun_cong[where x=x] split: prod.splits)
      from h have eq2: "fst (snd (a x)) = fst (snd (c x))" for x
        by (auto dest!: to_V_use_inj fun_cong[where x=x] split: prod.splits)

      from h have "io_to_V (snd (snd (a x))) = io_to_V (snd (snd (c x)))" for x
        by (auto dest!: to_V_use_inj fun_cong[where x=x] split: prod.splits)
      have eq3: "snd (snd (a x)) = snd (snd (c x))" for x

      proof (rule WaitLocalStep)
        show "io_to_V (snd (snd (a x))) = io_to_V (snd (snd (c x)))"
          using `io_to_V (snd (snd (a x))) = io_to_V (snd (snd (c x)))` .

        show "snd (snd (a x)) \<in> Basic_BNFs.snds (snd (a x))"
          by (simp add: snds.simps)

        show "snd (a x) \<in> Basic_BNFs.snds (a x)"
          by (simp add: snds.intros)

        show " a x \<in> range a"
          by blast
      qed

      have "a = c"
        by (auto simp add: prod_eq_iff eq1 eq2 eq3)

      thus " WaitLocalStep a = y"
        using `y = WaitLocalStep c` by simp
    next
    qed (insert `io_to_V (WaitLocalStep a) = io_to_V y`, auto dest!: to_V_use_inj)
  next
    case (WaitBeginAtomic a)
     thus ?case by (cases y, auto dest!: to_V_use_inj)
  next
    case (WaitEndAtomic a)
    thus ?case by (cases y, auto dest!: to_V_use_inj)
  next
    case (WaitNewId a b)
    thus ?case
      by (cases y, auto dest!: to_V_use_inj, meson HOL.ext rangeI)
  next
    case (WaitDbOperation a b)
     thus ?case by (cases y, auto dest!: to_V_use_inj, meson HOL.ext rangeI)
  next
    case (WaitReturn r)
     thus ?case by (cases y, auto dest!: to_V_use_inj)
  next
    case (Loop i bdy cont)
    thus ?case proof (cases y, auto dest!: to_V_use_inj, rename_tac cont')
      fix cont'
      assume a0: "y = Loop i bdy cont'"
        and IH: "\<And>x3aa y. \<lbrakk>x3aa \<in> range cont; io_to_V x3aa = io_to_V y\<rbrakk> \<Longrightarrow> x3aa = y"
        and a2: "(\<lambda>x. io_to_V (cont x)) = (\<lambda>x. io_to_V (cont' x))"
        and a3: "io_to_V (Loop i bdy cont) = io_to_V y"

      from a2
      have "io_to_V (cont x) = io_to_V (cont' x)" for x
        by meson
      hence "(cont x) = (cont' x)" for x
        by (simp add: IH rangeI)
      thus "cont = cont' "
        by blast
    qed
  qed
qed

instance io :: (embeddable, embeddable, small) embeddable
  by (standard, force intro: io_to_V_inj)

definition loopResult_to_V :: "('a::embeddable, 'b::embeddable) loopResult \<Rightarrow> V" where
  "loopResult_to_V l = (case l of
    (Break x) \<Rightarrow> to_V (False, x, undefined::'a)
  | (Continue x) \<Rightarrow> to_V (True, undefined::'b, x))"

lemma loopResult_to_V_inj: "inj loopResult_to_V"
  by standard (use to_V_use_inj in \<open>auto simp add: loopResult_to_V_def  split: loopResult.splits\<close>)

instance loopResult :: (embeddable, embeddable) embeddable
  by (standard, force intro: loopResult_to_V_inj)

instance loopResult :: (small, small) small
proof (rule show_small_type_class, intro conjI exI)

  have "\<exists>(f::'a \<Rightarrow> V). inj f \<and>   small (range f)"
    using small down to_V_property to_V_small by blast

  show "inj loopResult_to_V"
    by (simp add: loopResult_to_V_inj)

  have "small (range (to_V :: (bool\<times>'b\<times>'a)\<Rightarrow>V))"
    using to_V_small by blast

  thus "small (range (loopResult_to_V::('a,'b) loopResult\<Rightarrow>V))"
  proof (rule smaller_than_small)

    show "range (loopResult_to_V::('a,'b)  loopResult\<Rightarrow>V) \<subseteq>range (to_V :: (bool\<times>'b\<times>'a)\<Rightarrow>V)"
      by (auto simp add: loopResult_to_V_def split: loopResult.splits)
  qed
qed

definition loop_body_from_V :: "V \<Rightarrow> 'any \<Rightarrow> (('any,'any) loopResult, 'op::embeddable, 'any::small) io" where
"loop_body_from_V \<equiv> from_V"

definition loop_body_to_V :: "('any \<Rightarrow> (('any,'any) loopResult, 'op::embeddable, 'any::small) io) \<Rightarrow> V" where
"loop_body_to_V \<equiv> to_V"

lemma loop_body_from_V_rev[simp]: "loop_body_from_V (loop_body_to_V x) = x"
  by (simp add: loop_body_from_V_def loop_body_to_V_def)

text_raw \<open>\DefineSnippet{io_defs_bind}{\<close>
function (*<*) (domintros) (*>*) bind (*<*) :: "('a, 'op, 'any) io \<Rightarrow> ('a \<Rightarrow> ('b, 'op,'any) io) \<Rightarrow> ('b, 'op,'any) io" (*>*) (infixl "\<bind>io" 54)  where
  "WaitLocalStep n \<bind>io f = (WaitLocalStep (\<lambda>s. let (a,b,c) = n s
                                                  in (a, b, bind c f)))"
| "WaitBeginAtomic n \<bind>io f = (WaitBeginAtomic (n \<bind>io f))"
| "WaitEndAtomic n \<bind>io f = (WaitEndAtomic (n \<bind>io f))"
| "WaitNewId P n \<bind>io f = (WaitNewId P (\<lambda>i. n i \<bind>io f))"
| "WaitDbOperation op n \<bind>io f = (WaitDbOperation op (\<lambda>i. n i \<bind>io f))"
| "WaitReturn s \<bind>io f = (f s)"
| "Loop i body n \<bind>io f = (Loop i body (\<lambda>x. n x \<bind>io f))"
text_raw \<open>}%EndSnippet\<close>
  by (pat_completeness, auto)
termination
  using [[show_sorts]]
proof auto
  show "bind_dom (i, f)" for i :: "('a, 'op, 'any) io" and f :: "'a \<Rightarrow> ('d, 'op, 'any) io"
    apply (induct i, auto simp add: bind.domintros)
    by (metis bind.domintros(1) range_eqI)
qed

text_raw \<open>\DefineSnippet{toImpl}{\<close>
fun toImpl :: "(('val store \<times> uniqueId set \<times> (('val,'op::{small,valueType}, 'val::{small,valueType}) io)), 'op, 'val) procedureImpl" where
  "toImpl (store, knownUids, WaitLocalStep n) = (
        let (ok, store', n') = n store
        in LocalStep (ok \<and> (finite (dom store) \<longrightarrow> finite (dom (store'))))
                      (store', knownUids, n'))"
| "toImpl (store, knownUids, WaitBeginAtomic n) =
        BeginAtomic (store, knownUids, n)"
| "toImpl (store, knownUids, WaitEndAtomic n) =
        EndAtomic (store, knownUids,  n)"
| "toImpl (store, knownUids, WaitNewId P n) =
        NewId (\<lambda>i. if P i then Some (store, knownUids \<union> uniqueIds i,  n i) else None)"
| "toImpl (store, knownUids, WaitDbOperation op n) = (
        if uniqueIds op \<subseteq> knownUids then
          DbOperation op (\<lambda>r. (store, knownUids \<union> uniqueIds r, n r))
        else
          LocalStep False (store, knownUids, WaitDbOperation op n))"
| "toImpl (store, knownUids, WaitReturn v) = (
        if uniqueIds v \<subseteq> knownUids then
          Return v
        else
          LocalStep False (store, knownUids, WaitReturn v))"
| "toImpl (store, knownUids, Loop i body n) =
        LocalStep True
            (store, knownUids, (loop_body_from_V body i) \<bind>io (\<lambda>r.
               case r of Break x \<Rightarrow> n x
| Continue x \<Rightarrow> Loop x body n))"
text_raw \<open>}%EndSnippet\<close>

text \<open>\DefineSnippet{toImpl_simps}{
  @{thm [display] toImpl.simps}
}%EndSnippet\<close>

abbreviation  toImpl' where
 "toImpl' proc (x :: ('val,'op,'val) io) \<equiv> ((Map.empty, uniqueIds proc, x) , toImpl)"

adhoc_overloading Monad_Syntax.bind bind

definition pause :: "(unit,'op,'any) io" where
"pause \<equiv> WaitLocalStep (\<lambda>s. (True, s, WaitReturn ()))"

definition beginAtomic :: "(unit,'op,'any) io" where
"beginAtomic \<equiv> WaitBeginAtomic (WaitReturn ())"

definition endAtomic :: "(unit,'op,'any) io" where
"endAtomic \<equiv> WaitEndAtomic (WaitReturn ())"

definition newId :: "('any \<Rightarrow> bool) \<Rightarrow> ('any,'op,'any) io" where
"newId P \<equiv> WaitNewId P (\<lambda>i. WaitReturn i)"

definition call :: "'op \<Rightarrow> ('any,'op,'any) io" where
"call op \<equiv> WaitDbOperation op (\<lambda>i. WaitReturn i)"

definition return :: "'a  \<Rightarrow> ('a,'op, 'any) io" where
"return x \<equiv> WaitReturn x"

definition atomic ::"('a,'op, 'any) io \<Rightarrow> ('a,'op, 'any) io"  where
"atomic f \<equiv> do {
  beginAtomic;
  r \<leftarrow> f;
  endAtomic;
  return r
}"

definition
"skip \<equiv> return default"

text "Next, we define some operations to work with references:
We simply encode references using natural numbers."

definition "fromAny x \<equiv> from_nat (toNat x)"
definition "intoAny x \<equiv> fromNat (to_nat x)"

lemma fromAny_intoAny[simp]: "fromAny (intoAny x) = x"
  by (simp add: fromAny_def fromNat_inj intoAny_def the_inv_f_f toNat_def)

definition freshRefH :: "nat \<Rightarrow> nat set \<Rightarrow> nat" where
"freshRefH mi D \<equiv> (if finite D then LEAST x. x \<ge> mi \<and> (\<forall>y\<in>D. x>y) else 0)"

abbreviation freshRef :: "nat set \<Rightarrow> nat" where
"freshRef \<equiv> freshRefH 0"

lemma freshRef_empty[simp]: "freshRefH x {} = x"
  by (auto simp add: freshRefH_def Least_equality)

lemma freshRef_insert[simp]:
"freshRefH mi (insert x S) = freshRefH (max mi (Suc x)) S"
  by (auto simp add: freshRefH_def intro!: arg_cong[where f=Least])

definition makeRef :: "'a::countable \<Rightarrow> ('a ref, 'op, 'any::natConvert) io" where
"makeRef v \<equiv> WaitLocalStep (\<lambda>s. let r = freshRef (dom s) in (True, s(r \<mapsto> intoAny v), WaitReturn (Ref r)))"

definition s_read :: "('any::natConvert) store \<Rightarrow> ('a::countable) ref \<Rightarrow> 'a" where
"s_read s ref \<equiv>
    case s (iref ref) of
      Some v \<Rightarrow> fromAny v
    | None  \<Rightarrow> from_nat 0"

definition read :: "'a ref \<Rightarrow> ('a::countable, 'op, 'any::natConvert) io" where
"read ref \<equiv> WaitLocalStep (\<lambda>s. case s (iref ref) of
      Some v \<Rightarrow> (True, s, WaitReturn (fromAny v))
    | None  \<Rightarrow> (False, s, WaitReturn (from_nat 0)))"

definition assign :: "('a::countable) ref \<Rightarrow> 'a \<Rightarrow> (unit, 'op, 'any::natConvert) io" (infix ":\<leftarrow>" 60) where
"assign ref v \<equiv> WaitLocalStep (\<lambda>s. case s (iref ref) of
    Some _ \<Rightarrow> (True, s((iref ref) \<mapsto> intoAny v), WaitReturn ())
  | None  \<Rightarrow> (False, s, WaitReturn ())) "

definition update :: "('a::countable) ref \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> (unit, 'op, 'any::natConvert) io" where
"update ref upd \<equiv> WaitLocalStep (\<lambda>s. case s (iref ref) of
      Some v \<Rightarrow> (True, s((iref ref) \<mapsto> intoAny (upd (fromAny v))), WaitReturn ())
    | None  \<Rightarrow> (False, s, WaitReturn ())) "

lemma toImpl_simps_newId[simp]:
"toImpl (store, u, newId P) = NewId (\<lambda>i. if P i then Some (store, u \<union> uniqueIds i, return i) else None)"
by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: ext split: io.splits)
lemma toImpl_simps_pause[simp]:
"toImpl (store, u, pause) = LocalStep True (store, u, return ())"
by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: ext split: io.splits)
lemma toImpl_simps_beginAtomic[simp]:
"toImpl (store, u, beginAtomic) = BeginAtomic (store, u, return ())"
by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: ext split: io.splits)
lemma toImpl_simps_endAtomic[simp]:
"toImpl (store, u, endAtomic) = EndAtomic (store, u, return ())"
by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: ext split: io.splits)
lemma toImpl_simps_call[simp]:
   "toImpl (store, u, call op ) = (if uniqueIds op \<subseteq> u then DbOperation op  (\<lambda>r. (store, u \<union> uniqueIds r, return r)) else LocalStep False (store, u, call op))"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: HOL.ext split: io.splits)
lemma toImpl_simps_return[simp]:
  "toImpl (store, u, return x) = (if uniqueIds x \<subseteq> u then Return x else LocalStep False (store, u, return x))"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: ext split: io.splits)

schematic_goal "toImpl (store, u, newId P \<bind> x) = ?x"
 by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

lemma toImpl_bind_simps_newid[simp]:
"toImpl (store, u, newId P \<bind> x) = NewId (\<lambda>i. if P i then Some (store, u \<union> uniqueIds i, x i) else None)"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

lemma toImpl_bind_simps_pause[simp]:
"toImpl (store, u, pause \<bind> x) = LocalStep True (store, u, x ())"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

lemma toImpl_bind_simps_beginAtomic[simp]:
"toImpl (store, u, beginAtomic \<bind> x) = BeginAtomic (store, u, x ())"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

lemma toImpl_bind_simps_endAtomic[simp]:
" toImpl (store, u, endAtomic \<bind> x) = EndAtomic (store, u, x ())"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

lemma toImpl_bind_simps_call[simp]:
"toImpl (store, u, call op  \<bind> x) = (if uniqueIds op \<subseteq> u then DbOperation op  (\<lambda>r. (store, u \<union> uniqueIds r, x r)) else LocalStep False (store, u, call op  \<bind> x))"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

paragraph "Monad Laws"

text "We prove the typical monad laws: identity of return and associativity."

declare Basic_BNFs.snds.simps[simp]
declare Basic_BNFs.fsts.simps[simp]

lemma return_left_ident[simp]:
  fixes x and f :: "'a \<Rightarrow> ('b,'op, 'any) io"
  shows "return x \<bind> f = f x"
  by (auto simp add: return_def)

lemma right_ident[simp]:
  fixes m :: "('a,'op, 'any) io"
  shows "(m \<bind> return) = m"
proof (induct m)
  case (WaitLocalStep x)
  then show ?case
    by (auto simp add: return_def intro!: HOL.ext   split: prod.splits, metis range_eqI)
next
  case (WaitBeginAtomic m)
  then show ?case  by (auto simp add: return_def)
next
  case (WaitEndAtomic m)
  then show ?case  by (auto simp add: return_def)
next
  case (WaitNewId x1a x2a)
  then show ?case  by (auto simp add: return_def)
next
  case (WaitDbOperation x1a x2a)
  then show ?case  by (auto simp add: return_def)
next
  case (WaitReturn x)
  then show ?case  by (auto simp add: return_def)
next
  case (Loop x1a m)
  then show ?case  by (auto simp add: return_def)
qed

lemma bind_assoc[simp]:
  fixes x :: "('a,'op, 'any) io"
    and y :: "'a \<Rightarrow> ('b,'op, 'any) io"
    and z :: "'b \<Rightarrow> ('c,'op, 'any) io"
  shows "((x \<bind> y) \<bind> z) = (x \<bind> (\<lambda>a. y a \<bind> z))"
proof (induct x)
  case (WaitLocalStep x)
  then show ?case
    by (auto simp add: return_def intro!: HOL.ext   split: prod.splits, metis rangeI)
next
  case (WaitBeginAtomic x)
  then show ?case  by auto
next
  case (WaitEndAtomic x)
  then show ?case  by auto
next
  case (WaitNewId x1a x2a)
  then show ?case  by auto
next
  case (WaitDbOperation x1a x2a)
  then show ?case  by auto
next
  case (WaitReturn x)
  then show ?case  by auto
next
  case (Loop x1a x)
  then show ?case  by auto
qed

 text \<open>
 \DefineSnippet{io_bind_monad_rules}{
    @{thm [display] return_left_ident}
    @{thm [display] right_ident}
    @{thm [display] bind_assoc}
 }%EndSnippet
 \<close>

lemma atomic_simp1[simp]:
"toImpl (s, u, atomic f) = BeginAtomic (s, u, f \<bind> (\<lambda>r. endAtomic \<bind> (\<lambda>_. return r)))"
  by (auto simp add: atomic_def)

lemma atomic_simp2[simp]:
"toImpl (s, u, atomic f \<bind> x) = BeginAtomic (s, u, f \<bind> (\<lambda>a. endAtomic \<bind> (\<lambda>b. x a)))"
  by (auto simp add: atomic_def)

subsection "Syntactic sugar for loops"

definition loop :: "'a::countable \<Rightarrow> ('a \<Rightarrow> (('a,'b::countable) loopResult, 'op::small, 'any::{small,natConvert} ) io) \<Rightarrow> ('b, 'op, 'any) io" where
"loop init body \<equiv> Loop
      (intoAny init)
      (loop_body_to_V (\<lambda>acc.
          body (fromAny acc) \<bind>io (\<lambda>res. return (
            case res of Continue x \<Rightarrow> (Continue (intoAny x))
                      | Break x \<Rightarrow> (Break (intoAny x))))))
      (return \<circ> fromAny)"

definition while :: "(bool, 'op::small, 'any::small) io \<Rightarrow> (unit, 'op, 'any) io" where
"while body \<equiv> Loop
      ???
      (loop_body_to_V (\<lambda>_. body \<bind>io (\<lambda>x. return ((if x then Break else Continue) ???))))
      (return \<circ> (\<lambda>_. ()))"

definition "forEach"  :: "'e::countable list \<Rightarrow> ('e \<Rightarrow> ('a::countable, 'op::small, 'any::{small,natConvert}) io) \<Rightarrow> ('a list, 'op, 'any) io" where
"forEach elements body \<equiv>
    loop (elements,[]) (\<lambda>(elems, acc).
        case elems of
        [] \<Rightarrow> return (Break (rev acc))
        | (x#xs) \<Rightarrow> body x \<bind>io (\<lambda>r. return (Continue (xs, r#acc)))
    )"

 text \<open>
 \DefineSnippet{io_language_constructs}{
    @{thm [display] beginAtomic_def}
    @{thm [display] endAtomic_def}
    @{thm [display] newId_def}
    @{thm [display] call_def}
    @{thm [display] return_def}
    @{thm [display] skip_def}
    @{thm [display] atomic_def}
 }%EndSnippet
 \<close>

 text \<open>
 \DefineSnippet{io_language_constructs_refs}{
    @{thm [display] makeRef_def}
    @{thm [display] read_def}
    @{thm [display] assign_def}
    @{thm [display] update_def}
 }%EndSnippet
 \<close>

 text \<open>
 \DefineSnippet{io_language_constructs_loops}{
    @{thm [display] loop_def}
    @{thm [display] while_def}
    @{thm [display] forEach_def}
 }%EndSnippet
 \<close>

end


(*  Title:      HOL/Statespace/StateSpaceLocale.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section {* Setup for State Space Locales \label{sec:StateSpaceLocale}*}

theory StateSpaceLocale imports StateFun
keywords "statespace" :: thy_decl
begin

ML_file "state_space.ML"
ML_file "state_fun.ML"

text {* For every type that is to be stored in a state space, an
instance of this locale is imported in order convert the abstract and
concrete values.*}

locale project_inject =
 fixes project :: "'value \<Rightarrow> 'a"
  and inject :: "'a \<Rightarrow> 'value"
 assumes project_inject_cancel [statefun_simp]: "project (inject x) = x"
begin

lemma ex_project [statefun_simp]: "\<exists>v. project v = x"
proof
  show "project (inject x) = x"
    by (rule project_inject_cancel)
qed

lemma project_inject_comp_id [statefun_simp]: "project \<circ> inject = id"
  by (rule ext) (simp add: project_inject_cancel)

lemma project_inject_comp_cancel[statefun_simp]: "f \<circ> project \<circ> inject = f"
  by (rule ext) (simp add: project_inject_cancel)

end

end


theory AbstractMultiPaxosR2Correctness
imports AbstractMultiPaxosR1 AbstractMultiPaxosR2 Simulations
begin

locale ampr2_proof = IOA + quorums quorums + ampr2_ioa quorums leader
  + r1:ampr1_ioa quorums leader
  for quorums :: "'a set set" and leader :: "bal \<Rightarrow> 'a" +
  fixes ampr2_ioa :: "(('v, 'a, 'l) ampr2_state, 'v paxos_action) ioa"
    and ampr1_ioa :: "(('v, 'a, 'l) ampr1_state, 'v paxos_action) ioa"
  defines "ampr2_ioa \<equiv> ioa" and "ampr1_ioa \<equiv> r1.ioa"
begin

definition ref_map where "ref_map s \<equiv> \<lparr>
  ampr1_state.propCmd = propCmd s,
  ampr1_state.ballot = ballot s,
  ampr1_state.vote = (\<lambda> i a . vote s $ a $ i),
  ampr1_state.suggestion = suggestion s,
  ampr1_state.onebs = onebs s,
  ampr1_state.leader = ampr2_state.leader s\<rparr>"

term "ampr1_ioa"
term "ampr2_ioa"

lemma "is_ref_map ref_map ampr2_ioa ampr1_ioa"
proof (auto simp add:is_ref_map_def simp del:split_paired_Ex)
  fix s
  assume "s \<in> ioa.start ampr2_ioa"
  thus "ref_map s \<in> ioa.start ampr1_ioa"
    by (simp add:ref_map_def ampr1.simps ampr2_ioa_def ampr1_ioa_def ioa_def start_def)
next
  fix s t a
  assume a1:"reachable ampr2_ioa s" and a2:"s \<midarrow>a\<midarrow>ampr2_ioa\<longrightarrow> t"
  let ?e = "(ref_map s, [(a, ref_map t)])"
  have "refines ?e s a t ampr1_ioa ref_map"
  proof (auto simp add:refines_def ioa_simps trace_match_def trace_def schedule_def filter_act_def)
    show "(ref_map s, a, ref_map t) \<in> ioa.trans ampr1_ioa" using a2
    apply (simp add:ampr2_ioa_def ioa_def is_trans_def trans_def)
    apply (simp add:ampr1_ioa_def ampr1.ioa_def ampr1.trans_def)
    apply (induct rule:trans_cases_2)
    apply (simp_all add:simps ampr1.simps ref_map_def)[2]
    (* join_ballot *)
    apply (induct a) apply auto[2]
    apply (auto simp add:ref_map_def ampr1.simps simps)[1]
    (* do_vote *)
    apply (induct a) apply auto[2]
    subgoal premises prems for a i v
    proof -
      have "ampr1.do_vote a i v (ref_map s) (ref_map t)" using prems
        by (auto simp add:ref_map_def simps Let_def ampr1.simps fun_eq_iff)
      thus ?thesis by auto
    qed
    (* suggest *)
    apply (induct a) apply auto[2]
    subgoal premises prems for a i b v
    proof -
      have "ampr1.suggest a i b v (ref_map s) (ref_map t)" using prems
        by (auto simp add:ref_map_def simps Let_def ampr1.simps fun_eq_iff)
      thus ?thesis by auto
    qed
    (* catch_up *)
    apply (induct a) apply auto[2]
    subgoal premises prems for l1 l2 i v
    proof -
      have "ampr1.catch_up l1 l2 i v (ref_map s) (ref_map t)" using prems
        by (auto simp add:ref_map_def simps Let_def ampr1.simps fun_eq_iff)
      thus ?thesis by auto
    qed
    (* acquire_leadership *)
    apply (induct a) apply auto[2]
    subgoal premises prems for aa q
    proof -
      have "ampr1.acquire_leadership aa q (ref_map s) (ref_map t)" using prems
        by (auto simp add:ref_map_def simps Let_def ampr1.simps fun_eq_iff)
      thus ?thesis by auto
    qed
    done
    qed
  thus "\<exists> e . refines e s a t ampr1_ioa ref_map" by blast
qed

end