(*
 * 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 Detype_C
imports "../../lib/clib/Ctac" TcbQueue_C
begin

lemma typ_clear_region_out:
  "x \<notin> {p..+2 ^ bits} \<Longrightarrow> typ_clear_region p bits d x = d x"
  unfolding typ_clear_region_def
  by simp

lemma typ_bytes_region_out:
  "x \<notin> {p..+2 ^ bits} \<Longrightarrow> typ_region_bytes p bits d x = d x"
  unfolding typ_region_bytes_def
  by simp

lemma h_t_valid_ptr_clear_region:
  fixes p :: "'a :: c_type ptr"
  shows "typ_clear_region ptr bits hp,g \<Turnstile>\<^sub>t p =
   ({ptr_val p ..+ size_of (TYPE ('a))} \<inter> {ptr ..+ 2 ^ bits} = {} \<and> hp,g \<Turnstile>\<^sub>t p)"
  unfolding h_t_valid_def
  apply (clarsimp simp: valid_footprint_def Let_def)
  apply (rule iffI)
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: disjoint_iff_not_equal)
    apply (drule intvlD)
    apply (clarsimp simp: size_of_def)
    apply (drule spec, drule (1) mp)
    apply (clarsimp simp: typ_clear_region_def)
   apply clarsimp
   apply (drule spec, drule (1) mp)
   apply (clarsimp simp: typ_clear_region_def split: if_split_asm)
  apply clarsimp
  apply (drule spec, drule (1) mp)
  apply (subgoal_tac "ptr_val p + of_nat y \<notin> {ptr..+2 ^ bits}")
  apply (simp add: typ_clear_region_out)
  apply clarsimp
  apply (drule intvlD)
  apply (clarsimp simp: disjoint_iff_not_equal )
  apply (drule_tac x = "ptr_val p + of_nat y" in bspec)
   apply (rule intvlI)
   apply (simp add: size_of_def)
  apply (drule_tac x = "ptr + of_nat k" in bspec)
   apply (erule intvlI)
  apply simp
  done

lemma map_of_le:
  "map_le (map_of xs) m \<Longrightarrow> distinct (map fst xs) \<Longrightarrow> \<forall>(x, v) \<in> set xs. m x = Some v"
  apply (induct xs)
   apply simp
  apply clarsimp
  apply (clarsimp simp: map_le_def dom_map_of_conv_image_fst)
  apply (drule(1) bspec, simp)
  apply (simp(no_asm_use) split: if_split_asm)
   apply (fastforce simp: image_def)
  apply simp
  done

lemma list_map_le_singleton:
  "map_le (list_map xs) [n \<mapsto> x]
    = (xs = [] \<or> n = 0 \<and> xs = [x])"
  apply (simp add: list_map_def)
  apply (rule iffI)
   apply (drule map_of_le)
    apply simp
   apply (cases xs, simp_all add: list_map_def upt_conv_Cons
                       split: if_split_asm del: upt.simps)
   apply (case_tac list, simp_all add: upt_conv_Cons del: upt.simps)
  apply auto
  done

lemma neq_types_not_typ_slice_eq:
  "\<lbrakk> s \<noteq> t \<rbrakk> \<Longrightarrow> typ_slice_t s k \<noteq> [(t, v)]"
  using ladder_set_self[where s=s and n=k]
  by clarsimp

lemma valid_footprint_typ_region_bytes:
  assumes neq_byte: "td \<noteq> typ_uinfo_t TYPE (word8)"
  shows "valid_footprint (typ_region_bytes ptr bits hp) p td =
   ({p ..+ size_td td} \<inter> {ptr ..+ 2 ^ bits} = {} \<and> valid_footprint hp p td)"
  apply (clarsimp simp: valid_footprint_def Let_def)
  apply (rule iffI)
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: disjoint_iff_not_equal)
    apply (drule intvlD)
    apply (clarsimp simp: size_of_def)
    apply (drule spec, drule (1) mp)
    apply (clarsimp simp: typ_region_bytes_def list_map_le_singleton neq_byte
                          neq_types_not_typ_slice_eq)
   apply clarsimp
   apply (drule spec, drule (1) mp)
   apply (clarsimp simp: typ_region_bytes_def list_map_le_singleton neq_byte
                         neq_types_not_typ_slice_eq
                  split: if_split_asm)
  apply clarsimp
  apply (drule spec, drule (1) mp)
  apply (subgoal_tac "p + of_nat y \<notin> {ptr..+2 ^ bits}")
  apply (simp add: typ_bytes_region_out)
  apply clarsimp
  apply (drule intvlD)
  apply (clarsimp simp: disjoint_iff_not_equal )
  apply (drule_tac x = "p + of_nat y" in bspec)
   apply (rule intvlI)
   apply (simp add: size_of_def)
  apply (drule_tac x = "ptr + of_nat k" in bspec)
   apply (erule intvlI)
  apply simp
  done

lemma h_t_valid_typ_region_bytes:
  fixes p :: "'a :: c_type ptr"
  assumes neq_byte: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE (word8)"
  shows "typ_region_bytes ptr bits hp,g \<Turnstile>\<^sub>t p =
   ({ptr_val p ..+ size_of (TYPE ('a))} \<inter> {ptr ..+ 2 ^ bits} = {} \<and> hp,g \<Turnstile>\<^sub>t p)"
  unfolding h_t_valid_def
  by (simp add: valid_footprint_typ_region_bytes[OF neq_byte]
                size_of_def)

lemma proj_d_lift_state_hrs_htd_update [simp]:
  "proj_d (lift_state (hrs_htd_update f hp)) = f (hrs_htd hp)"
  by (cases hp) (simp add: hrs_htd_update_def proj_d_lift_state hrs_htd_def)

lemma proj_d_lift_state_hrs_htd [simp]:
  "proj_d (lift_state hp), g \<Turnstile>\<^sub>t x = hrs_htd hp, g \<Turnstile>\<^sub>t x"
  apply (cases hp)
  apply (simp add: proj_d_lift_state hrs_htd_def)
  done

lemma heap_list_s_heap_list':
  fixes p :: "'a :: c_type ptr"
  shows "hrs_htd hp,\<top> \<Turnstile>\<^sub>t p \<Longrightarrow>
  heap_list_s (lift_state hp) (size_of TYPE('a)) (ptr_val p) =
  heap_list (hrs_mem hp) (size_of TYPE('a)) (ptr_val p)"
  apply (cases hp)
  apply (simp add: hrs_htd_def hrs_mem_def heap_list_s_heap_list)
  done

lemma lift_t_typ_clear_region:
  assumes doms: "\<And>x :: 'a :: mem_type ptr. \<lbrakk> hrs_htd hp,g \<Turnstile>\<^sub>t x; x \<in> - (Ptr ` {ptr ..+2 ^ bits}) \<rbrakk>
  \<Longrightarrow> {ptr_val x..+size_of TYPE('a)} \<inter> {ptr..+2 ^ bits} = {}"
  shows "(lift_t g (hrs_htd_update (typ_clear_region ptr bits) hp) :: 'a :: mem_type typ_heap) =
          lift_t g hp |` (- Ptr ` {ptr ..+2 ^ bits})"
  apply (rule ext)
  apply (case_tac "({ptr_val x..+size_of TYPE('a)} \<inter> {ptr..+2 ^ bits} = {} \<and> hrs_htd hp,g \<Turnstile>\<^sub>t x)")
  apply (clarsimp simp add: lift_t_def lift_typ_heap_if s_valid_def h_t_valid_ptr_clear_region)
   apply (subgoal_tac "x \<in> - Ptr ` {ptr..+2 ^ bits}")
   apply clarsimp
    apply (subst heap_list_s_heap_list')
     apply (clarsimp simp add: hrs_htd_update h_t_valid_ptr_clear_region)
     apply (erule h_t_valid_taut)
    apply (subst heap_list_s_heap_list')
     apply (clarsimp elim!:  h_t_valid_taut)
    apply simp
   apply clarsimp
   apply (drule (1) orthD2)
   apply (erule contrapos_np, rule intvl_self)
   apply (simp add: size_of_def wf_size_desc_gt)
  apply (simp add: lift_t_def lift_typ_heap_if s_valid_def h_t_valid_ptr_clear_region  del: disj_not1 split del: if_split)
  apply (subst if_not_P)
   apply simp
   apply (case_tac "x \<in> (- Ptr ` {ptr..+2 ^ bits})")
   apply (simp del: disj_not1)
   apply (erule contrapos_pn)
   apply simp
   apply (erule doms)
   apply simp
  apply simp
  done

lemma image_Ptr:
  "Ptr ` S = {x. ptr_val x \<in> S}"
  apply (safe, simp_all)
  apply (case_tac x, simp_all)
  done

lemma lift_t_typ_region_bytes:
  assumes doms: "\<And>x :: 'a :: mem_type ptr. \<lbrakk> hrs_htd hp,g \<Turnstile>\<^sub>t x; x \<in> - (Ptr ` {ptr ..+2 ^ bits}) \<rbrakk>
  \<Longrightarrow> {ptr_val x..+size_of TYPE('a)} \<inter> {ptr..+2 ^ bits} = {}"
  assumes neq_byte: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE (word8)"
  shows "(lift_t g (hrs_htd_update (typ_region_bytes ptr bits) hp) :: 'a :: mem_type typ_heap) =
          lift_t g hp |` (- Ptr ` {ptr ..+2 ^ bits})"
  apply (rule ext)
  apply (case_tac "({ptr_val x..+size_of TYPE('a)} \<inter> {ptr..+2 ^ bits} = {} \<and> hrs_htd hp,g \<Turnstile>\<^sub>t x)")
   apply (clarsimp simp add: lift_t_def lift_typ_heap_if s_valid_def
                             h_t_valid_typ_region_bytes neq_byte)
   apply (subgoal_tac "x \<in> - Ptr ` {ptr..+2 ^ bits}")
    apply clarsimp
    apply (subst heap_list_s_heap_list')
     apply (clarsimp simp add: hrs_htd_update h_t_valid_typ_region_bytes neq_byte)
     apply (erule h_t_valid_taut)
    apply (subst heap_list_s_heap_list')
     apply (clarsimp elim!:  h_t_valid_taut)
    apply simp
   apply (simp add: image_Ptr)
   apply (cut_tac p=x in mem_type_self)
   apply blast
  apply (simp add: lift_t_def lift_typ_heap_if s_valid_def neq_byte
                   h_t_valid_typ_region_bytes  del: disj_not1 split del: if_split)
  apply (clarsimp simp add: restrict_map_def)
  apply (blast dest: doms)
  done

context kernel
begin

lemma cmap_relation_h_t_valid:
  fixes p :: "'a :: c_type ptr"
  shows "\<lbrakk>cmap_relation am (cslift s' :: 'a typ_heap) f rel; s' \<Turnstile>\<^sub>c p;
  \<And>v v' x. \<lbrakk>f x = p; am x = Some v; cslift s' p = Some v'; rel v v'\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding cmap_relation_def
  apply (clarsimp simp: h_t_valid_clift_Some_iff)
  apply (drule equalityD2)
  apply (drule (1) subsetD [OF _ domI])
  apply clarsimp
  apply (drule (1) bspec [OF _ domI])
  apply clarsimp
  done

lemma valid_untyped_capE:
  assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and rl: "\<lbrakk>is_aligned ptr bits; valid_untyped' d ptr bits idx s; ptr \<noteq> 0; bits < word_bits \<rbrakk> \<Longrightarrow> P"
  shows P
proof (rule rl)
  from vuc show al: "is_aligned ptr bits" and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    unfolding valid_cap'_def capAligned_def by auto

  from al p0 show wb: "bits < word_bits"
    by (clarsimp elim!: is_aligned_get_word_bits[where 'a=32, folded word_bits_def])
qed
(*FIX me: move *)

lemma valid_untyped_pspace_no_overlap':
 assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and    idx: "idx< 2^ bits"
  and psp_al: "pspace_aligned' s" "pspace_distinct' s"
  shows  "pspace_no_overlap' (ptr + of_nat idx) bits s"

proof -
  note blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex

  from vuc have al: "is_aligned ptr bits" and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    and wb: "bits < word_bits"
    by (auto elim!: valid_untyped_capE)

  from vuc idx
   have [simp]: "(ptr + (of_nat idx) && ~~ mask bits) = ptr"
    apply -
    apply (rule is_aligned_add_helper[THEN conjunct2])
     apply (clarsimp simp:valid_cap'_def capAligned_def)+
    apply (rule word_of_nat_less)
    apply simp
    done

  show "pspace_no_overlap' (ptr + of_nat idx) bits s"
    using vuc idx psp_al
    apply -
    apply (clarsimp simp:valid_cap'_def valid_untyped'_def pspace_no_overlap'_def)
    apply (drule_tac x = x in spec)
    apply (frule(1) pspace_alignedD')
    apply (frule(1) pspace_distinctD')
    apply (clarsimp simp:ko_wp_at'_def obj_range'_def p_assoc_help)
    done
  qed

lemma cmap_relation_disjoint:
  fixes  rel :: "'a :: pspace_storable \<Rightarrow> 'b :: mem_type \<Rightarrow> bool" and x :: "'b :: mem_type ptr"
  assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and   invs: "invs' s"
  and     cm: "cmap_relation (proj \<circ>\<^sub>m (ksPSpace s)) (cslift s') Ptr rel"
  and     ht: "s' \<Turnstile>\<^sub>c x"
  and     tp: "\<And>ko v. proj ko = Some v \<Longrightarrow> koType TYPE('a) = koTypeOf ko"
  and     xv: "x \<notin> Ptr ` {ptr..+2 ^ bits}"
  and    sof: "size_td (typ_info_t TYPE('b)) \<le> 2 ^ objBits (undefined :: 'a)"
  shows  "{ptr_val x..+size_of TYPE('b)} \<inter> {ptr..+2 ^ bits} = {}"
proof -
  from vuc have al: "is_aligned ptr bits"
    and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    and wb: "bits < word_bits"
    and [simp]: "(ptr && ~~ mask bits) = ptr"
    by (auto elim!: valid_untyped_capE)

  note blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex

  let ?ran = "{ptr..ptr + 2 ^ bits - 1}"
  let ?s = "(s\<lparr>ksPSpace := (ksPSpace s) |` (- ?ran)\<rparr>)"
  from cm ht obtain ko and v :: 'a where ks: "ksPSpace s (ptr_val x) = Some ko" and po: "proj ko = Some v"
    apply (rule cmap_relation_h_t_valid)
    apply (clarsimp simp: map_comp_Some_iff)
    done

  let ?oran = "{ptr_val x .. ptr_val x + 2 ^ objBitsKO ko - 1}"
  let ?ran' = "{ptr..+2 ^ bits}"
  let ?oran' = "{ptr_val x..+2 ^ objBitsKO ko}"

  have ran' [simp]: "?ran' = ?ran" using al wb upto_intvl_eq by blast

  have oran' [simp]: "?oran' = ?oran"
  proof (rule upto_intvl_eq)
    from invs have "pspace_aligned' s" ..
    with ks show "is_aligned (ptr_val x) (objBitsKO ko)"  ..
  qed

  from xv have "ptr_val x \<in> (- ?ran)" apply (simp only: ran' Compl_iff)
    apply (erule contrapos_nn)
    apply (erule image_eqI [rotated])
    apply simp
    done

  hence "ksPSpace ?s (ptr_val x) = Some ko" using ks by auto
  hence "?oran \<inter> ?ran = {}"
  proof (rule pspace_no_overlapD'[where p = ptr and bits = bits,simplified])
    from invs have "valid_pspace' s" ..
    with vu al show "pspace_no_overlap' ptr bits ?s" by (rule valid_untyped_no_overlap)
  qed

  hence "?oran' \<inter> ?ran' = {}" by simp
  thus "{ptr_val x..+size_of TYPE('b)} \<inter> ?ran' = {}"
  proof (rule disjoint_subset [rotated])
    have "objBits (undefined :: 'a) = objBitsKO ko" using po
      apply (simp add: objBits_def)
      apply (rule objBits_type)
      apply (subst iffD1 [OF project_koType])
      apply (fastforce simp add: project_inject)
      apply (erule tp)
      done
    thus "{ptr_val x..+size_of TYPE('b)} \<subseteq> ?oran'" using sof
      apply -
      apply (rule intvl_start_le)
      apply (simp add: size_of_def)
      done
  qed
qed

lemma vut_subseteq:
notes blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex
shows "\<lbrakk>s \<turnstile>' UntypedCap d ptr bits idx;idx < 2 ^ bits\<rbrakk>
 \<Longrightarrow> Ptr ` {ptr + of_nat idx..ptr + 2 ^ bits - 1} \<subseteq> Ptr ` {ptr ..+ 2^bits}" (is "\<lbrakk>?a1;?a2\<rbrakk> \<Longrightarrow> ?b \<subseteq> ?c")
  apply (subgoal_tac  "?c =  Ptr ` {ptr ..ptr + 2 ^ bits - 1}")
   apply (simp add:inj_image_subset_iff)
   apply (clarsimp simp:blah valid_cap'_def capAligned_def)
   apply (rule is_aligned_no_wrap')
     apply simp+
    apply (rule word_of_nat_less)
    apply simp
  apply (rule arg_cong[where f = "\<lambda>x. Ptr ` x"])
  apply (rule upto_intvl_eq)
  apply (clarsimp simp:valid_cap'_def capAligned_def)+
  done

(* CLAG : IpcCancel_C *)
lemma tcb_ptr_to_ctcb_ptr_imageD:
  "x \<in> tcb_ptr_to_ctcb_ptr ` S \<Longrightarrow> ctcb_ptr_to_tcb_ptr x \<in> S"
  apply (erule imageE)
  apply simp
  done

lemma ctcb_ptr_to_tcb_ptr_imageI:
  "ctcb_ptr_to_tcb_ptr x \<in> S \<Longrightarrow> x \<in> tcb_ptr_to_ctcb_ptr ` S"
  apply (drule imageI [where f = tcb_ptr_to_ctcb_ptr])
  apply simp
  done

lemma aligned_ranges_subset_or_disjointE [consumes 2, case_names disjoint subset1 subset2]:
  "\<lbrakk>is_aligned p n; is_aligned p' n';
   {p..p + 2 ^ n - 1} \<inter> {p'..p' + 2 ^ n' - 1} = {}  \<Longrightarrow> P;
   {p..p + 2 ^ n - 1} \<subseteq> {p'..p' + 2 ^ n' - 1} \<Longrightarrow> P;
   {p'..p' + 2 ^ n' - 1} \<subseteq> {p..p + 2 ^ n - 1} \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (drule (1) aligned_ranges_subset_or_disjoint)
  apply blast
  done

lemma valid_untyped_cap_ko_at_disjoint:
  assumes vu: "s \<turnstile>' UntypedCap d ptr bits idx"
  and   koat: "ko_at' ko x s"
  and     pv: "{x .. x + 2 ^ objBits ko - 1} \<inter> {ptr .. ptr + 2 ^ bits - 1} \<noteq> {}"
  shows   "{x .. x + 2 ^ objBits ko - 1} \<subseteq> {ptr .. ptr + 2 ^ bits - 1}"

proof -
  from vu have "is_aligned ptr bits"
    unfolding valid_cap'_def capAligned_def by simp

  moreover from koat have "is_aligned x (objBits ko)"
    by (rule obj_atE') (simp add: projectKOs objBits_def project_inject)

  ultimately show ?thesis
  proof (cases rule: aligned_ranges_subset_or_disjointE)
    case disjoint
    thus ?thesis using pv by auto
  next
    case subset2 thus ?thesis .
  next
    case subset1
    note blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex
    have  "\<not> ko_wp_at' (\<lambda>ko. {ptr..ptr + 2 ^ bits - 1} \<subset> obj_range' x ko) x s"
      using vu unfolding valid_cap'_def valid_untyped'_def
      apply clarsimp
      apply (drule_tac x = x in spec)
      apply (clarsimp simp:ko_wp_at'_def)
      done

    with koat have "\<not> {ptr..ptr + 2 ^ bits - 1} \<subset> {x..x + 2 ^ objBits ko - 1}"
      apply -
      apply (erule obj_atE')+
      apply (simp add: ko_wp_at'_def projectKOs obj_range'_def not_less objBits_def project_inject)
      done

    thus ?thesis using subset1
      by (simp add: psubset_eq del: Icc_eq_Icc)
  qed
qed

lemma tcb_ptr_to_ctcb_ptr_in_range:
  fixes tcb :: tcb
  assumes tat: "ko_at' tcb x s"
  shows "ptr_val (tcb_ptr_to_ctcb_ptr x) \<in> {x..x + 2 ^ objBits tcb - 1}"
proof -
  from tat have al: "is_aligned x 9" by (clarsimp elim!: obj_atE' simp: projectKOs objBits_simps)
  hence "x \<le> x + 2 ^ 9 - 1"
    by (rule is_aligned_no_overflow)

  moreover from al have "x \<le> x + 2 ^ 8"
    by (rule is_aligned_no_wrap') simp

  ultimately show ?thesis
    unfolding tcb_ptr_to_ctcb_ptr_def
    by (simp add: ctcb_offset_def objBits_simps field_simps word_plus_mono_right)
qed

lemma tcb_ptr_to_ctcb_ptr_in_range':
  fixes tcb :: tcb
  assumes al: "is_aligned (ctcb_ptr_to_tcb_ptr x) 9"
  shows "{ptr_val x ..+ size_of TYPE (tcb_C)}
          \<subseteq> {ctcb_ptr_to_tcb_ptr x..+2 ^ objBits tcb}"
proof -
  from al have "ctcb_ptr_to_tcb_ptr x \<le> ctcb_ptr_to_tcb_ptr x + 2 ^ 9 - 1"
    by (rule is_aligned_no_overflow)

  moreover from al have "ctcb_ptr_to_tcb_ptr x \<le> ctcb_ptr_to_tcb_ptr x + 2 ^ 8"
    by (rule is_aligned_no_wrap') simp

  moreover from al have "is_aligned (ptr_val x) 8" by (rule ctcb_ptr_to_tcb_ptr_aligned)
  moreover from al have "{ctcb_ptr_to_tcb_ptr x..+2 ^ objBits tcb} = {ctcb_ptr_to_tcb_ptr x.. ctcb_ptr_to_tcb_ptr x + 2 ^ objBits tcb - 1}"
    apply -
    apply (rule upto_intvl_eq)
     apply (simp add: objBits_simps)
    done

  ultimately show ?thesis
    unfolding ctcb_ptr_to_tcb_ptr_def ctcb_offset_def
    apply -
    apply (clarsimp simp: field_simps objBits_simps size_of_def)
    apply (drule intvlD)
    apply clarsimp
    apply (rule conjI)
     apply (erule order_trans, erule is_aligned_no_wrap')
     apply (rule of_nat_power)
      apply simp
     apply simp
    apply (rule word_plus_mono_right)
   apply (simp add: word_le_nat_alt unat_of_nat)
  apply (erule is_aligned_no_wrap')
  apply simp
  done
qed

lemma valid_untyped_cap_ctcb_member:
  fixes tcb :: tcb
  assumes vu: "s \<turnstile>' UntypedCap d ptr bits idx"
  and   koat: "ko_at' tcb x s"
  and     pv: "ptr_val (tcb_ptr_to_ctcb_ptr x) \<in> {ptr .. ptr + 2 ^ bits - 1}"
  shows   "x \<in> {ptr .. ptr + 2 ^ bits - 1}"
  using vu
proof -
  from vu koat have "{x..x + 2 ^ objBits tcb - 1} \<subseteq> {ptr..ptr + 2 ^ bits - 1}"
  proof (rule valid_untyped_cap_ko_at_disjoint)
    from koat have "ptr_val (tcb_ptr_to_ctcb_ptr x) \<in> {x..x + 2 ^ objBits tcb - 1}"
      by (rule tcb_ptr_to_ctcb_ptr_in_range)
    thus "{x..x + 2 ^ objBits tcb - 1} \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {}" using pv
      apply -
      apply rule
      apply (drule (1) orthD1)
      apply simp
      done
  qed

  thus ?thesis
  proof (rule set_mp)
    from koat have "is_aligned x (objBits tcb)"  by (clarsimp elim!: obj_atE' simp: objBits_simps projectKOs)
    thus "x \<in> {x..x + 2 ^ objBits tcb - 1}"
      apply (rule base_member_set [simplified field_simps])
      apply (simp add: objBits_simps word_bits_conv)
      done
  qed
qed

lemma ko_at_is_aligned' [intro?]:
  "ko_at' ko p s \<Longrightarrow> is_aligned p (objBits ko)"
  apply (erule obj_atE')
  apply (simp add: objBits_def projectKOs project_inject)
  done

lemma cmap_relation_disjoint_tcb:
  fixes x :: "tcb_C ptr"
  assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and    invs: "invs' s"
  and      cm: "cmap_relation (projectKO_opt \<circ>\<^sub>m (ksPSpace s)) (cslift s') tcb_ptr_to_ctcb_ptr ctcb_relation"
  and      ht: "s' \<Turnstile>\<^sub>c x"
  and      xv: "x \<notin> Ptr ` {ptr..+2 ^ bits}"
  shows  "{ptr_val x..+size_of TYPE(tcb_C)} \<inter> {ptr..+2 ^ bits} = {}"
proof -
  let ?ran = "{ptr..ptr + 2 ^ bits - 1}"
  let ?s = "(s\<lparr>ksPSpace := (ksPSpace s) |` (- ?ran)\<rparr>)"
  from cm ht invs obtain tcb :: tcb where koat: "ko_at' tcb  (ctcb_ptr_to_tcb_ptr x) s"
    apply -
    apply (erule (1) cmap_relation_h_t_valid)
    apply (drule (1) map_to_ko_atI')
    apply clarsimp
    done

  let ?oran = "{ctcb_ptr_to_tcb_ptr x .. ctcb_ptr_to_tcb_ptr x + 2 ^ objBits tcb - 1}"
  let ?ran' = "{ptr..+2 ^ bits}"
  let ?oran' = "{ctcb_ptr_to_tcb_ptr x..+2 ^ objBits tcb}"

  from vuc have al: "is_aligned ptr bits" and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    and wb: "bits < word_bits"
    by (auto elim!: valid_untyped_capE)

  have ran' [simp]: "?ran' = ?ran" using al wb upto_intvl_eq by blast

  have oran' [simp]: "?oran' = ?oran"
  proof (rule upto_intvl_eq)
    from koat show "is_aligned (ctcb_ptr_to_tcb_ptr x) (objBits tcb)"  ..
  qed

  show ?thesis
  proof (rule disjoint_subset)
    from xv koat have "\<not> ?oran \<subseteq> ?ran"
      apply -
      apply (erule contrapos_nn)
      apply (drule tcb_ptr_to_ctcb_ptr_in_range)
      apply (rule image_eqI [where x = "ptr_val x"])
       apply simp
      apply (drule (1) subsetD)
      apply simp
      done

    thus "{ctcb_ptr_to_tcb_ptr x..+2 ^ objBits tcb} \<inter> {ptr..+2 ^ bits} = {}"
      apply (rule contrapos_np)
      apply (rule valid_untyped_cap_ko_at_disjoint [OF vuc koat])
      apply simp
      done

    from koat show "{ptr_val x..+size_of TYPE(tcb_C)} \<subseteq> {ctcb_ptr_to_tcb_ptr x..+2 ^ objBits tcb}"
      by (metis tcb_ptr_to_ctcb_ptr_in_range' tcb_aligned' obj_at'_weakenE)
  qed
qed

lemma ctes_of_is_aligned:
  fixes s :: "kernel_state"
  assumes ks: "ctes_of s p = Some cte"
  shows "is_aligned p (objBits cte)"
proof -
  have "cte_wp_at' (op = cte) p s" using ks by (clarsimp simp: cte_wp_at_ctes_of)
  thus ?thesis
    apply (simp add: cte_wp_at_cases' objBits_simps cte_level_bits_def)
    apply (erule disjE)
     apply simp
    apply clarsimp
    apply (drule_tac y = n in aligned_add_aligned [where m = 4])
     apply (simp add: tcb_cte_cases_def is_aligned_def split: if_split_asm)
    apply (simp add: word_bits_conv)
    apply simp
    done
qed

lemma cte_wp_at_casesE' [consumes 1, case_names cte tcb]:
  "\<lbrakk>cte_wp_at' P p s;
  \<And>cte. \<lbrakk> ksPSpace s p = Some (KOCTE cte); is_aligned p cte_level_bits; P cte; ps_clear p 4 s \<rbrakk> \<Longrightarrow> R;
  \<And>n tcb getF setF. \<lbrakk>
     ksPSpace s (p - n) = Some (KOTCB tcb);
     is_aligned (p - n) 9;
     tcb_cte_cases n = Some (getF, setF);
     P (getF tcb); ps_clear (p - n) 9 s\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (fastforce simp: cte_wp_at_cases')

(* FIXME: MOVE *)
lemma tcb_cte_cases_in_range3:
  assumes tc: "tcb_cte_cases (y - x) = Some v"
  and     al: "is_aligned x 9"
  shows   "y + 2 ^ 4 - 1 \<le> x + 2 ^ 9 - 1"
proof -
  from tc obtain q where yq: "y = x + q" and qv: "q \<le> 2 ^ 7 - 1"
    unfolding tcb_cte_cases_def
    by (simp add: diff_eq_eq split: if_split_asm)

  have "q + (2 ^ 4 - 1) \<le> (2 ^ 7 - 1) + (2 ^ 4 - 1)" using qv
    by (rule word_plus_mcs_3) simp
  also have "\<dots> \<le> 2 ^ 9 - 1" by simp
  finally have "x + (q + (2 ^ 4 - 1)) \<le> x + (2 ^ 9 - 1)"
    apply (rule word_plus_mono_right)
    apply (rule is_aligned_no_overflow' [OF al])
    done

  thus ?thesis using yq by (simp add: field_simps)
qed

lemma tcb_cte_in_range:
  "\<lbrakk> ksPSpace s p = Some (KOTCB tcb); is_aligned p 9;
  tcb_cte_cases n = Some (getF, setF) \<rbrakk>
  \<Longrightarrow> {p + n.. (p + n) + 2 ^ objBits (cte :: cte) - 1} \<subseteq> {p .. p + 2 ^ objBits tcb - 1}"
  apply (rule range_subsetI)
  apply (erule (1) tcb_cte_cases_in_range1 [where y = "p + n" and x = p, simplified])
  apply (frule (1) tcb_cte_cases_in_range3 [where y = "p + n" and x = p, simplified])
  apply (simp add: objBits_simps)
  done

lemma tcb_cte_cases_aligned:
  "\<lbrakk>is_aligned p 9; tcb_cte_cases n = Some (getF, setF)\<rbrakk>
  \<Longrightarrow> is_aligned (p + n) (objBits (cte :: cte))"
  apply (erule aligned_add_aligned)
   apply (simp add: tcb_cte_cases_def is_aligned_def objBits_simps split: if_split_asm)
  apply (simp add: objBits_simps)
  done

lemma tcb_cte_in_range':
  "\<lbrakk> ksPSpace s p = Some (KOTCB tcb); is_aligned p 9;
  tcb_cte_cases n = Some (getF, setF) \<rbrakk>
  \<Longrightarrow> {p + n..+2 ^ objBits (cte :: cte)} \<subseteq> {p ..+ 2 ^ objBits tcb}"
  apply (subst upto_intvl_eq)
    apply (erule (1) tcb_cte_cases_aligned)
   apply (simp add: objBits_def)
  apply (subst upto_intvl_eq)
   apply (simp add: objBits_simps)
  apply (simp add: objBits_def)
  apply (erule (2) tcb_cte_in_range[unfolded objBits_def, simplified])
  done

(* clagged from above :( Were I smarter or if I cared more I could probably factor out more \<dots>*)
lemma cmap_relation_disjoint_cte:
  assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and   invs: "invs' s"
  and     cm: "cmap_relation (ctes_of s) (cslift s') Ptr ccte_relation"
  and     ht: "s' \<Turnstile>\<^sub>c (x :: cte_C ptr)"
  and     xv: "x \<notin> Ptr ` {ptr..+2 ^ bits}"
  shows  "{ptr_val x..+size_of TYPE(cte_C)} \<inter> {ptr..+2 ^ bits} = {}"
proof -
  from vuc have al: "is_aligned ptr bits" and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    and wb: "bits < word_bits" and [simp]: "(ptr && ~~ mask bits) = ptr"
    by (auto elim!: valid_untyped_capE)

  note blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex

  let ?ran = "{ptr..ptr + 2 ^ bits - 1}"
  let ?s = "(s\<lparr>ksPSpace := (ksPSpace s) |` (- ?ran)\<rparr>)"
  from cm ht obtain cte where ks: "ctes_of s (ptr_val x) = Some cte"
    apply (rule cmap_relation_h_t_valid)
    apply (clarsimp simp: map_comp_Some_iff)
    done

  let ?oran = "{ptr_val x .. ptr_val x + 2 ^ objBits cte - 1}"

  let ?ran' = "{ptr..+2 ^ bits}"
  let ?oran' = "{ptr_val x..+2 ^ objBits cte}"

  have ran' [simp]: "?ran' = ?ran" using al wb upto_intvl_eq by auto

  have oran' [simp]: "?oran' = ?oran"
  proof (rule upto_intvl_eq)
    from ks show "is_aligned (ptr_val x) (objBits cte)"
      by (rule ctes_of_is_aligned)
  qed

  from xv have px: "ptr_val x \<in> (- ?ran)"
    apply (simp only: ran' Compl_iff)
    apply (erule contrapos_nn)
    apply (erule image_eqI [rotated])
    apply simp
    done

  from ks have "cte_wp_at' (op = cte) (ptr_val x) s" by (clarsimp simp: cte_wp_at_ctes_of)
  thus ?thesis
  proof (cases rule: cte_wp_at_casesE')
    case (cte cte')

    hence "ksPSpace ?s (ptr_val x) = Some (injectKOS cte)" using px by simp
    hence "?oran \<inter> ?ran = {}"
      unfolding objBits_def
    proof (rule pspace_no_overlapD'[where p = ptr and bits = bits,simplified])
      from invs have "valid_pspace' s" ..
      with vu al show "pspace_no_overlap' ptr bits ?s" by (rule valid_untyped_no_overlap)
    qed
    hence "?oran' \<inter> ?ran' = {}" by simp
    thus ?thesis by (simp add: objBits_simps size_of_def)
  next
    case (tcb n tcb _ _)

    hence koat: "ko_at' tcb (ptr_val x - n) s"
      apply -
      apply (erule obj_atI', simp_all add: objBits_simps projectKOs)
      done

    let ?tran = "{ptr_val x - n .. (ptr_val x - n) + 2 ^ objBits tcb - 1}"
    have ot: "?oran \<subseteq> ?tran"
      by (rule tcb_cte_in_range[where p = "ptr_val x - n" and n = "n",
                                simplified diff_add_cancel]) fact+

    also
    from xv have "\<not> \<dots> \<subseteq> ?ran"
    proof (rule contrapos_nn)
      assume "?tran \<subseteq> ?ran"
      with ot have "?oran \<subseteq> ?ran" by (rule order_trans)
      hence "ptr_val x \<in> ?ran"
      proof (rule subsetD)
        from tcb have "is_aligned (ptr_val x) (objBits cte)"
          apply -
          apply (drule (1) tcb_cte_cases_aligned)
          apply simp
          done
        hence "ptr_val x \<le> ptr_val x + 2 ^ objBits cte - 1"
          by (rule is_aligned_no_overflow)
        thus "ptr_val x \<in> ?oran" by (rule first_in_uptoD)
      qed
      thus "x \<in> Ptr ` {ptr..+2 ^ bits}"
        unfolding ran'
        by (rule image_eqI [where x = "ptr_val x", rotated]) simp
    qed

    hence "?tran \<inter> ?ran' = {}"
      apply (rule contrapos_np)
      apply (rule valid_untyped_cap_ko_at_disjoint [OF vuc koat])
      apply simp
      done

    finally have "{ptr_val x..+2 ^ objBits cte} \<inter> ?ran' = {}"
      using ot unfolding oran'
      by blast
    thus ?thesis by (simp add: objBits_simps size_of_def)
  qed
qed

lemma cmap_relation_disjoint_user_data:
  fixes x :: "user_data_C ptr"
  assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and    invs: "invs' s"
  and      cm: "cmap_relation (heap_to_user_data (ksPSpace s) (underlying_memory (ksMachineState s))) (cslift s') Ptr cuser_user_data_relation"
  and      ht: "s' \<Turnstile>\<^sub>c x"
  and      xv: "x \<notin> Ptr ` {ptr..+2 ^ bits}"
  shows  "{ptr_val x..+size_of TYPE(user_data_C)} \<inter> {ptr..+2 ^ bits} = {}"
proof -
  from vuc have al: "is_aligned ptr bits" and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    and wb: "bits < word_bits" and [simp]:"ptr && ~~ mask bits = ptr"
    by (auto elim!: valid_untyped_capE)

  note blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex

  let ?ran = "{ptr..ptr + 2 ^ bits - 1}"
  let ?s = "(s\<lparr>ksPSpace := (ksPSpace s) |` (- ?ran)\<rparr>)"
  from cm ht have ks: "ksPSpace s (ptr_val x) = Some KOUserData"
    apply (rule cmap_relation_h_t_valid)
    apply (clarsimp simp: map_comp_Some_iff heap_to_user_data_def Let_def projectKO_opts_defs)
    apply (case_tac k')
        apply simp_all
    done

  let ?oran = "{ptr_val x .. ptr_val x + 2 ^ objBitsKO KOUserData - 1}"

  let ?ran' = "{ptr..+2 ^ bits}"
  let ?oran' = "{ptr_val x..+2 ^ objBitsKO KOUserData}"

  have ran' [simp]: "?ran' = ?ran" using al wb upto_intvl_eq by auto

  have oran' [simp]: "?oran' = ?oran"
  proof (rule upto_intvl_eq)
    from invs have "pspace_aligned' s" ..
    with ks show "is_aligned (ptr_val x) (objBitsKO KOUserData)"  ..
  qed

  from xv have "ptr_val x \<in> (- ?ran)"
    apply (simp only: ran' Compl_iff)
    apply (erule contrapos_nn)
    apply (erule image_eqI [rotated])
    apply simp
    done

  hence "ksPSpace ?s (ptr_val x) = Some KOUserData" using ks by simp
  hence "?oran \<inter> ?ran = {}"
  proof (rule pspace_no_overlapD'[where p = ptr and bits = bits,simplified])
    from invs have "valid_pspace' s" ..
    with vu al show "pspace_no_overlap' ptr bits ?s" by (rule valid_untyped_no_overlap)
  qed

  hence "?oran' \<inter> ?ran' = {}" by simp
  thus "{ptr_val x..+size_of TYPE(user_data_C)} \<inter> ?ran' = {}"
  proof (rule disjoint_subset [rotated])
    show "{ptr_val x..+size_of TYPE(user_data_C)} \<subseteq> ?oran'"
      apply -
      apply (rule intvl_start_le)
      apply (simp add: size_of_def objBits_simps pageBits_def)
      done
  qed
qed

lemma cmap_relation_disjoint_device_data:
  fixes x :: "user_data_device_C ptr"
  assumes vuc: "s \<turnstile>' UntypedCap d ptr bits idx"
  and    invs: "invs' s"
  and      cm: "cmap_relation (heap_to_device_data (ksPSpace s) (underlying_memory (ksMachineState s))) (cslift s') Ptr cuser_user_data_device_relation"
  and      ht: "s' \<Turnstile>\<^sub>c x"
  and      xv: "x \<notin> Ptr ` {ptr..+2 ^ bits}"
  shows  "{ptr_val x..+size_of TYPE(user_data_device_C)} \<inter> {ptr..+2 ^ bits} = {}"
proof -
  from vuc have al: "is_aligned ptr bits" and vu: "valid_untyped' d ptr bits idx s" and p0: "ptr \<noteq> 0"
    and wb: "bits < word_bits" and [simp]:"ptr && ~~ mask bits = ptr"
    by (auto elim!: valid_untyped_capE)

  note blah[simp del] =  atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex

  let ?ran = "{ptr..ptr + 2 ^ bits - 1}"
  let ?s = "(s\<lparr>ksPSpace := (ksPSpace s) |` (- ?ran)\<rparr>)"
  from cm ht have ks: "ksPSpace s (ptr_val x) = Some KOUserDataDevice"
    apply (rule cmap_relation_h_t_valid)
    apply (clarsimp simp: map_comp_Some_iff heap_to_device_data_def Let_def projectKO_opts_defs)
    apply (case_tac k')
        apply simp_all
    done

  let ?oran = "{ptr_val x .. ptr_val x + 2 ^ objBitsKO KOUserDataDevice - 1}"

  let ?ran' = "{ptr..+2 ^ bits}"
  let ?oran' = "{ptr_val x..+2 ^ objBitsKO KOUserDataDevice}"

  have ran' [simp]: "?ran' = ?ran" using al wb upto_intvl_eq by auto

  have oran' [simp]: "?oran' = ?oran"
  proof (rule upto_intvl_eq)
    from invs have "pspace_aligned' s" ..
    with ks show "is_aligned (ptr_val x) (objBitsKO KOUserDataDevice)"  ..
  qed

  from xv have "ptr_val x \<in> (- ?ran)"
    apply (simp only: ran' Compl_iff)
    apply (erule contrapos_nn)
    apply (erule image_eqI [rotated])
    apply simp
    done

  hence "ksPSpace ?s (ptr_val x) = Some KOUserDataDevice" using ks by simp
  hence "?oran \<inter> ?ran = {}"
  proof (rule pspace_no_overlapD'[where p = ptr and bits = bits,simplified])
    from invs have "valid_pspace' s" ..
    with vu al show "pspace_no_overlap' ptr bits ?s" by (rule valid_untyped_no_overlap)
  qed

  hence "?oran' \<inter> ?ran' = {}" by simp
  thus "{ptr_val x..+size_of TYPE(user_data_device_C)} \<inter> ?ran' = {}"
  proof (rule disjoint_subset [rotated])
    show "{ptr_val x..+size_of TYPE(user_data_device_C)} \<subseteq> ?oran'"
      apply -
      apply (rule intvl_start_le)
      apply (simp add: size_of_def objBits_simps pageBits_def)
      done
  qed
qed

lemma tcb_queue_relation_live_restrict:
  assumes vuc: "s \<turnstile>' capability.UntypedCap d ptr bits idx"
  and     rel: "\<forall>t \<in> set q. tcb_at' t s"
  and    live: "\<forall>t \<in> set q. ko_wp_at' live' t s"
  and      rl: "\<forall>(p :: word32) P. ko_wp_at' P p s \<and> (\<forall>ko. P ko \<longrightarrow> live' ko) \<longrightarrow> p \<notin> {ptr..ptr + 2 ^ bits - 1}"
  shows "tcb_queue_relation' getNext getPrev (cm |` (- Ptr ` {ptr..+2 ^ bits})) q cend chead =
  tcb_queue_relation' getNext getPrev cm q cend chead"
proof (rule tcb_queue_relation'_cong [OF refl refl refl])
  fix p
  assume "p \<in> tcb_ptr_to_ctcb_ptr ` set q"

  hence pin: "ctcb_ptr_to_tcb_ptr p \<in> set q" by (rule tcb_ptr_to_ctcb_ptr_imageD)

  with rel have "tcb_at' (ctcb_ptr_to_tcb_ptr p) s" ..
  then obtain tcb :: tcb where koat: "ko_at' tcb (ctcb_ptr_to_tcb_ptr p) s"
    by (clarsimp simp: obj_at'_real_def ko_wp_at'_def)

  from live pin have "ko_wp_at' live' (ctcb_ptr_to_tcb_ptr p) s" ..
  hence notin: "(ctcb_ptr_to_tcb_ptr p) \<notin> {ptr..ptr + 2 ^ bits - 1}"
    by (fastforce intro!: rl [rule_format])

  from vuc have al: "is_aligned ptr bits" and wb: "bits < word_bits"
    by (auto elim!: valid_untyped_capE)

  hence ran': " {ptr..+2 ^ bits} = {ptr..ptr + 2 ^ bits - 1}" by (simp add: upto_intvl_eq)

  hence "p \<in> - Ptr ` {ptr..+2 ^ bits}" using vuc koat notin
    apply -
    apply (erule contrapos_np)
    apply (erule (1) valid_untyped_cap_ctcb_member)
    apply (clarsimp elim!: imageE simp: ran')
    done

  thus "(cm |` (- Ptr ` {ptr..+2 ^ bits})) p = cm p" by simp
qed

fun
  epQ :: "endpoint \<Rightarrow> word32 list"
  where
  "epQ IdleEP = []"
  | "epQ (RecvEP ts) = ts"
  | "epQ (SendEP ts) = ts"

lemma ep_queue_live:
  assumes invs: "invs' s"
  and     koat: "ko_at' ep p s"
  shows   "\<forall>t \<in> set (epQ ep). ko_wp_at' live' t s"
proof
  fix t
  assume tin: "t \<in> set (epQ ep)"

  from invs koat tin show "ko_wp_at' live' t s"
    apply -
    apply (drule sym_refs_ko_atD')
     apply clarsimp
    apply (cases ep)
    by (auto elim!: ko_wp_at'_weakenE [OF _ refs_of_live'])
qed

fun
  ntfnQ :: "ntfn \<Rightarrow> word32 list"
  where
  "ntfnQ (WaitingNtfn ts) = ts"
  | "ntfnQ _ = []"

lemma ntfn_queue_live:
  assumes invs: "invs' s"
  and     koat: "ko_at' ntfn p s"
  shows   "\<forall>t \<in> set (ntfnQ (ntfnObj ntfn)). ko_wp_at' live' t s"
proof
  fix t
  assume tin: "t \<in> set (ntfnQ (ntfnObj ntfn))"

  from invs koat tin show "ko_wp_at' live' t s"
    apply -
    apply (drule sym_refs_ko_atD')
     apply clarsimp
    apply (cases "ntfnObj ntfn")
      apply (auto elim!: ko_wp_at'_weakenE [OF _ refs_of_live']
                  dest!: bspec)
    done
qed

lemma cendpoint_relation_restrict:
  assumes vuc: "s \<turnstile>' capability.UntypedCap d ptr bits idx"
  and    invs: "invs' s"
  and      rl: "\<forall>(p :: word32) P. ko_wp_at' P p s \<and> (\<forall>ko. P ko \<longrightarrow> live' ko) \<longrightarrow> p \<notin> {ptr..ptr + 2 ^ bits - 1}"
  and    meps: "map_to_eps (ksPSpace s) p = Some ep"
  shows "cendpoint_relation (cslift s' |` (- Ptr ` {ptr..+2 ^ bits})) ep b = cendpoint_relation (cslift s') ep b"
proof -
  from invs have "valid_objs' s" ..
  with meps have vep: "valid_ep' ep s"
    apply -
    apply (clarsimp simp add: map_comp_Some_iff projectKOs)
    apply (erule (1) valid_objsE')
    apply (simp add: valid_obj'_def)
    done

  from meps have koat: "ko_at' ep p s" by (rule map_to_ko_atI') fact+

  show ?thesis
  proof (cases ep)
    case (RecvEP ts)

    from vep RecvEP have tats: "\<forall>t \<in> set ts. tcb_at' t s"
      by (simp add: valid_ep'_def)

    have tlive: "\<forall>t\<in>set ts. ko_wp_at' live' t s" using RecvEP invs koat
      apply -
      apply (drule (1) ep_queue_live)
      apply simp
      done

    show ?thesis using RecvEP
      unfolding cendpoint_relation_def Let_def
      by (simp add: tcb_queue_relation_live_restrict [OF vuc tats tlive rl])
  next
    case (SendEP ts)

    from vep SendEP have tats: "\<forall>t \<in> set ts. tcb_at' t s"
      by (simp add: valid_ep'_def)

    have tlive: "\<forall>t\<in>set ts. ko_wp_at' live' t s" using SendEP invs koat
      apply -
      apply (drule (1) ep_queue_live)
      apply simp
      done

    show ?thesis using SendEP
      unfolding cendpoint_relation_def Let_def
      by (simp add: tcb_queue_relation_live_restrict [OF vuc tats tlive rl])
  next
    case IdleEP
    thus ?thesis unfolding cendpoint_relation_def Let_def by simp
  qed
qed

lemma cnotification_relation_restrict:
  assumes vuc: "s \<turnstile>' capability.UntypedCap d ptr bits idx"
  and    invs: "invs' s"
  and      rl: "\<forall>(p :: word32) P. ko_wp_at' P p s \<and> (\<forall>ko. P ko \<longrightarrow> live' ko) \<longrightarrow> p \<notin> {ptr..ptr + 2 ^ bits - 1}"
  and    meps: "map_to_ntfns (ksPSpace s) p = Some ntfn"
  shows "cnotification_relation (cslift s' |` (- Ptr ` {ptr..+2 ^ bits})) ntfn b = cnotification_relation (cslift s') ntfn b"
proof -
  from invs have "valid_objs' s" ..
  with meps have vep: "valid_ntfn' ntfn s"
    apply -
    apply (clarsimp simp add: map_comp_Some_iff projectKOs)
    apply (erule (1) valid_objsE')
    apply (simp add: valid_obj'_def)
    done

  from meps have koat: "ko_at' ntfn p s" by (rule map_to_ko_atI') fact+

  show ?thesis
  proof (cases "ntfnObj ntfn")
    case (WaitingNtfn ts)

    with vep have tats: "\<forall>t \<in> set ts. tcb_at' t s"
      by (simp add: valid_ntfn'_def)

    have tlive: "\<forall>t\<in>set ts. ko_wp_at' live' t s" using WaitingNtfn invs koat
      apply -
      apply (drule (1) ntfn_queue_live)
      apply simp
      done

    show ?thesis using WaitingNtfn
      unfolding cnotification_relation_def Let_def
      by (simp add: tcb_queue_relation_live_restrict [OF vuc tats tlive rl])
  qed (simp_all add: cnotification_relation_def Let_def)
qed

declare surj_Ptr[simp]

declare bij_Ptr[simp]

lemma surj_tcb_ptr_to_ctcb_ptr [simp]:
  "surj tcb_ptr_to_ctcb_ptr"
  by (rule surjI [where f = "ctcb_ptr_to_tcb_ptr"], simp)

lemma bij_tcb_ptr_to_ctcb_ptr [simp]:
  "bij tcb_ptr_to_ctcb_ptr" by (simp add: bijI)

lemma inj_ctcb_ptr_to_tcb_ptr [simp]:
  "inj ctcb_ptr_to_tcb_ptr"
  apply (rule injI)
  apply (simp add: ctcb_ptr_to_tcb_ptr_def)
  done

lemma surj_ctcb_ptr_to_tcb_ptr [simp]:
  "surj ctcb_ptr_to_tcb_ptr"
  by (rule surjI [where f = "tcb_ptr_to_ctcb_ptr"], simp)

lemma bij_ctcb_ptr_to_tcb_ptr [simp]:
  "bij ctcb_ptr_to_tcb_ptr" by (simp add: bijI)

lemma cmap_relation_restrict_both:
  "\<lbrakk> cmap_relation am cm f rel; bij f\<rbrakk> \<Longrightarrow> cmap_relation (am |` (- S)) (cm |` (- f ` S)) f rel"
  unfolding cmap_relation_def
  apply (rule conjI)
   apply (clarsimp simp: image_Int bij_image_Compl_eq bij_def)
  apply (rule ballI)
  apply (clarsimp simp: image_iff2 bij_def)
  done

lemma cmap_relation_restrict_both_proj:
  "\<lbrakk> cmap_relation (projectKO_opt \<circ>\<^sub>m am) cm f rel; bij f\<rbrakk>
  \<Longrightarrow> cmap_relation (projectKO_opt \<circ>\<^sub>m (am |` (- S))) (cm |` (- f ` S)) f rel"
  unfolding cmap_relation_def
  apply (rule conjI)
   apply (rule equalityI)
    apply rule
    apply (clarsimp simp: map_comp_restrict_map_Some_iff image_iff2 bij_def)
    apply (erule (1) cmap_domE1)
    apply simp
   apply (clarsimp simp: image_Int bij_image_Compl_eq bij_def)
   apply (erule (1) cmap_domE2)
   apply (clarsimp simp: image_Int bij_image_Compl_eq bij_def map_comp_restrict_map_Some_iff intro!: imageI)
  apply clarsimp
  apply (subst restrict_in)
   apply (clarsimp simp add: image_iff map_comp_restrict_map_Some_iff inj_eq bij_def)
  apply (clarsimp simp add: map_comp_restrict_map_Some_iff)
  apply (drule (1) bspec [OF _ domI])
  apply simp
  done

declare not_snd_assert[simp]

lemma ccorres_stateAssert_fwd:
  "ccorres r xf (P and R) P' hs b c \<Longrightarrow> ccorres r xf P P' hs (stateAssert R vs >>= (\<lambda>_. b)) c"
  apply (rule ccorresI')
  apply (simp add: stateAssert_def bind_assoc)
  apply (drule not_snd_bindD)
   apply (fastforce simp add: in_monad)
  apply clarsimp
  apply (frule not_snd_bindI1)
  apply simp
  apply (erule (1) ccorresE)
      apply simp
     apply assumption
    apply assumption
   apply assumption
  apply (fastforce simp: in_monad')
  done

(* FIXME: generalise to above *)
lemma tcb_ptr_to_ctcb_ptr_comp:
  "tcb_ptr_to_ctcb_ptr = Ptr o (\<lambda>p. p + ctcb_offset)"
  apply (rule ext)
  apply (simp add: tcb_ptr_to_ctcb_ptr_def)
  done

lemma tcb_ptr_to_ctcb_ptr_to_Ptr:
  "tcb_ptr_to_ctcb_ptr ` {p..+b} = Ptr ` {p + ctcb_offset..+b}"
  apply (simp add:  tcb_ptr_to_ctcb_ptr_comp image_comp [symmetric])
  apply (rule equalityI)
   apply clarsimp
   apply (rule imageI)
   apply (drule intvlD)
   apply clarsimp
   apply (subgoal_tac "p + ctcb_offset + of_nat k \<in> {p + ctcb_offset..+b}")
    apply (simp add: field_simps)
   apply (erule intvlI)
  apply (rule image_mono)
  apply clarsimp
  apply (drule intvlD)
  apply clarsimp
  apply (rule image_eqI)
   apply simp
  apply (erule intvlI)
  done

lemma valid_untyped_cap_ctcb_member':
  fixes tcb :: tcb
  shows "\<lbrakk>s \<turnstile>' capability.UntypedCap d ptr bits idx; ko_at' tcb x s;
  ptr_val (tcb_ptr_to_ctcb_ptr x) \<in> {ptr..+2 ^ bits}\<rbrakk>
  \<Longrightarrow> x \<in> {ptr..+ 2 ^ bits}"
  apply (rule valid_untyped_capE, assumption)
  apply (simp only: upto_intvl_eq)
  apply (erule (2) valid_untyped_cap_ctcb_member)
  done

lemma cpspace_tcb_relation_address_subset:
  assumes     vuc: "s \<turnstile>' capability.UntypedCap d ptr bits idx"
  and        invs: "invs' s"
  and     ctcbrel: "cpspace_tcb_relation (ksPSpace s) (t_hrs_' (globals s'))"
  shows "cmap_relation (map_to_tcbs (ksPSpace s |` (- {ptr..+2 ^ bits - unat ctcb_offset})))
      (cslift s' |` (- tcb_ptr_to_ctcb_ptr ` {ptr..+2 ^ bits - unat ctcb_offset})) tcb_ptr_to_ctcb_ptr
      ctcb_relation
   = cmap_relation (map_to_tcbs (ksPSpace s |` (- {ptr..+2 ^ bits})))
        (cslift s' |` (- Ptr ` {ptr..+2 ^ bits})) tcb_ptr_to_ctcb_ptr
        ctcb_relation" (is "cmap_relation ?am ?cm tcb_ptr_to_ctcb_ptr ctcb_relation
  = cmap_relation ?am' ?cm' tcb_ptr_to_ctcb_ptr ctcb_relation")
proof (rule cmap_relation_cong)
  from vuc have al: "is_aligned ptr bits" and wb: "bits < word_bits" by (auto elim: valid_untyped_capE)

  have r1: "\<And>x tcb. \<lbrakk> (map_to_tcbs (ksPSpace s) x) = Some tcb; x \<in> {ptr..+2 ^ bits}\<rbrakk>
    \<Longrightarrow> x \<in> {ptr..+2 ^ bits - unat ctcb_offset}"
  proof (subst intvl_aligned_top [where 'a=32, folded word_bits_def, OF _ al _ _ wb])
    fix x tcb
    assume mtcb: "map_to_tcbs (ksPSpace s) x = Some tcb" and xin: "x \<in> {ptr..+2 ^ bits}"

    from mtcb invs have koat: "ko_at' tcb x s"
      by (fastforce simp: map_comp_Some_iff projectKOs intro: aligned_distinct_obj_atI')

    thus "is_aligned x (objBits tcb)"
      by (clarsimp elim!: obj_atE' simp: projectKOs objBits_def)

    (* FIXME: generalise *)
    with xin koat show "objBits tcb \<le> bits" using wb
      apply -
      apply (frule is_aligned_no_overflow)
      apply (drule valid_untyped_cap_ko_at_disjoint [OF vuc])
      apply (erule contrapos_pn)
      apply (subst upto_intvl_eq [OF al])
      apply (erule orthD1)
      apply simp
      apply (drule (1) range_subsetD)
      apply clarsimp
      apply (drule (1) word_sub_mono2 [where b = "(2 :: word32) ^ objBits tcb - 1"
        and d = "2 ^ bits - 1", simplified field_simps])
      apply (subst field_simps [symmetric], subst olen_add_eqv [symmetric])
      apply (simp add: field_simps)
      apply (subst field_simps [symmetric], subst olen_add_eqv [symmetric])
      apply (rule is_aligned_no_overflow' [OF al])
      apply (subgoal_tac "(2 :: word32) ^ objBits tcb \<noteq> 0")
       apply (simp add: word_le_nat_alt unat_minus_one le_diff_iff word_bits_def)
      apply (simp add: objBits_simps)
      done

    show "unat ctcb_offset < 2 ^ objBits tcb"
      by (fastforce simp add: ctcb_offset_def objBits_simps project_inject)

    show "x \<in> {ptr..+2 ^ bits}" by fact
  qed

  show "dom ?am = dom ?am'"
    apply (rule dom_eqI)
    apply (clarsimp dest!: r1 simp: map_comp_restrict_map_Some_iff)
    apply (clarsimp dest!: intvl_mem_weaken simp: map_comp_restrict_map_Some_iff)
    done

  let ?ran = "{ptr..+2 ^ bits}"
  let ?small_ran = "{ptr..+2 ^ bits - unat ctcb_offset}"

  show "dom ?cm = dom ?cm'"
  proof (rule dom_eqI)
    fix x y
    assume "?cm' x = Some y"
    hence cl: "cslift s' x = Some y" and xni: "x \<notin> Ptr ` ?ran"
      by (auto simp: restrict_map_Some_iff)

    with ctcbrel obtain x' tcb where mt: "map_to_tcbs (ksPSpace s) x' = Some tcb"
      and xv: "x = tcb_ptr_to_ctcb_ptr x'"
      by (fastforce elim!: cmap_relation_h_t_valid simp add: h_t_valid_clift_Some_iff)

    have "(cslift s' |` (- tcb_ptr_to_ctcb_ptr ` ?small_ran)) x = Some y"
    proof (subst restrict_in)
      show "x \<in> - tcb_ptr_to_ctcb_ptr ` ?small_ran" using xni
      proof (rule contrapos_np)
        assume "x \<notin> - tcb_ptr_to_ctcb_ptr ` ?small_ran"
        hence "x \<in> tcb_ptr_to_ctcb_ptr ` ?small_ran" by simp
        hence "x \<in> Ptr ` {ptr + ctcb_offset ..+ 2 ^ bits - unat ctcb_offset}" by (simp add: tcb_ptr_to_ctcb_ptr_to_Ptr)
        thus "x \<in> Ptr ` ?ran"
          by (clarsimp intro!: imageI elim!: intvl_plus_sub_offset)
      qed
    qed fact
    thus "\<exists>y. (cslift s' |` (- tcb_ptr_to_ctcb_ptr ` ?small_ran)) x = Some y" ..
  next
    fix x y
    assume "?cm x = Some y"
    hence cl: "cslift s' x = Some y" and xni: "x \<notin> tcb_ptr_to_ctcb_ptr ` ?small_ran"
      by (auto simp: restrict_map_Some_iff)

    with ctcbrel obtain x' tcb where mt: "map_to_tcbs (ksPSpace s) x' = Some tcb" and xv: "x = tcb_ptr_to_ctcb_ptr x'"
      by (fastforce elim!: cmap_relation_h_t_valid simp add: h_t_valid_clift_Some_iff)

    from mt invs have koat: "ko_at' tcb x' s" by (rule map_to_ko_atI')

    have "(cslift s' |` (- Ptr ` ?ran)) x = Some y"
    proof (subst restrict_in)
      show "x \<in> - Ptr ` ?ran" using xni
        apply (rule contrapos_np)
        apply (simp add: xv)
        apply (rule imageI)
        apply (rule r1 [OF mt])
        apply (rule valid_untyped_cap_ctcb_member' [OF vuc koat])
        apply (erule imageE)
        apply simp
        done
    qed fact
    thus "\<exists>y. (cslift s' |` (- Ptr ` ?ran)) x = Some y" ..
  qed
qed (clarsimp simp: map_comp_Some_iff restrict_map_Some_iff)

lemma heap_to_user_data_restrict:
  "heap_to_user_data (mp |` S) bhp = (heap_to_user_data mp bhp |` S)"
  unfolding heap_to_user_data_def
  apply (rule ext)
  apply (case_tac "p \<in> S")
  apply (simp_all add: Let_def map_comp_def split: option.splits)
  done

lemma heap_to_device_data_restrict:
  "heap_to_device_data (mp |` S) bhp = (heap_to_device_data mp bhp |` S)"
  unfolding heap_to_device_data_def
  apply (rule ext)
  apply (case_tac "p \<in> S")
  apply (simp_all add: Let_def map_comp_def split: option.splits)
  done

lemma ccorres_stateAssert_after:
  assumes "ccorres r xf (P and (\<lambda>s. (\<forall>(rv,s') \<in> fst (f s). R s'))) P' hs f c"
  shows "ccorres r xf P P' hs (do _ \<leftarrow> f; stateAssert R vs od) c" using assms
  apply (clarsimp simp: ccorres_underlying_def split: xstate.splits)
  apply (drule snd_stateAssert_after)
  apply clarsimp
  apply (drule (1) bspec)
  apply (clarsimp simp: split_def)
  apply (rule conjI)
   apply clarsimp
   apply (rename_tac s)
   apply (erule_tac x=n in allE)
   apply (erule_tac x="Normal s" in allE)
   apply clarsimp
   apply (simp add: bind_def stateAssert_def get_def assert_def)
   apply (rule bexI)
    prefer 2
    apply assumption
   apply (clarsimp simp: return_def fail_def)
   apply fastforce
  apply fastforce
  done

lemma aligned_range_offset_mem_helper:
  "\<lbrakk> is_aligned (x :: 'a :: len word) m; y < 2 ^ m; is_aligned p n;
              n \<ge> m; n < len_of TYPE('a) \<rbrakk>
       \<Longrightarrow> (x + y \<in> {p .. p + 2 ^ n - 1}) = (x \<in> {p .. p + 2 ^ n - 1})"
  apply (simp only: mask_in_range[symmetric]
                    is_aligned_add_or)
  apply (simp add: word_ao_dist, simp add: mask_out_sub_mask)
  apply (subst less_mask_eq, erule order_less_le_trans)
   apply (simp add: two_power_increasing)
  apply simp
  done

lemma heap_to_user_data_update_region:
  assumes foo: "\<And>x y v. \<lbrakk> map_to_user_data psp x = Some y;
                           v < 2 ^ pageBits \<rbrakk> \<Longrightarrow> (x + v \<in> S) = (x \<in> S)"
  shows
  "heap_to_user_data psp (\<lambda>x. if x \<in> S then v else f x)
     = (\<lambda>x. if x \<in> S \<inter> dom (map_to_user_data psp) then Some (K (word_rcat [v, v, v, v]))
             else heap_to_user_data psp f x)"
  apply (rule ext)
  apply (simp add: heap_to_user_data_def Let_def
            split: if_split)
  apply (rule conjI)
   apply (clarsimp simp: byte_to_word_heap_def Let_def add.assoc
                 intro!: ext)
   apply (subst foo, assumption+,
          (rule word_add_offset_less[where n=2, simplified]
                word_add_offset_less[where n=2 and y=0, simplified],
           simp_all, rule ucast_less,
           simp_all add: word_bits_def pageBits_def
                         order_less_le_trans[OF ucast_less])[1])+
   apply simp
  apply clarsimp
  apply (case_tac "map_to_user_data psp x")
   apply simp
  apply (clarsimp simp: dom_def byte_to_word_heap_def Let_def add.assoc
                intro!: ext)
  apply (subst foo, assumption,
         (rule word_add_offset_less[where n=2, simplified]
               word_add_offset_less[where n=2 and y=0, simplified],
          simp_all, rule ucast_less,
          simp_all add: word_bits_def pageBits_def
                        order_less_le_trans[OF ucast_less])[1])+
  apply (simp add: field_simps)
  done

lemma heap_to_device_data_update_region:
  assumes foo: "\<And>x y v. \<lbrakk> map_to_user_data_device psp x = Some y;
                           v < 2 ^ pageBits \<rbrakk> \<Longrightarrow> (x + v \<in> S) = (x \<in> S)"
  shows
  "heap_to_device_data psp (\<lambda>x. if x \<in> S then v else f x)
     = (\<lambda>x. if x \<in> S \<inter> dom (map_to_user_data_device psp) then Some (K (word_rcat [v, v, v, v]))
             else heap_to_device_data psp f x)"
  apply (rule ext)
  apply (simp add: heap_to_device_data_def Let_def
            split: if_split)
  apply (rule conjI)
   apply (clarsimp simp: byte_to_word_heap_def Let_def add.assoc
                 intro!: ext)
   apply (subst foo, assumption+,
          (rule word_add_offset_less[where n=2, simplified]
                word_add_offset_less[where n=2 and y=0, simplified],
           simp_all, rule ucast_less,
           simp_all add: word_bits_def pageBits_def
                         order_less_le_trans[OF ucast_less])[1])+
   apply simp
  apply clarsimp
  apply (case_tac "map_to_user_data_device psp x")
   apply simp
  apply (clarsimp simp: dom_def byte_to_word_heap_def Let_def add.assoc
                intro!: ext)
  apply (subst foo, assumption,
         (rule word_add_offset_less[where n=2, simplified]
               word_add_offset_less[where n=2 and y=0, simplified],
          simp_all, rule ucast_less,
          simp_all add: word_bits_def pageBits_def
                        order_less_le_trans[OF ucast_less])[1])+
  apply (simp add: field_simps)
  done

(* FIXME: move *)
lemma ccorres_grab_asm:
  "(Q \<Longrightarrow> ccorres_underlying sr G rr xf ar ax P P' hs f g) \<Longrightarrow>
   ccorres_underlying sr G rr xf ar ax (P and K Q) P' hs f g"
  by (fastforce simp: ccorres_underlying_def)

lemma ksPSpace_ksMSu_comm:
  "ksPSpace_update f (ksMachineState_update g s) =
   ksMachineState_update g (ksPSpace_update f s)"
  by simp

lemma ksPSpace_update_ext:
  "(\<lambda>s. s\<lparr>ksPSpace := f (ksPSpace s)\<rparr>) = (ksPSpace_update f)"
  by (rule ext) simp

(* FIXME: move *)
lemma valid_untyped':
  notes usableUntypedRange.simps[simp del]
  assumes pspace_distinct': "pspace_distinct' s" and
           pspace_aligned': "pspace_aligned' s" and
                        al: "is_aligned ptr bits"
  shows "valid_untyped' d ptr bits idx s =
         (\<forall>p ko. ksPSpace s p = Some ko \<longrightarrow>
                 obj_range' p ko \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {} \<longrightarrow>
                 obj_range' p ko \<subseteq> {ptr..ptr + 2 ^ bits - 1} \<and>
                 obj_range' p ko \<inter>
                   usableUntypedRange (UntypedCap d ptr bits idx) = {})"
  apply (simp add: valid_untyped'_def)
  apply (simp add: ko_wp_at'_def)
  apply (rule arg_cong[where f=All])
  apply (rule ext)
  apply (rule arg_cong[where f=All])
  apply (rule ext)
  apply (case_tac "ksPSpace s ptr' = Some ko", simp_all)
  apply (frule pspace_alignedD'[OF _ pspace_aligned'])
  apply (frule pspace_distinctD'[OF _ pspace_distinct'])
  apply simp
  apply (frule aligned_ranges_subset_or_disjoint[OF al])
  apply (fold obj_range'_def)
  apply (rule iffI)
   apply auto[1]
  apply (rule conjI)
   apply (rule ccontr, simp)
   apply (simp add: Set.psubset_eq)
   apply (erule conjE)
   apply (case_tac "obj_range' ptr' ko \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {}", simp)
   apply (cut_tac is_aligned_no_overflow[OF al])
   apply (auto simp add: obj_range'_def)[1]
  apply (clarsimp simp add: usableUntypedRange.simps Int_commute)
  apply (case_tac "obj_range' ptr' ko \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {}", simp+)
  apply (cut_tac is_aligned_no_overflow[OF al])
  apply (clarsimp simp add: obj_range'_def)
  apply (frule is_aligned_no_overflow)
  by (metis al intvl_range_conv' le_m1_iff_lt less_is_non_zero_p1
               nat_le_linear power_overflow sub_wrap add_0
               add_0_right word_add_increasing word_less_1 word_less_sub_1)

lemma hrs_ghost_update_comm:
  "(t_hrs_'_update f \<circ> ghost'state_'_update g) =
   (ghost'state_'_update g \<circ> t_hrs_'_update f)"
  by (rule ext) simp

lemma htd_safe_typ_clear_region:
  "htd_safe S htd \<Longrightarrow> htd_safe S (typ_clear_region ptr bits htd)"
  apply (clarsimp simp: htd_safe_def dom_s_def typ_clear_region_def)
  apply (simp add: subset_iff)
  apply blast
  done

lemma htd_safe_typ_region_bytes:
  "htd_safe S htd \<Longrightarrow> {ptr ..+ 2 ^ bits} \<subseteq> S \<Longrightarrow> htd_safe S (typ_region_bytes ptr bits htd)"
  apply (clarsimp simp: htd_safe_def dom_s_def typ_region_bytes_def)
  apply (simp add: subset_iff)
  apply blast
  done

lemma untyped_cap_rf_sr_ptr_bits_domain:
  "cte_wp_at' (\<lambda>cte. cteCap cte = capability.UntypedCap d ptr bits idx) p s
    \<Longrightarrow> invs' s \<Longrightarrow> (s, s') \<in> rf_sr
    \<Longrightarrow> {ptr..+2 ^ bits} \<subseteq> domain"
  apply (clarsimp simp: cte_wp_at_ctes_of)
  apply (frule ctes_of_valid', clarsimp)
  apply (drule valid_global_refsD', clarsimp)
  apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def
                        valid_cap'_def capAligned_def)
  apply (simp only: upto_intvl_eq)
  apply blast
  done

lemma aligned_ranges_subset_or_disjoint_coroll:
  "\<lbrakk> is_aligned (p :: 'a :: len word) n; is_aligned (p' :: 'a :: len word) n';
        p && ~~ mask n' \<noteq> p'; p' && ~~ mask n \<noteq> p \<rbrakk>
     \<Longrightarrow> {p .. p + 2 ^ n - 1} \<inter> {p' .. p' + 2 ^ n' - 1} = {}"
  using aligned_ranges_subset_or_disjoint
  apply (simp only: mask_in_range)
  apply (subgoal_tac "p \<in> {p .. p + 2 ^ n - 1} \<and> p' \<in> {p' .. p' + 2 ^ n' - 1}")
   apply blast
  apply simp
  done

lemma neg_mask_twice:
  "x && ~~ mask n && ~~ mask m = x && ~~ mask (max n m)"
  by (metis word_bw_assocs neg_mask_combine)

lemma multiple_mask_trivia: "n \<ge> m
    \<Longrightarrow> (x && ~~ mask n) + (x && mask n && ~~ mask m) = x && ~~ mask m"
  apply (rule trans[rotated], rule_tac w="mask n" in word_plus_and_or_coroll2)
  apply (simp add: word_bw_assocs word_bw_comms word_bw_lcs neg_mask_twice
                   max_absorb2)
  done

lemma distinct_aligned_addresses_accumulate:
  "is_aligned p n \<Longrightarrow> is_aligned ptr bits
    \<Longrightarrow> n \<ge> m \<Longrightarrow> n < size p \<Longrightarrow> m \<le> bits
    \<Longrightarrow> (\<forall>y<2 ^ (n - m). p + (y << m) \<notin> {ptr..ptr + 2 ^ bits - 1})
    \<Longrightarrow> {p .. p + 2 ^ n - 1} \<inter> {ptr..ptr + 2 ^ bits - 1} = {}"
  apply safe
  apply (simp only: mask_in_range[symmetric])
  apply (drule_tac x="(x && mask n) >> m" in spec)
  apply (simp add: shiftr_shiftl1 word_bw_assocs)
  apply (drule mp, rule shiftr_less_t2n)
   apply (subst add_diff_inverse, simp, rule and_mask_less', simp add: word_size)
  apply (clarsimp simp: multiple_mask_trivia word_bw_assocs neg_mask_twice max_absorb2)
  done

lemma offs_in_intvl_iff:
  "(p + x \<in> {p ..+ n}) = (unat x < n)"
  apply (simp add: intvl_def, safe)
   apply (erule order_le_less_trans[rotated], simp add: unat_of_nat)
  apply (rule exI, erule conjI[rotated])
  apply simp
  done

lemma objBits_koTypeOf:
  fixes v :: "'a :: pspace_storable" shows
  "objBits v = objBitsT (koType TYPE('a))"
  using project_inject[where v=v, THEN iffD2, OF refl]
      project_koType[THEN iffD1, OF exI[where x=v]]
  by (simp add: objBits_def objBitsT_koTypeOf[symmetric])

lemma cmap_array_typ_region_bytes:
  "ptrf = (Ptr :: _ \<Rightarrow> 'b ptr)
    \<Longrightarrow> carray_map_relation bits' amap (h_t_valid htd c_guard) ptrf
    \<Longrightarrow> is_aligned ptr bits
    \<Longrightarrow> typ_uinfo_t TYPE('b :: c_type) \<noteq> typ_uinfo_t TYPE(8 word)
    \<Longrightarrow> size_of TYPE('b) = 2 ^ bits'
    \<Longrightarrow> objBitsT (koType TYPE('a :: pspace_storable)) \<le> bits
    \<Longrightarrow> objBitsT (koType TYPE('a :: pspace_storable)) \<le> bits'
    \<Longrightarrow> bits' < word_bits
    \<Longrightarrow> carray_map_relation bits' (restrict_map (amap :: _ \<Rightarrow> 'a option) (- {ptr ..+ 2 ^ bits}))
        (h_t_valid (typ_region_bytes ptr bits htd) c_guard) ptrf"
  apply (clarsimp simp: carray_map_relation_def h_t_valid_typ_region_bytes)
  apply (case_tac "h_t_valid htd c_guard (ptrf p)", simp_all)
   apply (clarsimp simp: objBits_koTypeOf)
   apply (drule spec, drule(1) iffD2, clarsimp)
   apply (rule iffI[rotated])
    apply clarsimp
    apply (drule equals0D, erule notE, erule IntI[rotated])
    apply (simp only: upto_intvl_eq is_aligned_neg_mask2 mask_in_range[symmetric])
   apply (simp only: upto_intvl_eq, rule distinct_aligned_addresses_accumulate,
     simp_all add: upto_intvl_eq[symmetric] word_size word_bits_def)
   apply clarsimp
   apply (drule_tac x="p + (y << objBitsT (koType TYPE('a)))" in spec)+
   apply (simp add: is_aligned_add[OF is_aligned_weaken is_aligned_shiftl])
   apply (simp add: is_aligned_add_helper shiftl_less_t2n word_bits_def)
  apply clarsimp
  apply (drule_tac x=p in spec)
  apply (clarsimp simp: objBits_koTypeOf)
  apply auto
  done

lemma map_comp_restrict_map:
  "(f \<circ>\<^sub>m (restrict_map m S)) = (restrict_map (f \<circ>\<^sub>m m) S)"
  by (rule ext, simp add: restrict_map_def map_comp_def)

lemma size_td_uinfo_array_tag_n_m[simp]:
  "size_td (uinfo_array_tag_n_m (ta :: ('a :: c_type) itself) n m)
    = size_of (TYPE('a)) * n"
  apply (induct n)
   apply (simp add: uinfo_array_tag_n_m_def)
  apply (simp add: uinfo_array_tag_n_m_def size_of_def)
  done

lemma modify_machinestate_assert_cnodes_swap:
  "do x \<leftarrow> modify (ksMachineState_update f);
    y \<leftarrow> stateAssert (\<lambda>s. \<not> cNodePartialOverlap (gsCNodes s) S) []; g od
    = do y \<leftarrow> stateAssert (\<lambda>s. \<not> cNodePartialOverlap (gsCNodes s) S) [];
        x \<leftarrow> modify (ksMachineState_update f); g od"
  by (simp add: fun_eq_iff exec_modify stateAssert_def
                bind_assoc exec_get assert_def)

lemma h_t_array_valid_typ_region_bytes:
  "h_t_array_valid htd (p :: ('a :: c_type) ptr) n
    \<Longrightarrow> {ptr_val p..+n * size_of TYPE('a)} \<inter> {ptr..+2 ^ bits} = {}
    \<Longrightarrow> h_t_array_valid (typ_region_bytes ptr bits htd) p n"
  apply (clarsimp simp: h_t_array_valid_def)
  apply (subst valid_footprint_typ_region_bytes)
   apply (simp add: uinfo_array_tag_n_m_def typ_uinfo_t_def typ_info_word)
  apply (simp add: field_simps)
  done

lemma cvariable_array_map_relation_detype:
  "cvariable_array_map_relation mp szs ptrfun htd
    \<Longrightarrow> ptrfun = (Ptr :: _ \<Rightarrow> ('a :: c_type ptr))
    \<Longrightarrow> \<forall>p v. mp p = Some v \<longrightarrow> p \<notin> {ptr ..+ 2 ^ bits}
        \<longrightarrow> {p ..+ szs v * size_of TYPE('a)} \<inter> {ptr ..+ 2 ^ bits} = {}
    \<Longrightarrow> cvariable_array_map_relation (mp |` (- {ptr..+2 ^ bits}))
        szs ptrfun (typ_region_bytes ptr bits htd)"
  apply (clarsimp simp: cvariable_array_map_relation_def restrict_map_def)
  apply (elim allE, (drule(1) mp)+)
  apply (simp add: h_t_array_valid_typ_region_bytes)
  done

lemma zero_ranges_are_zero_typ_region_bytes:
  "zero_ranges_are_zero rs hrs
    \<Longrightarrow> zero_ranges_are_zero rs (hrs_htd_update (typ_region_bytes ptr bits) hrs)"
  apply (clarsimp simp: zero_ranges_are_zero_def)
  apply (drule(1) bspec)
  apply (clarsimp simp: region_actually_is_bytes'_def typ_region_bytes_def hrs_htd_update)
  done

lemma deleteObjects_ccorres':
  notes if_cong[cong]
  shows
  "ccorres dc xfdc
     (cte_wp_at' (\<lambda>cte. cteCap cte = capability.UntypedCap d ptr bits idx) p and
      (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) and
      invs' and ct_active' and sch_act_simple and
      K ( 2 \<le> bits \<and> bits < word_bits))
     UNIV hs
     (deleteObjects ptr bits)
     (Basic (\<lambda>s. globals_update
       (t_hrs_'_update (hrs_htd_update (typ_region_bytes ptr bits)) \<circ>
        ghost'state_'_update (gs_clear_region ptr bits)) s))"
  apply (rule ccorres_grab_asm)
  apply (rule ccorres_name_pre)
  apply (simp add: deleteObjects_def3 hrs_ghost_update_comm)
  apply (rule ccorres_assert)
  apply (rule ccorres_stateAssert_fwd)
  apply (subst bind_assoc[symmetric])
  apply (unfold freeMemory_def)
  apply (subst ksPSpace_update_ext)
  apply (subgoal_tac "bits \<le> word_bits")
  prefer 2
   apply (clarsimp simp:cte_wp_at_ctes_of)
  apply (clarsimp simp: mapM_x_storeWord_step[simplified word_size_bits_def]
             intvl_range_conv intvl_range_conv[where 'a=32, folded word_bits_def]
             doMachineOp_modify modify_modify o_def ksPSpace_ksMSu_comm
             bind_assoc modify_machinestate_assert_cnodes_swap
             modify_modify_bind)
  apply (rule ccorres_stateAssert_fwd)
  apply (rule ccorres_stateAssert_after)
  apply (rule ccorres_from_vcg)
  apply (rule allI, rule conseqPre, vcg)
  apply (clarsimp simp: in_monad)
  apply (rule bexI [rotated])
   apply (rule iffD2 [OF in_monad(20)])
   apply (rule conjI [OF refl refl])
  apply (clarsimp simp: simpler_modify_def)
proof -
  let ?mmu = "(\<lambda>h x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then 0 else h x)"
  let ?psu = "(\<lambda>h x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then None else h x)"

  fix s s'
  assume al: "is_aligned ptr bits"
    and cte: "cte_wp_at' (\<lambda>cte. cteCap cte = UntypedCap d ptr bits idx) p s"
    and desc_range: "descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)"
    and invs: "invs' s" and "ct_active' s"
    and "sch_act_simple s" and wb: "bits < word_bits" and b2: "2 \<le> bits"
    and "deletionIsSafe ptr bits s"
    and cNodePartial: "\<not> cNodePartialOverlap (gsCNodes s)
        (\<lambda>x. ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1)"
    and sr: "(s, s') \<in> rf_sr"
    and safe_asids:
          "ksASIDMapSafe
            (gsCNodes_update (\<lambda>_. ?psu (gsCNodes s))
              (gsUserPages_update
                (\<lambda>_. ?psu (gsUserPages s))
                (ksMachineState_update
                  (underlying_memory_update ?mmu)
                  (s\<lparr>ksPSpace := ?psu (ksPSpace s) \<rparr>))))" (is "ksASIDMapSafe ?t")

  interpret D: delete_locale s ptr bits p
    apply (unfold_locales)
      apply fact+
    done

  let ?ks = "?psu (ksPSpace s)"
  let ?ks' = "ksPSpace s |` (- {ptr..+2 ^ bits})"

  have psu_restrict: "\<forall>h. ?psu h = h |` (- {ptr..+2 ^ bits})"
    apply (intro allI ext)
    apply (subst upto_intvl_eq [OF al])
    apply (clarsimp)
    done

  have ks': "?ks = ?ks'" by (simp add: psu_restrict)

  let ?th = "hrs_htd_update (typ_region_bytes ptr bits)"
  let ?th_s = "?th (t_hrs_' (globals s'))"

  have map_to_ctes_delete':
    "map_to_ctes ?ks' = ctes_of s |` (- {ptr..+2 ^ bits})" using invs
    apply (subst ks' [symmetric])
    apply (subst map_to_ctes_delete [OF D.valid_untyped, simplified field_simps])
     apply clarsimp
    apply (rule ext)
    apply (subst upto_intvl_eq [OF al])
    apply clarsimp
    done

  note cm_disj = cmap_relation_disjoint [OF D.valid_untyped invs, atomize]
  note cm_disj_tcb = cmap_relation_disjoint_tcb [OF D.valid_untyped invs]
  note cm_disj_cte = cmap_relation_disjoint_cte [OF D.valid_untyped invs]
  note cm_disj_user = cmap_relation_disjoint_user_data [OF D.valid_untyped invs]
  note cm_disj_device = cmap_relation_disjoint_device_data [OF D.valid_untyped invs]

  have rl: "\<forall>(p :: word32) P. ko_wp_at' P p s \<and>
            (\<forall>ko. P ko \<longrightarrow> live' ko) \<longrightarrow> p \<notin> {ptr..ptr + 2 ^ bits - 1}"
    apply (intro allI impI conjI)
    apply (elim conjE)
    apply (erule D.live_notRange [simplified field_simps])
    apply clarsimp
    done

  note cmaptcb = cmap_relation_tcb [OF sr]
  note cmap_array_helper = arg_cong2[where f=carray_map_relation, OF refl map_comp_restrict_map]
  have trivia: "size_of TYPE(pte_C[256]) = 2 ^ ptBits"
               "size_of TYPE(pde_C[4096]) = 2 ^ pdBits"
    by (auto simp: ptBits_def pageBits_def pdBits_def)
  note cmap_array = cmap_array_typ_region_bytes[where 'a=pte, OF refl _ al _ trivia(1)]
     cmap_array_typ_region_bytes[where 'a=pde, OF refl _ al _ trivia(2)]
  note cmap_array = cmap_array[simplified, simplified objBitsT_simps b2
        ptBits_def pdBits_def pageBits_def word_bits_def, simplified]

  note pspace_distinct' = invs_pspace_distinct'[OF invs] and
       pspace_aligned' = invs_pspace_aligned'[OF invs] and
       valid_objs' = invs_valid_objs'[OF invs] and
       valid_untyped'_def2 =
         valid_untyped'[OF pspace_distinct' pspace_aligned' al]

  have s_ksPSpace_adjust: "ksPSpace_update ?psu s = s\<lparr>ksPSpace := ?psu (ksPSpace s)\<rparr>"
    by simp

  from invs have "valid_global_refs' s" by fastforce
  with cte
  have ptr_refs: "kernel_data_refs \<inter> {ptr..ptr + 2 ^ bits - 1} = {}"
    by (fastforce simp: valid_global_refs'_def valid_refs'_def cte_wp_at_ctes_of ran_def)

  (* calculation starts here *)
  have cs: "cpspace_relation (ksPSpace s) (underlying_memory (ksMachineState s))
                             (t_hrs_' (globals s'))"
    using sr
    by (clarsimp simp: rf_sr_def cstate_relation_def Let_def)
  hence "cpspace_relation ?ks' (underlying_memory (ksMachineState s)) ?th_s"
    unfolding cpspace_relation_def
    using cendpoint_relation_restrict [OF D.valid_untyped invs rl]
      cnotification_relation_restrict [OF D.valid_untyped invs rl]
    apply -
    apply (elim conjE)
    apply ((subst lift_t_typ_region_bytes,
            rule cm_disj cm_disj_tcb cm_disj_cte cm_disj_user cm_disj_device
            , assumption +,
            simp_all add: objBits_simps archObjSize_def pageBits_def projectKOs
                          heap_to_user_data_restrict heap_to_device_data_restrict)[1])+ -- "waiting ..."
    apply (simp add: map_to_ctes_delete' cmap_relation_restrict_both_proj
                     cmap_relation_restrict_both cmap_array_helper hrs_htd_update
                     ptBits_def pdBits_def pageBits_def cmap_array)
    apply (intro conjI)
       apply (frule cmap_relation_restrict_both_proj
                      [where f = tcb_ptr_to_ctcb_ptr])
        apply simp
       apply (erule iffD1[OF cpspace_tcb_relation_address_subset,
                           OF D.valid_untyped invs cmaptcb])
      apply (subst cmap_relation_cong [OF refl refl,
                      where rel' = "cendpoint_relation (cslift s')"])
       apply (clarsimp simp: restrict_map_Some_iff image_iff
                             map_comp_restrict_map_Some_iff)
      apply (simp add: cmap_relation_restrict_both_proj)
     apply (subst cmap_relation_cong[OF refl refl,
                    where rel' = "cnotification_relation (cslift s')"])
      apply (clarsimp simp: restrict_map_Some_iff image_iff
                            map_comp_restrict_map_Some_iff)
     apply (simp add: cmap_relation_restrict_both_proj)
    done

  moreover
  from invs have "valid_queues s" ..
  hence "\<And>p. \<forall>t \<in> set (ksReadyQueues s p). tcb_at' t s \<and> ko_wp_at' live' t s"
    apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def)
    apply (drule spec, drule spec)
    apply clarsimp
    apply (drule (1) bspec)
    apply (rule conjI)
    apply (erule obj_at'_weakenE)
    apply simp
    apply (simp add: obj_at'_real_def)
    apply (erule ko_wp_at'_weakenE)
    apply (clarsimp simp: projectKOs inQ_def)
    done
  hence tat: "\<And>p. \<forall>t \<in> set (ksReadyQueues s p). tcb_at' t s"
    and  tlive: "\<And>p. \<forall>t \<in> set (ksReadyQueues s p). ko_wp_at' live' t s"
    by auto
  from sr have
    "cready_queues_relation (clift ?th_s)
        (ksReadyQueues_' (globals s')) (ksReadyQueues s)"
    unfolding cready_queues_relation_def rf_sr_def cstate_relation_def
              cpspace_relation_def
    apply (clarsimp simp: Let_def all_conj_distrib)
    apply (drule spec, drule spec, drule mp)
    apply fastforce
    apply ((subst lift_t_typ_region_bytes, rule cm_disj_tcb, assumption+,
      simp_all add: objBits_simps archObjSize_def pageBits_def projectKOs)[1])+
      -- "waiting ..."
    apply (simp add: tcb_queue_relation_live_restrict
                     [OF D.valid_untyped tat tlive rl])
    done

  moreover

  { assume asid_map:
    "asid_map_pd_to_hwasids (armKSASIDMap (ksArchState s)) =
       set_option \<circ> (pde_stored_asid \<circ>\<^sub>m cslift s' \<circ>\<^sub>m pd_pointer_to_asid_slot)"

    hence asid:
      "\<And>p pd_ptr pde. \<lbrakk> cslift s' (pde_Ptr p) = Some pde;
                        pd_pointer_to_asid_slot pd_ptr = Some (pde_Ptr p);
                        pde_stored_asid pde \<noteq> None \<rbrakk> \<Longrightarrow>
      \<exists>asid. (asid, pd_ptr) \<in> ran (armKSASIDMap (ksArchState s))"
      apply -
      apply (drule_tac x=pd_ptr in fun_cong)
      apply (clarsimp simp: map_comp_def)
      apply (clarsimp simp: asid_map_pd_to_hwasids_def)
      apply (drule equalityD2)
      apply fastforce
      done

    from safe_asids
    have pds:
      "\<And>p asid pd_ptr. armKSASIDMap (ksArchState (s\<lparr>ksPSpace := ?ks\<rparr>)) p =
                        Some (asid, pd_ptr) \<Longrightarrow>
                        page_directory_at' pd_ptr (s\<lparr>ksPSpace := ?ks\<rparr>)"
      by (clarsimp simp: ksASIDMapSafe_def)

    from cs
    have clift:
      "\<And>p. clift (hrs_htd_update (typ_region_bytes ptr bits)
                                  (t_hrs_' (globals s'))) (p::pde_C ptr) =
           (if p \<in> pde_Ptr ` {ptr..+2 ^ bits} then None else cslift s' p)"
      apply (subst lift_t_typ_region_bytes[OF cm_disj], simp_all)
        apply (fastforce simp: cpspace_relation_def)
       apply (simp add: projectKOs)
      apply (simp add: objBits_simps archObjSize_def)
      done

    have "set_option \<circ> (pde_stored_asid \<circ>\<^sub>m cslift s' \<circ>\<^sub>m pd_pointer_to_asid_slot) =
      set_option \<circ> (pde_stored_asid \<circ>\<^sub>m clift ?th_s \<circ>\<^sub>m
            pd_pointer_to_asid_slot)"
      apply -
      apply (rule ext)
      apply (rename_tac pd_ptr)
      apply (clarsimp simp: map_comp_def)
      apply (simp add: clift split: option.splits)
      apply clarsimp
      apply (rule ccontr)
      apply (drule (2) asid)
      apply (clarsimp simp: ran_def pd_pointer_to_asid_slot_def split: if_split_asm)
      apply (subgoal_tac "armKSASIDMap (ksArchState (s\<lparr>ksPSpace := ?ks\<rparr>)) a = Some (asid, pd_ptr)")
       prefer 2
       apply simp
      apply (drule pds)
      apply (subgoal_tac "pde_at' (pd_ptr + 0x3FC0) (s\<lparr>ksPSpace := ?ks\<rparr>)")
       apply (cut_tac p="pd_ptr + 0x3FC0" in D.typ_at' [of "ArchT PDET", simplified field_simps])
       apply (simp add: upto_intvl_eq [OF al])
      apply (clarsimp simp: page_directory_at'_def)
      apply (erule_tac x="0xFF0" in allE)
      apply simp
      done
  }
  moreover
  {
    assume "s' \<Turnstile>\<^sub>c (Ptr::(32 word \<Rightarrow> (pde_C[4096]) ptr)) (symbol_table ''armKSGlobalPD'')"
    moreover
    from sr ptr_refs have "ptr_span (pd_Ptr (symbol_table ''armKSGlobalPD''))
      \<inter> {ptr..ptr + 2 ^ bits - 1} = {}"
      by (fastforce simp: rf_sr_def cstate_relation_def Let_def)
    ultimately
    have "hrs_htd (hrs_htd_update (typ_region_bytes ptr bits) (t_hrs_' (globals s')))
      \<Turnstile>\<^sub>t (Ptr::(32 word \<Rightarrow> (pde_C[4096]) ptr)) (symbol_table ''armKSGlobalPD'')"
      using al wb
      apply (cases "t_hrs_' (globals s')")
      apply (simp add: hrs_htd_update_def hrs_htd_def h_t_valid_typ_region_bytes upto_intvl_eq)
      done
  }

  moreover
  have h2ud_eq:
       "heap_to_user_data (?psu (ksPSpace s))
                          (?mmu (underlying_memory (ksMachineState s))) =
        heap_to_user_data (?psu (ksPSpace s))
                          (underlying_memory (ksMachineState s))"
    apply (subst heap_to_user_data_update_region
                 [where S="{ptr..ptr + 2 ^ bits - 1}", simplified])
     prefer 2
     apply (rule ext)
     apply clarsimp
    apply (simp add: map_option_def map_comp_def
              split: if_split_asm option.splits)
    apply (frule pspace_alignedD'[OF _ pspace_aligned'])
    apply (case_tac "pageBits \<le> bits")
     apply (simp add: objBitsKO_def projectKOs  split: kernel_object.splits)
     apply clarsimp
     apply (rule aligned_range_offset_mem_helper
       [where 'a=32, folded word_bits_def, simplified, OF _ _ al _ wb])
       apply assumption+
    apply (rule iffI[rotated], simp)
    apply (simp add: objBits_simps projectKOs)
    apply (rule FalseE)
    apply (case_tac "ptr \<le> x", simp)
     apply clarsimp
     apply (frule_tac y="ptr + 2 ^ bits - 1" in le_less_trans)
      apply (simp only: not_le)
     apply (drule (1) is_aligned_no_wrap')
     apply simp
    apply (cut_tac cte[simplified cte_wp_at_ctes_of])
    apply clarsimp
    apply (frule ctes_of_valid'[OF _ valid_objs'])
    apply (frule pspace_distinctD'[OF _ pspace_distinct'])
    apply (clarsimp simp add: valid_cap'_def valid_untyped'_def2 capAligned_def)
    apply (drule_tac x=x in spec)
    apply (simp add: obj_range'_def objBitsKO_def)
    apply (simp only: not_le)
    apply (cut_tac is_aligned_no_overflow[OF al])
    apply (case_tac "ptr \<le> x + 2 ^ pageBits - 1",
           simp_all only: simp_thms not_le)
    apply clarsimp
    apply (thin_tac "psp = Some ko" for psp ko)+
    apply (thin_tac "ps_clear x y z" for x y z)
    apply (thin_tac "cteCap x = y" for x y)+
    apply (frule is_aligned_no_overflow)
    apply (simp only: x_power_minus_1)
    apply (frule_tac x=x in word_plus_strict_mono_right[of _ "2^pageBits"])
     apply (rule ccontr)
     apply (simp only: not_le)
     apply (frule_tac y="x" in less_le_trans, assumption)
     apply (simp add: field_simps word_sub_less_iff)
    apply simp
    done
  moreover
  have h2dd_eq:
       "heap_to_device_data (?psu (ksPSpace s))
                          (?mmu (underlying_memory (ksMachineState s))) =
        heap_to_device_data (?psu (ksPSpace s))
                          (underlying_memory (ksMachineState s))"
    apply (subst heap_to_device_data_update_region
                 [where S="{ptr..ptr + 2 ^ bits - 1}", simplified])
     prefer 2
     apply (rule ext)
     apply clarsimp
    apply (simp add: map_option_def map_comp_def
              split: if_split_asm option.splits)
    apply (frule pspace_alignedD'[OF _ pspace_aligned'])
    apply (case_tac "pageBits \<le> bits")
     apply (simp add: objBitsKO_def projectKOs  split: kernel_object.splits)
     apply clarsimp
     apply (rule aligned_range_offset_mem_helper
       [where 'a=32, folded word_bits_def, simplified, OF _ _ al _ wb])
       apply assumption+
    apply (rule iffI[rotated], simp)
    apply (simp add: objBits_simps projectKOs)
    apply (rule FalseE)
    apply (case_tac "ptr \<le> x", simp)
     apply clarsimp
     apply (frule_tac y="ptr + 2 ^ bits - 1" in le_less_trans)
      apply (simp only: not_le)
     apply (drule (1) is_aligned_no_wrap')
     apply simp
    apply (cut_tac cte[simplified cte_wp_at_ctes_of])
    apply clarsimp
    apply (frule ctes_of_valid'[OF _ valid_objs'])
    apply (frule pspace_distinctD'[OF _ pspace_distinct'])
    apply (clarsimp simp add: valid_cap'_def valid_untyped'_def2 capAligned_def)
    apply (drule_tac x=x in spec)
    apply (simp add: obj_range'_def objBitsKO_def)
    apply (simp only: not_le)
    apply (cut_tac is_aligned_no_overflow[OF al])
    apply (case_tac "ptr \<le> x + 2 ^ pageBits - 1",
           simp_all only: simp_thms not_le)
    apply clarsimp
    apply (thin_tac "psp = Some ko" for psp ko)+
    apply (thin_tac "ps_clear x y z" for x y z)
    apply (thin_tac "cteCap x = y" for x y)+
    apply (frule is_aligned_no_overflow)
    apply (simp only: x_power_minus_1)
    apply (frule_tac x=x in word_plus_strict_mono_right[of _ "2^pageBits"])
     apply (rule ccontr)
     apply (simp only: not_le)
     apply (frule_tac y="x" in less_le_trans, assumption)
     apply (simp add: field_simps word_sub_less_iff)
    apply simp
    done

  moreover {
    from D.valid_untyped invs have tcb_no_overlap:
      "\<And>p v. map_to_tcbs (ksPSpace s) p = Some v
        \<Longrightarrow> p \<notin> {ptr..+2 ^ bits}
        \<Longrightarrow> {p ..+ 2 ^ objBitsT TCBT} \<inter> {ptr..+2 ^ bits} = {}"
      apply (clarsimp simp: valid_cap'_def)
      apply (drule(1) map_to_ko_atI')
      apply (clarsimp simp: obj_at'_def valid_untyped'_def2)
      apply (elim allE, drule(1) mp)
      apply (clarsimp simp only: obj_range'_def upto_intvl_eq[symmetric] al)
      apply (subgoal_tac "objBitsKO ko = objBitsT TCBT")
       apply (subgoal_tac "p \<in> {p ..+ 2 ^ objBitsT TCBT}")
        apply simp
        apply blast
       apply (simp add: upto_intvl_eq)
      apply (clarsimp simp: objBits_simps projectKOs objBitsT_simps)
      done

    note upto_rew = upto_intvl_eq[OF al, THEN eqset_imp_iff, symmetric, simplified]

    from cNodePartial[simplified upto_rew] have cn_no_overlap:
      "\<And>p n. gsCNodes s p = Some n \<Longrightarrow> p \<notin> {ptr..+2 ^ bits}
          \<Longrightarrow> {p ..+ 2 ^ (n + cte_level_bits)} \<inter> {ptr..+2 ^ bits} = {}"
      apply (simp add: cNodePartialOverlap_def)
      apply (elim allE, drule(1) mp)
      apply clarsimp
      apply (frule base_member_set, simp add: word_bits_def)
      apply (clarsimp simp only: upto_intvl_eq[symmetric] field_simps)
      apply blast
      done

    from sr have "cvariable_array_map_relation (gsCNodes s|\<^bsub>(- {ptr..+2 ^ bits})\<^esub>) (op ^ 2) cte_Ptr
       (typ_region_bytes ptr bits (hrs_htd (t_hrs_' (globals s'))))"
      "cvariable_array_map_relation (map_to_tcbs (ksPSpace s|\<^bsub>(- {ptr..+2 ^ bits})\<^esub>)) (\<lambda>x. 5) cte_Ptr
       (typ_region_bytes ptr bits (hrs_htd (t_hrs_' (globals s'))))"
      apply (simp_all add: map_comp_restrict_map rf_sr_def cstate_relation_def Let_def)
       apply (rule cvariable_array_map_relation_detype, clarsimp+)
       apply (drule(1) cn_no_overlap)
       apply (simp add: cte_level_bits_def power_add)
      apply (rule cvariable_array_map_relation_detype, clarsimp+)
      apply (drule(1) tcb_no_overlap)
      apply (erule disjoint_subset[rotated])
      apply (rule intvl_start_le)
      apply (simp add: objBitsT_simps)
      done
  }

  moreover from sr
    have "apsnd fst (gs_clear_region ptr bits (ghost'state_' (globals s'))) =
        (gsUserPages s|\<^bsub>(- {ptr..+2 ^ bits})\<^esub>, gsCNodes s|\<^bsub>(- {ptr..+2 ^ bits})\<^esub>)
        \<and> ghost_size_rel (gs_clear_region ptr bits (ghost'state_' (globals s')))
            (gsMaxObjectSize s)"
    apply (case_tac "ghost'state_' (globals s')")
    apply (simp add: rf_sr_def cstate_relation_def Let_def gs_clear_region_def
                  upto_intvl_eq[OF al] carch_state_relation_def
                  cmachine_state_relation_def ghost_size_rel_def
                  ghost_assertion_data_get_def restrict_map_def
                  if_flip[symmetric, where F=None])
    done

   moreover from sr have
     "h_t_valid (typ_region_bytes ptr bits (hrs_htd (t_hrs_' (globals s'))))
       c_guard (ptr_coerce (intStateIRQNode_' (globals s')) :: (cte_C[256]) ptr)"
    apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def)
    apply (simp add: h_t_valid_typ_region_bytes)
    apply (simp add: upto_intvl_eq al)
    apply (rule disjoint_subset[OF _ ptr_refs])
    apply (simp add: cinterrupt_relation_def cte_level_bits_def)
    done

  ultimately
  show "(?t, globals_update
               (%x. ghost'state_'_update (gs_clear_region ptr bits)
                      (t_hrs_'_update ?th x)) s') \<in> rf_sr"
    using sr untyped_cap_rf_sr_ptr_bits_domain[OF cte invs sr]
    by (clarsimp simp: rf_sr_def cstate_relation_def Let_def
                       psu_restrict cpspace_relation_def
                       carch_state_relation_def cmachine_state_relation_def
                       hrs_htd_update htd_safe_typ_region_bytes
                       zero_ranges_are_zero_typ_region_bytes)
qed

abbreviation (input)
  "global_htd_update f == Guard MemorySafety \<lbrace>htd_safe domain (hrs_htd \<acute>t_hrs)
        \<and> htd_safe domain (\<acute>(\<lambda>s. f s) (hrs_htd \<acute>t_hrs))\<rbrace>
    (Basic (\<lambda>s. globals_update (t_hrs_'_update (hrs_htd_update (f s))) s))"

lemma kernel_data_refs_domain_eq_rotate:
  "(kernel_data_refs = - domain) = (domain = - kernel_data_refs)"
  by blast

lemma deleteObjects_ccorres[corres]:
  "ccorres dc xfdc
     (cte_wp_at' (\<lambda>cte. cteCap cte = UntypedCap d ptr bits idx) p and
      (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) and
      invs' and ct_active' and sch_act_simple and
      K ( 2 \<le> bits \<and> bits < word_bits))
     UNIV hs
     (deleteObjects ptr bits)
     (Seq (global_htd_update (\<lambda>_. typ_region_bytes ptr bits))
          (Guard GhostStateError UNIV
             (Basic (\<lambda>s. globals_update
                (ghost'state_'_update (gs_clear_region ptr bits)) s))))"
  apply (rule ccorres_guard_imp2)
   apply (rule ccorres_Guard_Seq)
   apply (rule Corres_UL_C.ccorres_exec_cong[THEN iffD2,
                                             OF _ deleteObjects_ccorres'[where idx=idx and p=p and d=d]])
   apply (simp add: exec_Basic_Guard_UNIV o_def
                    hrs_ghost_update_comm[simplified o_def])
  apply clarsimp
  apply (frule(2) untyped_cap_rf_sr_ptr_bits_domain)
  by (clarsimp simp: rf_sr_def cstate_relation_def Let_def
                        kernel_data_refs_domain_eq_rotate htd_safe_typ_region_bytes
                        untyped_cap_rf_sr_ptr_bits_domain)

end
end


theory PhiSem_CF_Break
  imports Phi_System.PhiSem_Formalization_Tools
begin

section \<open>Semantic Model\<close>

subsection \<open>Abnormal\<close>

virtual_datatype \<phi>CF_break_abnormal = \<phi>empty_abnormal +
  ABN_break    :: unit

debt_axiomatization ABN_break :: \<open>unit abnormal_entry\<close>
  where \<phi>CF_break_abnormal_ax: \<open>\<phi>CF_break_abnormal ABN_CONS_OF ABN_break\<close>

interpretation \<phi>CF_break_abnormal ABN_CONS_OF _ _ ABN_break
  using \<phi>CF_break_abnormal_ax .

hide_fact \<phi>CF_break_abnormal_ax

subsection \<open>Resource of Scope Frames\<close>

setup \<open>Sign.mandatory_path "RES"\<close>

type_synonym brk_label = nat
type_synonym brk_frame = \<open>RES.brk_label \<rightharpoonup> VAL list option nosep\<close>

setup \<open>Sign.parent_path\<close>

resource_space \<phi>CF_break =
  brk_frame :: \<open>{frames::RES.brk_frame. finite (dom frames)}\<close> (partial_map_resource) ..

hide_fact RES.\<phi>CF_break_res_ax

subsection \<open>Fiction of Scope Frames\<close>

fiction_space \<phi>CF_break =
  brk_frame :: \<open>RES.brk_frame.basic_fiction \<F>_it\<close>
               (identity_fiction_for_partial_mapping_resource RES.brk_frame) ..

hide_fact FIC.\<phi>CF_break_fic_ax

section \<open>\<phi>-Types\<close>

(*
abbreviation Brk_Frame' :: \<open>brk_label \<Rightarrow> (VAL list option,'a) \<phi> \<Rightarrow> (fiction,'a) \<phi>\<close>
  where \<open>Brk_Frame' label T \<equiv> (FIC.brk_frame.\<phi> (label \<^bold>\<rightarrow> \<black_circle> (Nosep T)))\<close>
*)

definition Brk_Frame :: \<open>RES.brk_label \<Rightarrow> assn\<close>
  where \<open>Brk_Frame label \<equiv> () \<Ztypecolon> FIC.brk_frame.\<phi> (label \<^bold>\<rightarrow> \<black_circle> (Nosep \<circle>))\<close>

definition Brking_Frame :: \<open>RES.brk_label \<Rightarrow> ('v::VALs \<phi>arg \<Rightarrow> assn) \<Rightarrow> assn\<close> ("\<^bold>b\<^bold>r\<^bold>o\<^bold>k\<^bold>e\<^bold>n _ \<^bold>w\<^bold>i\<^bold>t\<^bold>h _" [1000,10] 3)
  where \<open>Brking_Frame label S =
     (\<exists>*v. S v\<heavy_comma> to_vals (\<phi>arg.dest v) \<Ztypecolon> FIC.brk_frame.\<phi> (label \<^bold>\<rightarrow> \<black_circle> (Nosep (\<black_circle> Identity))))\<close>

lemma Brk_Frame_eq_identity:
  \<open>Brk_Frame l = (nosep None \<Ztypecolon> FIC.brk_frame.\<phi> (l \<^bold>\<rightarrow> \<black_circle> Identity))\<close>
  unfolding set_eq_iff Brk_Frame_def
  by (simp add: \<phi>expns)

lemma Brking_Frame_eq_identity:
  \<open>Brking_Frame l S = (\<exists>*v. S v\<heavy_comma> nosep (Some (to_vals (\<phi>arg.dest v))) \<Ztypecolon> FIC.brk_frame.\<phi> (l \<^bold>\<rightarrow> \<black_circle> Identity))\<close>
  unfolding set_eq_iff Brking_Frame_def
  by (simp add: \<phi>expns)

section \<open>Instruction\<close>

definition op_brk_scope :: \<open>(RES.brk_label \<Rightarrow> ('a::VALs) proc) \<Rightarrow> 'a proc\<close>
  where \<open>op_brk_scope F =
    RES.brk_frame.\<phi>R_allocate_res_entry (\<lambda>_. True) (Some (nosep None)) (\<lambda>l.
    op_try
    (F l \<bind> (\<lambda>ret. RES.brk_frame.\<phi>R_set_res (\<lambda>f. f(l := None)) \<ggreater> Return ret))
    (\<lambda>a. RES.brk_frame.\<phi>R_get_res_entry l (\<lambda>brk.
      RES.brk_frame.\<phi>R_set_res (\<lambda>f. f(l := None)) \<ggreater>
     (case nosep.dest brk of Some vs \<Rightarrow> Return (\<phi>arg (from_vals vs))
                                | None \<Rightarrow> throw a)
)))
\<close>

definition op_break :: \<open>RES.brk_label \<Rightarrow> ('a::VALs, 'ret::VALs) proc'\<close>
  where \<open>op_break l = (\<lambda>vs.
     RES.brk_frame.\<phi>R_set_res (\<lambda>f. f(l \<mapsto> nosep (Some (to_vals (\<phi>arg.dest vs)))))
  \<ggreater> throw (ABN_break.mk ())
)\<close>

lemma op_break_reduce_tail[procedure_simps,simp]:
  \<open>(op_break L v \<ggreater> f) = op_break L v\<close>
  unfolding op_break_def by simp

definition \<open>sift_brking_frame' l Y E = (Brking_Frame l Y) + (E\<heavy_comma> Brk_Frame l)\<close>
definition sift_brking_frame ("\<^bold>b\<^bold>r\<^bold>e\<^bold>a\<^bold>k _/ \<^bold>w\<^bold>i\<^bold>t\<^bold>h _/ \<^bold>o\<^bold>r _" [1000,10,3] 3)
  where \<open>sift_brking_frame = sift_brking_frame'\<close>

declare sift_brking_frame'_def[folded sift_brking_frame_def, assertion_simps_source]

context begin

private lemma alloc_brk_scope[intro!]:
  \<open>(\<And>l. \<p>\<r>\<o>\<c> F l \<lbrace> X\<heavy_comma> Brk_Frame l \<longmapsto> Y \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E  )
\<Longrightarrow> \<p>\<r>\<o>\<c> RES.brk_frame.\<phi>R_allocate_res_entry (\<lambda>_. True) (Some (nosep None)) F
         \<lbrace> X \<longmapsto> Y \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E \<close>
  unfolding Brk_Frame_eq_identity
  by (rule; simp add: finite_map_freshness)

private lemma dispose_brk_scope:
  \<open>\<p>\<r>\<o>\<c> RES.brk_frame.\<phi>R_set_res (\<lambda>f. f(l := None)) \<lbrace> Brk_Frame l \<longmapsto> \<lambda>_. Void \<rbrace>\<close>
  unfolding Brk_Frame_eq_identity
  by (rule FIC.brk_frame.\<phi>R_dispose_res[where P=\<open>\<lambda>_. True\<close>]; simp)

lemma brk_scope:
  \<open> (\<And>l. \<p>\<r>\<o>\<c> f l \<lbrace> X\<heavy_comma> Brk_Frame l \<longmapsto> \<lambda>ret. Y ret\<heavy_comma> Brk_Frame l \<rbrace>
    \<t>\<h>\<r>\<o>\<w>\<s> (\<lambda>a. sift_brking_frame l Y' (E a)))
\<Longrightarrow> \<p>\<r>\<o>\<c> op_brk_scope f \<lbrace> X \<longmapsto> \<lambda>ret. Y ret + Y' ret \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E\<close>
  unfolding op_brk_scope_def sift_brking_frame_def sift_brking_frame'_def
  apply (rule, rule, rule, assumption, rule)
  apply (rule \<phi>CONSEQ'E0, rule dispose_brk_scope[THEN \<phi>frame, simplified], rule)
  apply (rule \<phi>CASE)
  apply (simp only: Brking_Frame_eq_identity norm_precond_ex, rule, rule, simp, rule)
  apply (rule FIC.brk_frame.\<phi>R_dispose_res_frm[where P=\<open>\<lambda>_. True\<close>]; simp)
  apply (rule)
  apply (simp only: Brk_Frame_eq_identity, rule, simp, rule)
  apply (rule \<phi>CONSEQ'E0, rule FIC.brk_frame.\<phi>R_dispose_res_frm[where P=\<open>\<lambda>_. True\<close>]; simp)
  by (rule, rule implies_refl)

lemma "_op_break_rule_":
  \<open>\<p>\<r>\<o>\<c> op_break l vs \<lbrace> S vs\<heavy_comma> Brk_Frame l \<longmapsto> 0 \<rbrace>
   \<t>\<h>\<r>\<o>\<w>\<s> (\<lambda>_. Brking_Frame l S)\<close>
  unfolding op_break_def Brking_Frame_eq_identity Brk_Frame_eq_identity
  by (rule, rule, simp, simp, simp, rule, \<phi>reason)

end

section \<open>Reasoning Processes\<close>

subsection \<open>sift brking frame\<close>

declare [[\<phi>reason_default_pattern
     \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' ?l ?Y ?E \<a>\<n>\<d> ?Any\<close>
  \<Rightarrow> \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' ?l _ _ \<a>\<n>\<d> _\<close> (100)
 and \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame ?l ?Y ?E \<a>\<n>\<d> ?Any\<close>
  \<Rightarrow> \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame ?l _ _ \<a>\<n>\<d> _\<close>  (100)]]

lemma [\<phi>reason 1010 for \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame ?l ?var_Y' ?var_E'\<close>]:
  \<open> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y E
\<Longrightarrow> \<s>\<i>\<m>\<p>\<l>\<i>\<f>\<y>[assertion_simps undefined] Y' : Y
\<Longrightarrow> \<s>\<i>\<m>\<p>\<l>\<i>\<f>\<y>[assertion_simps undefined] E' : E
\<Longrightarrow> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame  l Y' E'\<close>
  unfolding sift_brking_frame_def Simplify_def by simp

lemma [\<phi>reason 1000]:
  \<open> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y E
\<Longrightarrow> (\<And>v. Y v \<i>\<m>\<p>\<l>\<i>\<e>\<s> Y' v @action ToSA)
\<Longrightarrow> E \<i>\<m>\<p>\<l>\<i>\<e>\<s> E' @action ToSA
\<Longrightarrow> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame  l Y' E'\<close>
  unfolding sift_brking_frame_def Simplify_def Action_Tag_def sift_brking_frame'_def
            Brking_Frame_def
  \<medium_left_bracket> premises X and Y and E
    X cases \<medium_left_bracket> E[THEN implies_right_prod] \<medium_right_bracket> for \<open>(\<exists>*v. Y' v\<heavy_comma> to_vals (\<phi>arg.dest v) \<Ztypecolon> _) + (E'\<heavy_comma> Brk_Frame l)\<close> ..
            \<medium_left_bracket> Y[THEN implies_right_prod] \<medium_right_bracket> ..
  \<medium_right_bracket>. .

lemma [\<phi>reason 3000 for \<open>_ \<i>\<m>\<p>\<l>\<i>\<e>\<s> _ * \<blangle> sift_brking_frame ?l ?Y ?E \<brangle> \<a>\<n>\<d> _\<close>]:
  \<open> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame l Y E
\<Longrightarrow> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> 1 * \<blangle> sift_brking_frame l Y E \<brangle> \<a>\<n>\<d> True\<close>
  unfolding FOCUS_TAG_def Action_Tag_def
  by simp

lemma Brking_Frame_plus:
  \<open>Brking_Frame l (Y1 + Y2) = Brking_Frame l Y1 + Brking_Frame l Y2\<close>
  unfolding set_eq_iff Brking_Frame_def plus_fun_def distrib_right ExSet_plus by clarify

lemma [\<phi>reason 1200]:
  \<open> X1 \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y1 E1
\<Longrightarrow> X2 \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y2 E2
\<Longrightarrow> (X1 + X2) \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l (Y1 + Y2) (E1 + E2)\<close>
  unfolding sift_brking_frame'_def Brking_Frame_plus distrib_right
  \<medium_left_bracket> premises X1 and X2
    cases \<medium_left_bracket> X2 \<medium_right_bracket> for \<open>Brking_Frame l Y1 + Brking_Frame l Y2 + ((E1 \<heavy_comma> Brk_Frame l) + (E2 \<heavy_comma> Brk_Frame l))\<close> by fast
          \<medium_left_bracket> X1 \<medium_right_bracket>.
  \<medium_right_bracket>. .

(* lemma [\<phi>reason 1200]:
  \<open> X1 \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y E
\<Longrightarrow> X2 \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y E
\<Longrightarrow> X1 + X2 \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y E\<close>
  using \<phi>CASE_IMP by fastforce *)

lemma [\<phi>reason 1200]:
  \<open>Brking_Frame l Y \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y 0\<close>
  unfolding sift_brking_frame'_def \<medium_left_bracket> \<medium_right_bracket>. .

lemma Brking_Frame_absorb_item[assertion_simps]:
  \<open>((Brking_Frame l Y)\<heavy_comma> X) = Brking_Frame l (\<lambda>v. Y v \<heavy_comma> X)\<close>
  unfolding Brking_Frame_def
  apply (intro assertion_eq_intro)
  \<medium_left_bracket> ;; \<medium_right_bracket>. \<medium_left_bracket> \<medium_right_bracket>. .

lemma Brking_Frame_absorb_subj[assertion_simps]:
  \<open>((Brking_Frame l Y) \<s>\<u>\<b>\<j> P) = Brking_Frame l (\<lambda>v. Y v \<s>\<u>\<b>\<j> P)\<close>
  unfolding Brking_Frame_def
  apply (intro assertion_eq_intro)
  \<medium_left_bracket> \<medium_right_bracket>. \<medium_left_bracket> ;; \<medium_right_bracket>. .

lemma Brking_Frame_absorb_ex[assertion_simps]:
  \<open>(\<exists>*x. (Brking_Frame l (Y x))) = Brking_Frame l (\<lambda>v. \<exists>*x. Y x v)\<close>
  unfolding Brking_Frame_def
  apply (intro assertion_eq_intro)
  \<medium_left_bracket> \<medium_right_bracket>. \<medium_left_bracket> ;; \<medium_right_bracket>. .

lemma [\<phi>reason 1180]:
  \<open> NO_MATCH TYPE('a) TYPE('b)
\<Longrightarrow> ERROR TEXT(\<open>The exits of scope\<close> l \<open>mismach in return type. One is\<close>
                    TYPE('a) \<open>while another is\<close> TYPE('b))
\<Longrightarrow> Brking_Frame l Y \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l Y' 0\<close>
  for Y :: \<open>'a::VALs \<phi>arg \<Rightarrow> _\<close> and Y' :: \<open>'b::VALs \<phi>arg \<Rightarrow> _\<close>
  by blast

lemma [\<phi>reason 1000]:
  \<open> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> E\<heavy_comma> \<blangle> Brk_Frame l \<brangle> \<a>\<n>\<d> Any
\<Longrightarrow> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> sift_brking_frame' l 0 E\<close>
  unfolding sift_brking_frame'_def FOCUS_TAG_def
  \<medium_left_bracket> premises X
    X
  \<medium_right_bracket>. .

hide_fact Brking_Frame_plus

subsection \<open>ToSA through Brking_Frame\<close>

lemma [\<phi>reason 2200]:
  (*The priority must override Void Padding*)
  \<open> (\<And>v. S v \<i>\<m>\<p>\<l>\<i>\<e>\<s> R v \<heavy_comma> \<blangle> Y \<brangle> \<a>\<n>\<d> P)
\<Longrightarrow> Brking_Frame l S \<i>\<m>\<p>\<l>\<i>\<e>\<s> Brking_Frame l R \<heavy_comma> \<blangle> Y \<brangle> \<a>\<n>\<d> P\<close>
  unfolding Brking_Frame_def FOCUS_TAG_def
  \<medium_left_bracket> premises X
    X[THEN implies_right_prod]
  \<medium_right_bracket>. .

subsection \<open>Syntax hiding technical separation items\<close>

optional_translations (\<phi>hide_brk_frame)
  "L" <= "CONST Brk_Frame l\<heavy_comma> L"
  "R" <= "R \<heavy_comma> CONST Brk_Frame l"
  "R\<heavy_comma> L" <= "R \<heavy_comma> CONST Brk_Frame l\<heavy_comma> L"
  "XCONST Void" <= "CONST Brk_Frame l"
  \<open>Hides technical SL assertions for control flowing breaking\<close>

declare [[\<phi>hide_brk_frame = false]]

(*
ML \<open>
val phi_display_brk_frame = Attrib.setup_config_bool \<^binding>\<open>\<phi>display_brk_frame\<close> (K false)

val _ = Theory.setup (
  Procedure_Syntax.add_item_printer (\<^const_syntax>\<open>Brk_Frame\<close>, (fn m => fn ctxt => fn X =>
    if Config.get ctxt phi_display_brk_frame
    then raise Match
    else (case m of Phi_Kind.Procedure => NONE
                  | Phi_Kind.Construction => NONE)
)))
\<close> *)

section \<open>Example\<close>

proc
  input  \<open>x \<Ztypecolon> \<v>\<a>\<l> T\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> U\<close>
  output \<open>y \<Ztypecolon> \<v>\<a>\<l> U\<close>
  \<medium_left_bracket> brk_scope \<medium_left_bracket> for l1
      brk_scope \<medium_left_bracket> for l2
        $y "_op_break_rule_"[of l1 \<a>\<r>\<g>2 \<open>\<lambda>ret. Brk_Frame l2\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[ret] U\<close>]
      \<medium_right_bracket> .. ;;
      assert \<bottom> (*this place is unreachable!*)
    \<medium_right_bracket> ..
  \<medium_right_bracket> .. .

end