(*<*)
(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Proofs
imports
  StrongTricolour
begin

(*>*)
section\<open>Top-level safety \label{sec:top-level-correctness}\<close>

subsection\<open>Invariants\<close>

definition (in gc) invsL :: "('field, 'mut, 'ref) gc_pred" where
  "invsL \<equiv>
    fM_fA_invL
  \<^bold>\<and> gc_mark.mark_object_invL
  \<^bold>\<and> gc_W_empty_invL
  \<^bold>\<and> handshake_invL
  \<^bold>\<and> obj_fields_marked_invL
  \<^bold>\<and> phase_invL
  \<^bold>\<and> sweep_loop_invL
  \<^bold>\<and> tso_lock_invL
  \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv)"

definition (in mut_m) invsL :: "('field, 'mut, 'ref) gc_pred" where
  "invsL \<equiv>
    mark_object_invL
  \<^bold>\<and> mut_get_roots.mark_object_invL m
  \<^bold>\<and> mut_store_ins.mark_object_invL m
  \<^bold>\<and> mut_store_del.mark_object_invL m
  \<^bold>\<and> handshake_invL
  \<^bold>\<and> tso_lock_invL
  \<^bold>\<and> LSTP mutator_phase_inv"

definition invs :: "('field, 'mut, 'ref) lsts_pred" where
  "invs \<equiv>
    handshake_phase_inv
  \<^bold>\<and> phase_rel_inv
  \<^bold>\<and> strong_tricolour_inv
  \<^bold>\<and> sys_phase_inv
  \<^bold>\<and> tso_writes_inv
  \<^bold>\<and> valid_refs_inv
  \<^bold>\<and> valid_W_inv"

definition I :: "('field, 'mut, 'ref) gc_pred" where
  "I \<equiv>
     gc.invsL
  \<^bold>\<and> (\<^bold>\<forall>m. mut_m.invsL m)
  \<^bold>\<and> LSTP invs"
(*<*)

lemmas I_defs = gc.invsL_def mut_m.invsL_def invs_def I_def

lemma (in gc) I:
  "\<lbrace> I \<rbrace> gc"
apply (simp add: I_defs)
apply (rule valid_pre)
apply ( rule valid_conj_lift valid_all_lift | fastforce )+
done

lemma (in sys) I:
  "\<lbrace> I \<rbrace> sys"
apply (simp add: I_defs)
apply (rule valid_pre)
apply ( rule valid_conj_lift valid_all_lift | fastforce )+
done

text\<open>

We need to separately treat the two cases of a single mutator and
multiple mutators. In the latter case we have the additional
obligation of showing mutual non-interference amongst mutators.

\<close>

lemma mut_invsL[intro]:
  "\<lbrace>I\<rbrace> mutator m \<lbrace>mut_m.invsL m'\<rbrace>"
proof(cases "m = m'")
  case True
  interpret mut_m m' by unfold_locales
  from True show ?thesis
    apply (simp add: I_defs)
    apply (rule valid_pre)
    apply ( rule valid_conj_lift valid_all_lift | fastforce )+
    done
next
  case False
  then interpret mut_m' m' m by unfold_locales blast
  from False show ?thesis
    apply (simp add: I_defs)
    apply (rule valid_pre)
    apply ( rule valid_conj_lift valid_all_lift | fastforce )+
    done
qed

lemma (in mut_m) I:
  "\<lbrace> I \<rbrace> mutator m"
apply (simp add: I_def gc.invsL_def invs_def)
apply (rule valid_pre)
apply ( rule valid_conj_lift valid_all_lift | fastforce )+
apply (simp add: I_defs)
done

(*>*)

subsection\<open>Initial conditions\<close>

text\<open>

We ask that the GC and system initially agree on some things:
\begin{itemize}

\item All objects on the heap are marked (have their flags equal to
  @{const "sys_fM"}, and there are no grey references, i.e. the heap
  is uniformly black.

\item The GC and system have the same values for @{term "fA"}, @{term
  "fM"}, etc. and the phase is @{term "Idle"}.

\item No process holds the TSO lock and all write buffers are empty.

\item All root-reachable references are backed by objects.

\end{itemize}
Note that these are merely sufficient initial conditions and can be
weakened.

\<close>

locale gc_system =
  fixes initial_mark :: gc_mark
begin

definition gc_initial_state :: "('field, 'mut, 'ref) lst_pred" where
  "gc_initial_state s \<equiv>
     fM s = initial_mark
   \<and> phase s = ph_Idle
   \<and> ghost_honorary_grey s = {}
   \<and> W s = {}"

definition mut_initial_state :: "('field, 'mut, 'ref) lst_pred" where
  "mut_initial_state s \<equiv>
     ghost_handshake_phase s = hp_IdleMarkSweep
   \<and> ghost_honorary_grey s = {}
   \<and> ghost_honorary_root s = {}
   \<and> W s = {}"

definition sys_initial_state :: "('field, 'mut, 'ref) lst_pred" where
  "sys_initial_state s \<equiv>
     (\<forall>m. \<not>handshake_pending s m \<and> ghost_handshake_in_sync s m)
   \<and> ghost_handshake_phase s = hp_IdleMarkSweep \<and> handshake_type s = ht_GetRoots
   \<and> obj_mark ` ran (heap s) \<subseteq> {initial_mark}
   \<and> fA s = initial_mark
   \<and> fM s = initial_mark
   \<and> phase s = ph_Idle
   \<and> ghost_honorary_grey s = {}
   \<and> W s = {}
   \<and> (\<forall>p. mem_write_buffers s p = [])
   \<and> mem_lock s = None"

abbreviation
  "root_reachable y \<equiv> \<^bold>\<exists>m x. \<langle>x\<rangle> \<^bold>\<in> mut_m.mut_roots m \<^bold>\<and> x reaches y"

definition valid_refs :: "('field, 'mut, 'ref) lsts_pred" where
  "valid_refs \<equiv> \<^bold>\<forall>y. root_reachable y \<^bold>\<longrightarrow> valid_ref y"

definition gc_system_init :: "('field, 'mut, 'ref) lsts_pred" where
  "gc_system_init \<equiv>
       (\<lambda>s. gc_initial_state (s gc))
     \<^bold>\<and> (\<lambda>s. \<forall>m. mut_initial_state (s (mutator m)))
     \<^bold>\<and> (\<lambda>s. sys_initial_state (s sys))
     \<^bold>\<and> valid_refs"

text\<open>

The system consists of the programs and these constraints on the initial state.

\<close>

abbreviation gc_system :: "('field, 'mut, 'ref) gc_system" where
  "gc_system \<equiv> (gc_pgms, gc_system_init)"
(*<*)

lemma init_strong_tricolour_inv:
  "\<lbrakk> obj_mark ` ran (sys_heap (mkP (s, []))\<down>) \<subseteq> {gc_fM (mkP (s, []))\<down>};
     sys_fM (mkP (s, []))\<down> = gc_fM (mkP (s, []))\<down> \<rbrakk>
     \<Longrightarrow> strong_tricolour_inv (mkP (s, []))\<down>"
by (auto simp: strong_tricolour_inv_def ran_def
        split: obj_at_splits)

lemma init_no_grey_refs:
  "\<lbrakk> gc_W (mkP (s, []))\<down> = {}; \<forall>m. W ((mkP (s, []))\<down> (mutator m)) = {}; sys_W (mkP (s, []))\<down> = {};
     gc_ghost_honorary_grey (mkP (s, []))\<down> = {}; \<forall>m. ghost_honorary_grey ((mkP (s, []))\<down> (mutator m)) = {}; sys_ghost_honorary_grey (mkP (s, []))\<down> = {} \<rbrakk>
     \<Longrightarrow> no_grey_refs (mkP (s, []))\<down>"
apply (clarsimp simp: no_grey_refs_def grey_def)
apply (rename_tac x xa)
apply (case_tac xa)
apply (auto simp: WL_def)
done

lemma valid_refs_imp_valid_refs_inv:
  "\<lbrakk> valid_refs s; no_grey_refs s; \<forall>p. sys_mem_write_buffers p s = []; \<forall>m. ghost_honorary_root (s (mutator m)) = {} \<rbrakk>
     \<Longrightarrow> valid_refs_inv s"
by (auto simp: valid_refs_def valid_refs_inv_def mut_m.reachable_def mut_m.tso_write_refs_def
         dest: no_grey_refs_not_grey_reachableD)

lemma no_grey_refs_imp_valid_W_inv:
  "\<lbrakk> no_grey_refs s; \<forall>p. sys_mem_write_buffers p s = [] \<rbrakk>
     \<Longrightarrow> valid_W_inv s"
unfolding valid_W_inv_def
by (auto simp: no_grey_refs_def grey_def WL_def)

lemma init_inv_sys: "\<forall>s\<in>initial_states gc_system. invs (mkP (s, []))\<down>"
apply (clarsimp dest!: initial_statesD
              simp: gc_system_init_def invs_def gc_initial_state_def mut_initial_state_def sys_initial_state_def
                    inv
                    handshake_phase_rel_def handshake_phase_inv_def hp_step_rel_def phase_rel_inv_def phase_rel_def
                    tso_writes_inv_def
                    init_no_grey_refs init_strong_tricolour_inv no_grey_refs_imp_valid_W_inv
                    valid_refs_imp_valid_refs_inv
                    all_conj_distrib)
done

lemma init_inv_gc: "\<forall>s\<in>initial_states gc_system. gc.invsL (mkP (s, []))"
apply (clarsimp dest!: initial_statesD)
apply (drule fun_cong[where x=gc]) (* hacky *)
apply (simp add: com)
apply (clarsimp simp: gc_system_init_def gc_initial_state_def mut_initial_state_def sys_initial_state_def
                      gc.invsL_def inv
                      gc.fM_fA_invL_def fA_rel_inv_def fA_rel_def fM_rel_inv_def fM_rel_def gc.handshake_invL_def
                      gc.obj_fields_marked_invL_def gc.phase_invL_def gc.sweep_loop_invL_def
                      gc.tso_lock_invL_def gc.gc_W_empty_invL_def
                      init_no_grey_refs
                      loc atS_simps
                      all_conj_distrib)
apply (auto simp: ran_def image_subset_iff split: obj_at_splits)
done

lemma valid_refs_imp_reachable_snapshot_inv:
  "\<lbrakk> valid_refs s; obj_mark ` ran (sys_heap s) \<subseteq> {sys_fM s}; \<forall>p. sys_mem_write_buffers p s = []; \<forall>m. ghost_honorary_root (s (mutator m)) = {} \<rbrakk>
     \<Longrightarrow> mut_m.reachable_snapshot_inv m s"
apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def valid_refs_def)
apply (auto simp: image_subset_iff ran_def black_def mut_m.reachable_def mut_m.tso_write_refs_def
           split: obj_at_splits)
done

lemma init_inv_mut: "\<forall>s\<in>initial_states gc_system. mut_m.invsL m (mkP (s, []))"
apply (clarsimp dest!: initial_statesD)
apply (drule fun_cong[where x="mutator m"]) (* hacky *)
apply (simp add: com)
apply (clarsimp simp: gc_system_init_def mut_initial_state_def sys_initial_state_def
                      valid_refs_imp_reachable_snapshot_inv
                      mut_m.invsL_def inv
                      mut_m.mark_object_invL_def
                      mut_m.handshake_invL_def mut_m.tso_lock_invL_def
                      mut_m.marked_deletions_def mut_m.marked_insertions_def
                      loc atS_simps)
done

lemma init_inv: "\<forall>s\<in>initial_states gc_system. I (mkP (s, []))"
by (simp add: I_def init_inv_sys init_inv_gc init_inv_mut)

(*>*)
text\<open>\<close>

theorem inv: "s \<in> reachable_states gc_system \<Longrightarrow> I (mkP s)"
(*<*)
apply (erule VCG)
 apply (rule init_inv)
apply (rename_tac p)
apply (case_tac p, simp_all)
  apply (rule mut_m.I[unfolded valid_proc_def, simplified])
 apply (rule gc.I[unfolded valid_proc_def, simplified])
apply (rule sys.I[unfolded valid_proc_def, simplified])
done

(*>*)
text\<open>

Our headline safety result follows directly.

\<close>

corollary safety:
  "s \<in> reachable_states gc_system \<Longrightarrow> valid_refs (mkP s)\<down>"
(*<*)
apply (drule inv)
apply (clarsimp simp: I_def invs_def valid_refs_inv_def valid_refs_def)
apply (rename_tac x xa xb)
apply (drule_tac x=x in spec)
apply clarsimp
apply (drule_tac x=xa in spec, fastforce simp: mut_m.reachable_def)
done

(*>*)
text\<open>\<close>

end

text\<open>

The GC is correct for the remaining fixed-but-arbitrary initial
conditions.

\<close>

interpretation gc_system_interpretation: gc_system undefined .

subsection\<open>A concrete system state\<close>

text\<open>

We demonstrate that our definitions are not vacuous by exhibiting a
concrete initial state that satisfies the initial conditions. We use
Isabelle's notation for types of a given size.

\<close>
(*<*)

end
(*>*)


theory Base
  imports "Separation_Logic_Imperative_HOL.Sep_Main" Named_Simpsets More_Eisbach_Tools
begin

no_notation Ref.update ("_ := _" 62)
notation Ref.update ("_ :=\<^sub>R _" 62)

abbreviation contains ("(_/ \<in>\<^sub>L _)" [51, 51] 50) where
  "contains x xs \<equiv> x \<in> set xs"

lemma ent_iff:"A = B \<longleftrightarrow> (B \<Longrightarrow>\<^sub>A A) \<and> (A \<Longrightarrow>\<^sub>A B)"
  using ent_iffI by auto

lemma htriple_frame_fwd:
  assumes R: "P \<Longrightarrow>\<^sub>A R"
  assumes F: "Ps \<Longrightarrow>\<^sub>A P*F"
  assumes I: "<R*F> c <Q>"
  shows "<Ps> c <Q>"
  using assms
  by (metis cons_rule ent_refl fr_refl)

lemma mod_starE:
  assumes "h \<Turnstile> P1 * P2"
  obtains h1 h2 where "h1 \<Turnstile> P1" "h2 \<Turnstile> P2"
  using assms mod_starD by blast

method hoare_triple_preI uses rule = rule hoare_triple_preI,
  (determ\<open>elim mod_starE rule[elim_format]\<close>)?, ((determ\<open>thin_tac "_ \<Turnstile> _"\<close>)+)?

method sep_drule uses r =
  rule ent_frame_fwd[OF r] htriple_frame_fwd[OF r], (assumption+)?, frame_inference

end


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

theory ArchUntyped_AI
imports Untyped_AI
begin

context Arch begin global_naming AARCH64

named_theorems Untyped_AI_assms

lemma of_bl_nat_to_cref[Untyped_AI_assms]:
    "\<lbrakk> x < 2 ^ bits; bits < word_bits \<rbrakk>
      \<Longrightarrow> (of_bl (nat_to_cref bits x) :: word64) = of_nat x"
  apply (clarsimp intro!: less_mask_eq
                  simp: nat_to_cref_def of_drop_to_bl
                        word_size word_less_nat_alt word_bits_def)
  by (metis add_lessD1 le_unat_uoi nat_le_iff_add nat_le_linear)

lemma cnode_cap_ex_cte[Untyped_AI_assms]:
  "\<lbrakk> is_cnode_cap cap; cte_wp_at (\<lambda>c. \<exists>m. cap = mask_cap m c) p s;
     (s::'state_ext::state_ext state) \<turnstile> cap; valid_objs s; pspace_aligned s \<rbrakk> \<Longrightarrow>
    ex_cte_cap_wp_to is_cnode_cap (obj_ref_of cap, nat_to_cref (bits_of cap) x) s"
  apply (simp only: ex_cte_cap_wp_to_def)
  apply (rule exI, erule cte_wp_at_weakenE)
  apply (clarsimp simp: is_cap_simps bits_of_def)
  apply (case_tac c, simp_all add: mask_cap_def cap_rights_update_def split:bool.splits)
  apply (clarsimp simp: nat_to_cref_def word_bits_def)
  apply (erule(2) valid_CNodeCapE)
  apply (simp add: word_bits_def cte_level_bits_def)
  done

lemma inj_on_nat_to_cref[Untyped_AI_assms]:
  "bits < word_bits \<Longrightarrow> inj_on (nat_to_cref bits) {..< 2 ^ bits}"
  apply (rule inj_onI)
  apply (drule arg_cong[where f="\<lambda>x. replicate (64 - bits) False @ x"])
  apply (subst(asm) word_bl.Abs_inject[where 'a=64, symmetric])
    apply (simp add: nat_to_cref_def word_bits_def)
   apply (simp add: nat_to_cref_def word_bits_def)
  apply (simp add: of_bl_rep_False of_bl_nat_to_cref)
  apply (erule word_unat.Abs_eqD)
   apply (simp only: unats_def mem_simps)
   apply (erule order_less_le_trans)
   apply (rule power_increasing, (simp add: word_bits_def) +)
  apply (simp only: unats_def mem_simps)
  apply (erule order_less_le_trans)
  apply (rule power_increasing, simp+)
  done

lemma data_to_obj_type_sp[Untyped_AI_assms]:
  "\<lbrace>P\<rbrace> data_to_obj_type x \<lbrace>\<lambda>ts (s::'state_ext::state_ext state). ts \<noteq> ArchObject ASIDPoolObj \<and> P s\<rbrace>, -"
  unfolding data_to_obj_type_def
  apply (rule hoare_pre)
   apply (wp|wpc)+
  apply clarsimp
  apply (simp add: arch_data_to_obj_type_def split: if_split_asm)
  done

lemma dui_inv_wf[wp, Untyped_AI_assms]:
  "\<lbrace>invs and cte_wp_at ((=) (cap.UntypedCap dev w sz idx)) slot
     and (\<lambda>s. \<forall>cap \<in> set cs. is_cnode_cap cap
                      \<longrightarrow> (\<forall>r\<in>cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s))
    and (\<lambda>s. \<forall>x \<in> set cs. s \<turnstile> x)\<rbrace>
     decode_untyped_invocation label args slot (cap.UntypedCap dev w sz idx) cs
   \<lbrace>valid_untyped_inv\<rbrace>,-"
proof -
  have inj: "\<And>node_cap s. \<lbrakk>is_cnode_cap node_cap;
    unat (args ! 5) \<le> 2 ^ bits_of node_cap - unat (args ! 4);valid_cap node_cap s\<rbrakk> \<Longrightarrow>
    inj_on (Pair (obj_ref_of node_cap) \<circ> nat_to_cref (bits_of node_cap))
                      {unat (args ! 4)..<unat (args ! 4) + unat (args ! 5)}"
    apply (simp add: comp_def)
    apply (rule inj_on_split)
    apply (rule subset_inj_on [OF inj_on_nat_to_cref])
     apply (clarsimp simp: is_cap_simps bits_of_def valid_cap_def
                           word_bits_def cap_aligned_def)
    apply clarsimp
    apply (rule less_le_trans)
     apply assumption
    apply (simp add:le_diff_conv2)
    done
  have nasty_strengthen:
    "\<And>S a f s. (\<forall>x\<in>S. cte_wp_at ((=) cap.NullCap) (a, f x) s)
    \<Longrightarrow> cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) slot s
    \<longrightarrow> slot \<notin> (Pair a \<circ> f) ` S"
    by (auto simp:cte_wp_at_caps_of_state)
  show ?thesis
    apply (simp add: decode_untyped_invocation_def unlessE_def[symmetric]
                     unlessE_whenE
          split del: if_split)
    apply (rule validE_R_sp[OF whenE_throwError_sp]
                validE_R_sp[OF data_to_obj_type_sp]
                validE_R_sp[OF dui_sp_helper] validE_R_sp[OF map_ensure_empty])+
     apply clarsimp
    apply (rule hoare_pre)
     apply (wp whenE_throwError_wp[THEN validE_validE_R] check_children_wp
               map_ensure_empty_wp)
    apply (clarsimp simp: distinct_map cases_imp_eq)
    apply (subgoal_tac "s \<turnstile> node_cap")
     prefer 2
     apply (erule disjE)
      apply (drule bspec [where x = "cs ! 0"],clarsimp)+
      apply fastforce
     apply clarsimp
     apply (clarsimp simp: cte_wp_at_caps_of_state)
     apply (drule(1) caps_of_state_valid[rotated])+
     apply assumption
    apply (subgoal_tac "\<forall>r\<in>cte_refs node_cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s")
     apply (clarsimp simp: cte_wp_at_caps_of_state)
     apply (frule(1) caps_of_state_valid[rotated])
     apply (clarsimp simp: not_less)
     apply (frule(2) inj)
     apply (clarsimp simp: comp_def)
     apply (frule(1) caps_of_state_valid)
     apply (simp add: nasty_strengthen[unfolded o_def] cte_wp_at_caps_of_state)
     apply (intro conjI)
      apply (intro impI)
      apply (frule range_cover_stuff[where w=w and rv = 0 and sz = sz], simp_all)[1]
        apply (clarsimp simp: valid_cap_simps cap_aligned_def)+
      apply (frule alignUp_idem[OF is_aligned_weaken,where a = w])
        apply (erule range_cover.sz)
       apply (simp add: range_cover_def)
      apply (clarsimp simp: get_free_ref_def empty_descendants_range_in)
      apply (rule conjI[rotated], blast, clarsimp)
      apply (drule_tac x = "(obj_ref_of node_cap, nat_to_cref (bits_of node_cap) slota)" in bspec)
       apply (clarsimp simp: is_cap_simps nat_to_cref_def word_bits_def bits_of_def valid_cap_simps
                             cap_aligned_def)+
     apply (simp add: free_index_of_def)
     apply (frule(1) range_cover_stuff[where sz = sz])
        apply (clarsimp dest!: valid_cap_aligned simp: cap_aligned_def word_bits_def)+
      apply simp+
     apply (clarsimp simp: get_free_ref_def)
    apply (erule disjE)
     apply (drule_tac x= "cs!0" in bspec, clarsimp)
     apply simp
    apply (clarsimp simp: cte_wp_at_caps_of_state ex_cte_cap_wp_to_def)
    apply (rule_tac x=aa in exI, rule exI, rule exI)
    apply simp
    done
qed

lemma asid_bits_ge_0:
  "(0::word32) < 2 ^ asid_bits" by (simp add: asid_bits_def)

lemma retype_ret_valid_caps_captable[Untyped_AI_assms]:
  "\<lbrakk>pspace_no_overlap_range_cover ptr sz (s::'state_ext::state_ext state) \<and> 0 < us
      \<and> range_cover ptr sz (obj_bits_api CapTableObject us) n \<and> ptr \<noteq> 0
       \<rbrakk>
         \<Longrightarrow> \<forall>y\<in>{0..<n}. s
                \<lparr>kheap := foldr (\<lambda>p kh. kh(p \<mapsto> default_object CapTableObject dev us)) (map (\<lambda>p. ptr_add ptr (p * 2 ^ obj_bits_api CapTableObject us)) [0..<n])
                           (kheap s)\<rparr> \<turnstile> CNodeCap (ptr_add ptr (y * 2 ^ obj_bits_api CapTableObject us)) us []"
by ((clarsimp simp:valid_cap_def default_object_def cap_aligned_def
        cte_level_bits_def is_obj_defs well_formed_cnode_n_def empty_cnode_def
        dom_def arch_default_cap_def ptr_add_def | rule conjI | intro conjI obj_at_foldr_intro imageI
      | rule is_aligned_add_multI[OF _ le_refl],
        (simp add:range_cover_def word_bits_def obj_bits_api_def slot_bits_def)+)+)[1]

lemma retype_ret_valid_caps_aobj[Untyped_AI_assms]:
  "\<And>ptr sz (s::'state_ext::state_ext state) x6 us n.
  \<lbrakk>pspace_no_overlap_range_cover ptr sz s \<and> x6 \<noteq> ASIDPoolObj \<and>
  range_cover ptr sz (obj_bits_api (ArchObject x6) us) n \<and> ptr \<noteq> 0\<rbrakk>
            \<Longrightarrow> \<forall>y\<in>{0..<n}. s
                   \<lparr>kheap := foldr (\<lambda>p kh. kh(p \<mapsto> default_object (ArchObject x6) dev us)) (map (\<lambda>p. ptr_add ptr (p * 2 ^ obj_bits_api (ArchObject x6) us)) [0..<n])
                              (kheap s)\<rparr> \<turnstile> ArchObjectCap (arch_default_cap x6 (ptr_add ptr (y * 2 ^ obj_bits_api (ArchObject x6) us)) us dev)"
  apply (rename_tac aobject_type us n)
  apply (case_tac aobject_type)
  by (clarsimp simp: valid_cap_def default_object_def cap_aligned_def
                     cte_level_bits_def is_obj_defs well_formed_cnode_n_def empty_cnode_def
                     dom_def arch_default_cap_def ptr_add_def
      | intro conjI obj_at_foldr_intro
        imageI valid_vm_rights_def
      | rule is_aligned_add_multI[OF _ le_refl]
      | fastforce simp:range_cover_def obj_bits_api_def
        default_arch_object_def valid_vm_rights_def  word_bits_def a_type_def)+

lemma cap_refs_in_kernel_windowD2:
  "\<lbrakk> cte_wp_at P p (s::'state_ext::state_ext state); cap_refs_in_kernel_window s \<rbrakk>
       \<Longrightarrow> \<exists>cap. P cap \<and> region_in_kernel_window (cap_range cap) s"
  apply (clarsimp simp: cte_wp_at_caps_of_state region_in_kernel_window_def)
  apply (drule(1) cap_refs_in_kernel_windowD)
  apply fastforce
  done

lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]:
  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace>
   init_arch_objects ty ptr n us y
   \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
  unfolding init_arch_objects_def by wp

lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]:
  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
   init_arch_objects ty ptr n us y
   \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
  unfolding init_arch_objects_def by wp

lemma set_untyped_cap_invs_simple[Untyped_AI_assms]:
  "\<lbrace>\<lambda>s. descendants_range_in {ptr .. ptr+2^sz - 1} cref s \<and> pspace_no_overlap_range_cover ptr sz s \<and> invs s
  \<and> cte_wp_at (\<lambda>c. is_untyped_cap c \<and> cap_bits c = sz \<and> obj_ref_of c = ptr \<and> cap_is_device c = dev) cref s \<and> idx \<le> 2^ sz\<rbrace>
  set_cap (cap.UntypedCap dev ptr sz idx) cref
 \<lbrace>\<lambda>rv s. invs s\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: cte_wp_at_caps_of_state invs_def valid_state_def)
  apply (rule hoare_pre)
  apply (wp set_free_index_valid_pspace_simple set_cap_valid_mdb_simple
    set_cap_idle update_cap_ifunsafe)
  apply (simp add:valid_irq_node_def)
  apply wps
  apply (wp hoare_vcg_all_lift set_cap_irq_handlers set_cap_valid_arch_caps
    set_cap_irq_handlers cap_table_at_lift_valid set_cap_typ_at
    set_untyped_cap_refs_respects_device_simple)
  apply (clarsimp simp:cte_wp_at_caps_of_state is_cap_simps)
  apply (intro conjI,clarsimp)
        apply (rule ext,clarsimp simp:is_cap_simps)
       apply (clarsimp split:cap.splits simp:is_cap_simps appropriate_cte_cap_def)
      apply (drule(1) if_unsafe_then_capD[OF caps_of_state_cteD])
       apply clarsimp
      apply (clarsimp simp:is_cap_simps ex_cte_cap_wp_to_def appropriate_cte_cap_def cte_wp_at_caps_of_state)
     apply (clarsimp dest!:valid_global_refsD2 simp:cap_range_def)
    apply (simp add:valid_irq_node_def)
   apply (clarsimp simp:valid_irq_node_def)
  apply (clarsimp simp:no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state vs_cap_ref_def)
  apply (case_tac cap)
   apply (simp_all add:vs_cap_ref_def table_cap_ref_def)
  apply (rename_tac arch_cap)
  apply (case_tac arch_cap)
   apply simp_all
  apply (clarsimp simp:cap_refs_in_kernel_window_def
              valid_refs_def simp del:split_paired_All)
  apply (drule_tac x = cref in spec)
  apply (clarsimp simp:cte_wp_at_caps_of_state)
  apply (fastforce simp: not_kernel_window_def)
  done

lemmas pbfs_less_wb' = pageBitsForSize_bounded

lemma delete_objects_rewrite[Untyped_AI_assms]:
  "\<lbrakk> word_size_bits \<le> sz; sz\<le> word_bits;ptr && ~~ mask sz = ptr\<rbrakk> \<Longrightarrow> delete_objects ptr sz =
    do y \<leftarrow> modify (clear_um {ptr + of_nat k |k. k < 2 ^ sz});
    modify (detype {ptr && ~~ mask sz..ptr + 2 ^ sz - 1})
    od"
  apply (clarsimp simp:delete_objects_def freeMemory_def word_size_def word_size_bits_def)
  apply (subgoal_tac "is_aligned (ptr &&~~ mask sz) sz")
  apply (subst mapM_storeWord_clear_um[simplified word_size_def word_size_bits_def])
  apply (simp)
  apply simp
  apply (simp add:range_cover_def)
  apply clarsimp
  apply (rule is_aligned_neg_mask)
  apply simp
  done

declare store_pte_pred_tcb_at [wp]

definition nonempty_table :: "obj_ref set \<Rightarrow> kernel_object \<Rightarrow> bool" where
 "nonempty_table S ko \<equiv> \<exists>pt_t. a_type ko = AArch (APageTable pt_t) \<and> ko \<noteq> ArchObj (PageTable (empty_pt pt_t))"

lemma reachable_target_trans[simp]:
  "reachable_target ref p (trans_state f s) = reachable_target ref p s"
  by (simp add: reachable_target_def split: prod.split)

lemma reachable_pg_cap_exst_update[simp]:
  "reachable_frame_cap x (trans_state f (s::'state_ext::state_ext state)) = reachable_frame_cap x s"
  by (simp add: reachable_frame_cap_def obj_at_def)

lemma create_cap_valid_arch_caps[wp, Untyped_AI_assms]:
  "\<lbrace>valid_arch_caps
      and valid_cap (default_cap tp oref sz dev)
      and (\<lambda>(s::'state_ext::state_ext state). \<forall>r\<in>obj_refs (default_cap tp oref sz dev).
                (\<forall>p'. \<not> cte_wp_at (\<lambda>cap. r \<in> obj_refs cap) p' s)
              \<and> \<not> obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
      and cte_wp_at ((=) cap.NullCap) cref
      and K (tp \<noteq> ArchObject ASIDPoolObj)\<rbrace>
     create_cap tp sz p dev (cref, oref) \<lbrace>\<lambda>rv. valid_arch_caps\<rbrace>"
  apply (simp add: create_cap_def set_cdt_def)
  apply (wp set_cap_valid_arch_caps)
  apply (simp add: trans_state_update[symmetric] del: trans_state_update)
  apply (wp hoare_vcg_disj_lift hoare_vcg_conj_lift hoare_vcg_all_lift hoare_vcg_imp_lift | simp)+

  apply (clarsimp simp del: split_paired_All split_paired_Ex
                            imp_disjL
                      simp: cte_wp_at_caps_of_state)
  apply (rule conjI)
   apply (clarsimp simp: no_cap_to_obj_with_diff_ref_def
                         cte_wp_at_caps_of_state)
   apply (case_tac "\<exists>x. x \<in> obj_refs cap")
    apply (clarsimp dest!: obj_ref_elemD)
    apply (case_tac cref, fastforce)
   apply (simp add: obj_ref_none_no_asid)
  apply (rule conjI)
   apply (auto simp: is_cap_simps valid_cap_def second_level_tables_def
                     obj_at_def nonempty_table_def a_type_simps in_omonad)[1]
  apply (clarsimp simp del: imp_disjL)
  apply (case_tac "\<exists>x. x \<in> obj_refs cap")
   apply (clarsimp dest!: obj_ref_elemD)
   apply fastforce
  apply (auto simp: is_cap_simps)[1]
  done

lemma create_cap_cap_refs_in_kernel_window[wp, Untyped_AI_assms]:
  "\<lbrace>cap_refs_in_kernel_window and cte_wp_at (\<lambda>c. cap_range (default_cap tp oref sz dev) \<subseteq> cap_range c) p\<rbrace>
     create_cap tp sz p dev (cref, oref) \<lbrace>\<lambda>rv. cap_refs_in_kernel_window\<rbrace>"
  apply (simp add: create_cap_def)
  apply (wp | simp)+
  apply (clarsimp simp: cte_wp_at_caps_of_state)
  apply (drule(1) cap_refs_in_kernel_windowD)
  apply blast
  done

lemma create_cap_ioports[wp, Untyped_AI_assms]:
  "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
  by wpsimp

lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
  "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
         \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
    K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
        init_arch_objects tp ptr bits us refs
   \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
  unfolding init_arch_objects_def by wpsimp

lemma nonempty_table_caps_of[Untyped_AI_assms]:
  "nonempty_table S ko \<Longrightarrow> caps_of ko = {}"
  by (auto simp: caps_of_def cap_of_def nonempty_table_def a_type_def
          split: Structures_A.kernel_object.split if_split_asm)

lemma nonempty_default[simp, Untyped_AI_assms]:
  "tp \<noteq> Untyped \<Longrightarrow> \<not> nonempty_table S (default_object tp dev us)"
  apply (case_tac tp, simp_all add: default_object_def nonempty_table_def a_type_def)
  apply (rename_tac aobject_type)
  apply (case_tac aobject_type; simp add: default_arch_object_def empty_pt_def)
  done

crunch cte_wp_at_iin[wp]: init_arch_objects "\<lambda>s. P (cte_wp_at (P' (interrupt_irq_node s)) p s)"

lemmas init_arch_objects_ex_cte_cap_wp_to = init_arch_objects_excap

lemma obj_is_device_vui_eq[Untyped_AI_assms]:
  "valid_untyped_inv ui s
      \<Longrightarrow> case ui of Retype slot reset ptr_base ptr tp us slots dev
          \<Rightarrow> obj_is_device tp dev = dev"
  apply (cases ui, clarsimp)
  apply (clarsimp simp: obj_is_device_def
                 split: apiobject_type.split)
  apply (intro impI conjI allI, simp_all add: is_frame_type_def default_object_def)
  apply (simp add: default_arch_object_def split: aobject_type.split)
  apply (auto simp: arch_is_frame_type_def)
  done

end

global_interpretation Untyped_AI? : Untyped_AI
  where nonempty_table = AARCH64.nonempty_table
  proof goal_cases
    interpret Arch .
    case 1 show ?case
    by (unfold_locales; (fact Untyped_AI_assms)?)
  qed

end