(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    The seL4 page table on ARMv6. See ASSUMPTIONS.
*)

theory PageTable_seL4
imports
  PageTable
  MachineARM
  Heaps
  MapExtra
  Misc
begin

declare map_add_assoc [simp del] (* required for MapExtra *)

text \<open>
  The base of the page table is one physical root.
  This page table structure is the part after the ASID table lookup.
  one for the user side\<close>
type_synonym ptable_base = paddr

text \<open>
  ASSUMPTIONS:

  Things I think are always the case in seL4:
  - subpage AP bits disabled (ARMv6 page table format, subpages disabled)
  - don't use extended physical addresses (40-bit address space)
  - don't use domains (domain is always 0)

\<close>

text \<open>
  Conventions:
  A Page Directory is the first level of a two-level page table.
  A Page Table is the second level of a two-level page table.
  Entries are called PDEs for the former and PTEs for the latter.

  Both PDEs and PTEs are the size of a machine word (32 bits)

  The offset is the index into the structure we resolve to when looking up,
  i.e. page index for pages, section index for sections
\<close>

text \<open>Supported page types\<close>

datatype page_type =
   ArmSmallPage
 | ArmSection

primrec
  page_bits :: "page_type \<Rightarrow> nat"
where
 "page_bits ArmSmallPage    = 12" |
 "page_bits ArmSection      = 20"

definition
  page_size :: "page_type \<Rightarrow> nat" where
  "page_size page_type \<equiv> 2 ^ (page_bits page_type)"

text \<open>Offset calculation common to all sizes\<close>

definition
  vaddr_offset :: "page_type \<Rightarrow> machine_word \<Rightarrow> machine_word" where
  "vaddr_offset p w \<equiv> w AND mask (page_bits p)"

definition
  "page_aligned page_type p = (vaddr_offset page_type p = 0)"

lemma "map (\<lambda>p. vaddr_offset p 0xFEDCBAAA) [ArmSmallPage, ArmSection] = [0xAAA, 0xCBAAA]"
  by (clarsimp simp: vaddr_offset_def mask_def)

text \<open>Get the non-offset part of an address for a given page size\<close>
definition
  addr_base :: "page_type \<Rightarrow> machine_word \<Rightarrow> machine_word" where
  "addr_base sz w \<equiv> w AND (NOT mask (page_bits sz))"

lemma "addr_base ArmSmallPage 0xFFFFFFFF = 0xFFFFF000" (* sanity check *)
  unfolding addr_base_def mask_def by simp

text \<open>
  Permissions bits as per the reference manual. These are not translated into
  anything more abstract, because currently they aren't used in the logic.
  I suppose the best way to go about this is to add another "guard", like a
  permissions guard, rather than fiddling around with a set of flags, since
  on the ARM the permissions decoding is not so straightforward.
\<close>

record arm_perm_bits =
    arm_p_APX :: "1 word"
    arm_p_AP  :: "2 word"
    arm_p_TEX :: "3 word"
    arm_p_S   :: "1 word"
    arm_p_XN  :: "1 word"
    arm_p_C   :: "1 word"
    arm_p_B   :: "1 word"
    arm_p_nG  :: "1 word"

section \<open>Page Directory Entry (PDE) Decoding\<close>

datatype pde =
   InvalidPDE
 | ReservedPDE
 \<comment> \<open>the paddr is address of a page table\<close>
 | PageTablePDE paddr
  \<comment> \<open>the paddr is base address of section\<close>
 | SectionPDE paddr arm_perm_bits

definition
  perm_bits_pde_sections :: "machine_word \<Rightarrow> arm_perm_bits" where
  "perm_bits_pde_sections w \<equiv>
     \<lparr> arm_p_APX = ucast ((w >> 15) AND 0x1),
       arm_p_AP  = ucast ((w >> 10) AND 0x3),
       arm_p_TEX = ucast ((w >> 12) AND 0x7),
       arm_p_S   = ucast ((w >> 16) AND 0x1),
       arm_p_XN  = ucast ((w >> 4) AND 0x1),
       arm_p_C   = ucast ((w >> 3) AND 0x1),
       arm_p_B   = ucast ((w >> 2) AND 0x1),
       arm_p_nG  = ucast ((w >> 17) AND 0x1) \<rparr>"

definition
  "decode_pde_section w \<equiv> SectionPDE (Addr (addr_base ArmSection w))
                                     (perm_bits_pde_sections w)"

definition
  pt_base_mask :: machine_word where
  "pt_base_mask \<equiv> NOT (mask 9)" (* FIXME TODO: check *again* that this is right *)
definition
  "decode_pde_pt w \<equiv> PageTablePDE (Addr (w AND pt_base_mask))"

lemma (* sanity check *)
  "pt_base_mask \<equiv> 0xFFFFFE00" unfolding pt_base_mask_def mask_def by simp

definition
  decode_pde :: "machine_word \<Rightarrow> pde" where
  "decode_pde w \<equiv> let pde_type = w AND 0x3
            in
              if pde_type = 1 then (decode_pde_pt w)
              else if pde_type = 2 then decode_pde_section w
              else if pde_type = 3 then ReservedPDE
              else InvalidPDE"

(* update form Hira: changed Option.map to map_option *)
definition
  decode_heap_pde :: "heap \<Rightarrow> paddr \<rightharpoonup> pde" where
  "decode_heap_pde h p \<equiv>
     map_option decode_pde (load_machine_word h p)"

section \<open>Page Table Entry (PTE) Decoding\<close>

datatype pte =
   InvalidPTE
  \<comment> \<open>the paddr is the page base address\<close>
 | SmallPagePTE paddr arm_perm_bits

definition
  perm_bits_pte_small :: "machine_word \<Rightarrow> arm_perm_bits" where
  "perm_bits_pte_small w =
     \<lparr> arm_p_APX = ucast ((w >> 9) AND 0x1),
       arm_p_AP  = ucast ((w >> 4) AND 0x3),
       arm_p_TEX = ucast ((w >> 6) AND 0x7),
       arm_p_S   = ucast ((w >> 10) AND 0x1),
       arm_p_XN  = ucast (w AND 0x1),
       arm_p_C   = ucast ((w >> 3) AND 0x1),
       arm_p_B   = ucast ((w >> 2) AND 0x1),
       arm_p_nG  = ucast ((w >> 11) AND 0x1) \<rparr>"

definition
  "decode_pte_small w \<equiv> SmallPagePTE (Addr (addr_base ArmSmallPage w))
                                     (perm_bits_pte_small w)"

definition
  large_base_mask :: "32 word" where
  "large_base_mask \<equiv> NOT (mask 16)"

lemma (* sanity check *)
  "large_base_mask \<equiv> 0xFFFF0000" by (simp add: large_base_mask_def mask_def)

definition
  decode_pte :: "machine_word \<Rightarrow> pte" where
  "decode_pte w \<equiv> if w AND 3 = 0
            then InvalidPTE
            else decode_pte_small w"

(* update form Hira: changed Option.map to map_option *)
definition
  decode_heap_pte :: "heap \<Rightarrow> paddr \<rightharpoonup> pte" where
  "decode_heap_pte h p \<equiv> map_option decode_pte (load_machine_word h p)"

section \<open>Performing a Lookup\<close>

text \<open>
  Bits 20-31 of virtual addresses represent an index into the page directory.\<close>
definition
  vaddr_pd_index :: "machine_word \<Rightarrow> machine_word" where
  "vaddr_pd_index w \<equiv> (w >> 20) AND mask 12"

lemma vaddr_pd_index_simp: "((w::machine_word) >> 20) AND mask 12 = w >> 20"
  by (clarsimp simp: and_mask_eq_iff_shiftr_0 shiftr_shiftr
                     le_mask_iff[symmetric])
     (unfold mask_def, rule order_trans, rule word_n1_ge, simp)

text \<open>
  Bits 12-19 of virtual addresses represent an index into the page table.\<close>
definition
  vaddr_pt_index :: "machine_word \<Rightarrow> machine_word" where
  "vaddr_pt_index w \<equiv> (w >> 12) AND mask 8"

subsection \<open>Get Frame\<close>

text \<open>
  Decode the correct page directory entry from the page directory at some
  physical location given a virtual address to look up.
\<close>
definition
  get_pde :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<rightharpoonup> pde" where
  "get_pde h root vp \<equiv>
     let
       pd_idx_offset = ((vaddr_pd_index (addr_val vp)) << 2)
     in
       decode_heap_pde h (root r+ pd_idx_offset)"

text \<open>
  Decode the correct page table entry from a page table at some
  physical location given a virtual address to look up.
\<close>
definition
  get_pte :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<rightharpoonup> pte" where
  "get_pte h pt_base vp \<equiv>
     let
       pt_idx_offset = ((vaddr_pt_index (addr_val vp)) << 2)
     in
       decode_heap_pte h (pt_base r+ pt_idx_offset)"

text \<open>
  The basic lookup mechanism we perform is figuring out the size of the page
  a virtual address is on, then figuring out where in physical memory that
  page maps to.
\<close>

definition
  lookup_pte :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<rightharpoonup> (paddr \<times> page_type \<times> arm_perm_bits)"
  where
  "lookup_pte h pt_base vp \<equiv>
   case_option None
    (\<lambda>pte. case pte
             of InvalidPTE \<Rightarrow> None
              | SmallPagePTE base perms \<Rightarrow> Some (base, ArmSmallPage, perms))
    (get_pte h pt_base vp)"

definition
  lookup_pde :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<rightharpoonup> (paddr \<times> page_type \<times> arm_perm_bits)"
  where
  "lookup_pde h root vp \<equiv>
   case_option None
    (\<lambda>pde. case pde
            of InvalidPDE \<Rightarrow> None
             | ReservedPDE \<Rightarrow> None
             | SectionPDE base perms \<Rightarrow> Some (base, ArmSection, perms)
             | PageTablePDE pt_base \<Rightarrow> lookup_pte h pt_base vp)
    (get_pde h root vp)"

subsection \<open>Get Page\<close>

text \<open>
  Find out which page a virtual address is on, along with permissions.

  Getting a page is a bit more complicated with superpages, as we can't really
  ``get a *page*''. So we get the virtual base address of the page *and*
  the page size. For that, we need to essentially perform a lookup.
  Once we know the page size, we can just mask it out of the virtual pointer.
\<close>

definition
  get_page :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<rightharpoonup> (vaddr \<times> page_type \<times> arm_perm_bits)"
  where
  "get_page h root vp \<equiv>
     let
       vp_val = addr_val vp
     in
       map_option
         (\<lambda>(base, pg_size, perms). (Addr (addr_base pg_size vp_val),
                                     pg_size, perms))
         (lookup_pde h root vp)"

subsection \<open>Lookup\<close>

text \<open>
  Lookup of a virtual pointer in a Page Table given its base address.
  To obtain the physical address, we get the frame and the page size,
  then mask in offset bits from the virtual pointer into the frame base
  address.
\<close>
definition
  ptable_lift :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<rightharpoonup> paddr" where
  "ptable_lift h pt_root vp \<equiv>
     let
       vp_val = addr_val vp
     in
       map_option
         (\<lambda>(base, pg_size, perms).
             base r+ (vaddr_offset pg_size vp_val))
         (lookup_pde h pt_root vp)"

subsection \<open>Trace\<close>

text \<open>
  Trace of looking up a virtual pointer in a Page Directory given its base
  address.\<close>
definition
  ptable_trace :: "heap \<Rightarrow> paddr \<Rightarrow> vaddr \<Rightarrow> paddr set" where
  "ptable_trace h root vp \<equiv>
     let
       vp_val = addr_val vp ;
       pd_idx_offset = ((vaddr_pd_index vp_val) << 2) ;
       pt_idx_offset = ((vaddr_pt_index vp_val) << 2) ;
       pd_touched = set (addr_seq (root r+ pd_idx_offset) 4) ;
       pt_touched = (\<lambda>pt_base. set (addr_seq (pt_base r+ pt_idx_offset) 4))
     in
      (case decode_heap_pde h (root r+ pd_idx_offset)
         of Some pde \<Rightarrow>
              (case pde
                 of PageTablePDE pt_base \<Rightarrow> pd_touched \<union> pt_touched pt_base
                  | _ \<Rightarrow> pd_touched)
          | None \<Rightarrow> {})"

section \<open>Properties, Instantiation to pagetable Locale\<close>

text \<open>Heap monotonicity and Frame monotonicity for on option result\<close>

definition
  heap_mono_option :: "(('a \<rightharpoonup> 'b) \<Rightarrow> 'c option) \<Rightarrow> bool" where
  "heap_mono_option f \<equiv> \<forall>h h' v. h \<bottom> h' \<and> f h = Some v \<longrightarrow> f (h ++ h') = Some v"

lemma heap_mono_optionE:
  "\<lbrakk> heap_mono_option f ; f h = Some v ; h \<bottom> h' \<rbrakk> \<Longrightarrow> f (h ++ h') = Some v"
  unfolding heap_mono_option_def by blast

lemma heap_mono_option_simp:
  "\<lbrakk> heap_mono_option f ; f h = Some v ; h \<bottom> h' \<rbrakk> \<Longrightarrow> f (h ++ h') = f h"
  by (frule (2) heap_mono_optionE, simp)

definition
  frame_mono_option :: "(('a \<rightharpoonup> 'b) \<Rightarrow> 'c option) \<Rightarrow> bool" where
  "frame_mono_option f \<equiv> \<forall>h h' v. h \<bottom> h' \<and> f (h ++ h') = Some v
                           \<longrightarrow> (f h = Some v \<or> f h = None)"

lemma frame_mono_optionE:
  "\<lbrakk> frame_mono_option f ; f (h ++ h') = Some v ; h \<bottom> h' \<rbrakk>
   \<Longrightarrow> f h = Some v \<or> f h = None"
  unfolding frame_mono_option_def by fastforce

subsection \<open>Heap monotonicity\<close>

lemma load_list_basic_heap_mono_simp:
  assumes disj: "h \<bottom> h'"
  assumes some: "\<forall>v \<in> set (load_list_basic h n p). v \<noteq> None"
  shows "load_list_basic (h ++ h') n p = load_list_basic h n p"
  using disj some
proof (induct n arbitrary: p)
  case 0 thus ?case by simp
next
  case (Suc n)
  thus ?case by (clarsimp, subst map_add_eval_left, auto)
qed

lemma Some_set_member:
  assumes some: "None \<notin> S"
  assumes x: "x \<in> S"
  shows "\<exists>y. x = Some y"
proof -
  { assume a: "x = None"
    hence False using some x by auto
  }
  thus ?thesis by blast
qed

lemma load_list_heap_mono_option:
  "heap_mono_option (\<lambda>h. load_list h n p)"
  unfolding heap_mono_option_def load_list_def
  by (clarify, subst load_list_basic_heap_mono_simp)
     (auto simp: deoption_list_def elim!: Some_set_member split: if_split_asm)

lemmas load_list_heap_mono_simp = heap_mono_option_simp[OF load_list_heap_mono_option]
lemmas load_list_heap_mono = heap_mono_optionE[OF load_list_heap_mono_option]

lemma decode_pde_heap_mono_option:
  "heap_mono_option (\<lambda>h. decode_heap_pde h p)"
  unfolding heap_mono_option_def decode_pde_def decode_heap_pde_def
  by (auto simp: load_machine_word_def load_value_def
                 load_list_heap_mono Let_def
           split: option.splits)

lemmas decode_pde_heap_mono_simp = heap_mono_option_simp[OF decode_pde_heap_mono_option]
lemmas decode_pde_heap_mono = heap_mono_optionE[OF decode_pde_heap_mono_option]

lemma decode_pte_heap_mono_option:
  "heap_mono_option (\<lambda>h. decode_heap_pte h p)"
  unfolding heap_mono_option_def decode_pte_def decode_heap_pte_def Let_def
  by (clarsimp simp: load_machine_word_def load_value_def Let_def
                     load_list_heap_mono
               split: option.splits)

lemmas decode_pte_heap_mono_simp = heap_mono_option_simp[OF decode_pte_heap_mono_option]
lemmas decode_pte_heap_mono = heap_mono_optionE[OF decode_pte_heap_mono_option]

lemma lookup_pte_heap_mono_option:
  "heap_mono_option (\<lambda>h. lookup_pte h r vp)"
  unfolding heap_mono_option_def lookup_pte_def get_pte_def Let_def
  by (clarsimp simp: decode_pte_heap_mono split: option.splits)

lemmas lookup_pte_heap_mono_simp = heap_mono_option_simp[OF lookup_pte_heap_mono_option]
lemmas lookup_pte_heap_mono = heap_mono_optionE[OF lookup_pte_heap_mono_option]

lemma lookup_pde_heap_mono_option:
  "heap_mono_option (\<lambda>h. lookup_pde h r vp)"
  unfolding heap_mono_option_def lookup_pde_def get_pde_def Let_def
  by (clarsimp simp: decode_pde_heap_mono lookup_pte_heap_mono
               split: option.splits pde.splits)

thm heap_mono_option_simp[OF lookup_pde_heap_mono_option]

lemmas lookup_pde_heap_mono_simp = heap_mono_option_simp[OF lookup_pde_heap_mono_option]
lemmas lookup_pde_heap_mono = heap_mono_optionE[OF lookup_pde_heap_mono_option]

lemma ptable_lift_heap_mono_option:
  "heap_mono_option (\<lambda>h. ptable_lift h r vp)"
  unfolding heap_mono_option_def ptable_lift_def Let_def
  by (clarsimp simp: lookup_pde_heap_mono
               split: option.splits pde.splits)

lemmas ptable_lift_heap_mono_simp = heap_mono_option_simp[OF ptable_lift_heap_mono_option]
lemmas ptable_lift_heap_mono = heap_mono_optionE[OF ptable_lift_heap_mono_option]

lemma get_page_heap_mono_option:
  "heap_mono_option (\<lambda>h. get_page h r vp)"
  unfolding heap_mono_option_def get_page_def Let_def
  by (clarsimp simp: lookup_pde_heap_mono split: option.splits)

lemmas get_page_disj_heap_mono_simp = heap_mono_option_simp[OF get_page_heap_mono_option]
lemmas get_page_disj_heap_mono = heap_mono_optionE[OF get_page_heap_mono_option]

text \<open>Heap monotonicity of ptable_trace works a bit differently as it just
  returns a set, so it depends on ptable_lift's monotonicity\<close>

(*XXX: fold into not_in_trace_not_in_pde?*)
lemma lift_valid_pde_valid:
  "\<lbrakk> ptable_lift h r vp = Some p \<rbrakk>
   \<Longrightarrow> decode_heap_pde h (r r+ (vaddr_pd_index (addr_val vp) << 2)) \<noteq> None"
  unfolding ptable_lift_def lookup_pde_def Let_def get_pde_def
  by (auto split: option.splits)

lemma ptable_trace_heap_mono_simp:
  "\<lbrakk> ptable_lift h r vp = Some p ; h \<bottom> h' \<rbrakk>
   \<Longrightarrow> ptable_trace (h ++ h') r vp = ptable_trace h r vp"
  unfolding ptable_trace_def Let_def
  apply (case_tac "decode_heap_pde h (r r+ (vaddr_pd_index (addr_val vp) << 2))")
   apply (drule lift_valid_pde_valid, blast)
  apply (subst decode_pde_heap_mono_simp, assumption+)
  apply simp
  done
(*XXX: any set-like monotonicity properties can be derived from this*)

subsection \<open>Frame Monotonicity\<close>

lemma load_list_frame_mono_option:
  "frame_mono_option (\<lambda>h. load_list h n p)"
  unfolding frame_mono_option_def load_list_def
  by (clarsimp simp: deoption_list_def, subst load_list_basic_heap_mono_simp)
     (auto elim: Some_set_member)

lemmas load_list_frame_mono = frame_mono_optionE[OF load_list_frame_mono_option]

lemma decode_pde_frame_mono_option:
  "frame_mono_option (\<lambda>h. decode_heap_pde h p)"
  unfolding frame_mono_option_def decode_pde_def decode_heap_pde_def load_machine_word_def load_value_def
            Let_def
  by (intro allI impI, elim conjE)
     (case_tac "load_list h (size_of TYPE(32 word)) p",
      auto simp: load_list_heap_mono)

lemmas decode_pde_frame_mono = frame_mono_optionE[OF decode_pde_frame_mono_option]

lemma decode_pte_frame_mono_option:
  "frame_mono_option (\<lambda>h. decode_heap_pte h p)"
  unfolding frame_mono_option_def decode_pte_def decode_heap_pte_def load_machine_word_def load_value_def
            Let_def
  by (intro allI impI, elim conjE)
     (case_tac "load_list h (size_of TYPE(32 word)) p",
      auto simp: load_list_heap_mono)

lemmas decode_pte_frame_mono = frame_mono_optionE[OF decode_pte_frame_mono_option]

lemma lookup_pte_frame_mono_option:
  "frame_mono_option (\<lambda>h. lookup_pte h r vp)"
  unfolding frame_mono_option_def lookup_pte_def load_machine_word_def
            load_value_def Let_def get_pte_def
  by (intro allI impI, elim conjE)
     (case_tac "decode_heap_pte h (r r+ (vaddr_pt_index (addr_val vp) << 2))",
      auto simp: decode_pte_heap_mono)

lemmas lookup_pte_frame_mono = frame_mono_optionE[OF lookup_pte_frame_mono_option]

lemma lookup_pde_frame_mono_option:
  "frame_mono_option (\<lambda>h. lookup_pde h r vp)"
  unfolding frame_mono_option_def lookup_pde_def load_machine_word_def
            load_value_def Let_def get_pde_def
  apply (intro allI impI, elim conjE)
  apply (case_tac "decode_heap_pde h (r r+ (vaddr_pd_index (addr_val vp) << 2))")
   apply simp
  apply simp
  apply (drule (1) decode_pde_heap_mono)
  apply simp
  apply (case_tac a)
      apply (auto elim!: lookup_pte_frame_mono)
  done

lemmas lookup_pde_frame_mono = frame_mono_optionE[OF lookup_pde_frame_mono_option]

lemma ptable_lift_frame_mono_option:
  "frame_mono_option (\<lambda>h. ptable_lift h r vp)"
  unfolding frame_mono_option_def ptable_lift_def Let_def
  apply (intro allI impI, elim conjE)
  apply (case_tac "lookup_pde (h ++ h') r vp", simp)
  apply (frule (1) lookup_pde_frame_mono)
  apply clarsimp
  done

lemmas ptable_lift_frame_mono = frame_mono_optionE[OF ptable_lift_frame_mono_option]

lemma get_page_frame_mono_option:
  "frame_mono_option (\<lambda>h. get_page h r vp)"
  unfolding frame_mono_option_def get_page_def Let_def
  apply (intro allI impI, elim conjE)
  apply (case_tac "lookup_pde (h ++ h') r vp", simp)
  apply (frule (1) lookup_pde_frame_mono)
  apply clarsimp
  done

lemmas get_page_frame_mono = frame_mono_optionE[OF get_page_frame_mono_option]

subsection \<open>Preservation of trace and lift During Updates Outside a Trace\<close>

lemma decode_pde_update_eq:
  "\<lbrakk> p \<notin> set (addr_seq start 4) \<rbrakk>
   \<Longrightarrow> decode_heap_pde (h(p \<mapsto> v)) start = decode_heap_pde h start"
  unfolding decode_pde_def decode_heap_pde_def load_machine_word_def
  by (simp add: load_value_update_eq)

lemma decode_pte_update_eq:
  "\<lbrakk> p \<notin> set (addr_seq start 4) \<rbrakk>
   \<Longrightarrow> decode_heap_pte (h(p \<mapsto> v)) start = decode_heap_pte h start"
  unfolding decode_pte_def decode_heap_pte_def load_machine_word_def
  by (simp add: load_value_update_eq)

lemma not_in_trace_not_in_pde:
  assumes trace: "p \<notin> ptable_trace h r vp"
  assumes lift: "ptable_lift h r vp = Some p"
  shows "p \<notin> set (addr_seq (r r+ (vaddr_pd_index (addr_val vp) << 2)) 4)"
proof -
  from lift
  obtain pde where
    "decode_heap_pde h (r r+ (vaddr_pd_index (addr_val vp) << 2)) = Some pde "
    by (auto dest: lift_valid_pde_valid)
  thus ?thesis using trace unfolding ptable_trace_def Let_def
    by (cases pde, auto)
qed

(*XXX:name modified to not conflict with instantiation of locale*)
lemma ptable_trace_preserved':
  "\<lbrakk> p \<notin> ptable_trace h r vp ; ptable_lift h r vp = Some p \<rbrakk>
  \<Longrightarrow> ptable_trace (h(p \<mapsto> v)) r vp = ptable_trace h r vp"
  apply (frule (1) not_in_trace_not_in_pde)
  apply (unfold ptable_trace_def ptable_lift_def Let_def lookup_pde_def)
  apply (simp add: decode_pde_update_eq)
  done

(*XXX:name modified to not conflict with instantiation of locale*)
lemma ptable_lift_preserved':
  "\<lbrakk> p \<notin> ptable_trace h r vp ; ptable_lift h r vp = Some p \<rbrakk>
    \<Longrightarrow> ptable_lift (h(p \<mapsto> v)) r vp = Some p"
  apply (frule (1) not_in_trace_not_in_pde)
  apply (unfold ptable_trace_def ptable_lift_def lookup_pde_def lookup_pte_def Let_def)
  apply clarsimp
  apply (case_tac "decode_heap_pde h (r r+ (vaddr_pd_index (addr_val vp) << 2))")
   apply (simp add: get_pde_def)
  apply (rule_tac x=a and y=aa in exI2)
  apply clarsimp
  apply (rename_tac pde)
  apply (case_tac pde)
      apply (clarsimp simp: get_pde_def get_pte_def Let_def
                            decode_pde_update_eq decode_pte_update_eq)+
  done
  (*XXX: shorter, but still ugly proof*)

interpretation (*XXX: no requirements on get_page so ignored in proof, but is it taken into account for the interpretation?*)
  pagetable ptable_lift ptable_trace get_page
  by (unfold_locales)
     (auto elim!: ptable_lift_heap_mono ptable_lift_frame_mono
                  ptable_trace_heap_mono_simp
                  ptable_lift_preserved' ptable_trace_preserved')

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__35_on_rules imports n_german_lemma_on_inv__35
begin
section{*All lemmas on causal relation between inv__35*}
lemma lemma_inv__35_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__35  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__35) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

end


theory Properties
imports Cheri_axioms_lemmas Sail.Sail2_state_lemmas
begin

locale CHERI_ISA = Capability_ISA CC ISA
  for CC :: "'cap Capability_class" and ISA :: "('cap, 'regval, 'instr, 'e) isa" +
  fixes fetch_assms :: "'regval trace \<Rightarrow> bool" and instr_assms :: "'regval trace \<Rightarrow> bool"
  assumes instr_cheri_axioms: "\<And>t instr. hasTrace t \<lbrakk>instr\<rbrakk> \<Longrightarrow> instr_assms t \<Longrightarrow> cheri_axioms CC ISA False (instr_raises_ex ISA instr t) (invokes_caps ISA instr t) t"
    and fetch_cheri_axioms: "\<And>t. hasTrace t (instr_fetch ISA) \<Longrightarrow> fetch_assms t \<Longrightarrow> cheri_axioms CC ISA True (fetch_raises_ex ISA t) False t"
    and instr_assms_appendE: "\<And>t t' instr. instr_assms (t @ t') \<Longrightarrow> Run \<lbrakk>instr\<rbrakk> t () \<Longrightarrow> instr_assms t \<and> fetch_assms t'"
    and fetch_assms_appendE: "\<And>t t' instr. fetch_assms (t @ t') \<Longrightarrow> Run (instr_fetch ISA) t instr \<Longrightarrow> fetch_assms t \<and> instr_assms t'"

locale Register_Accessors =
  fixes read_regval :: "register_name \<Rightarrow> 'regs \<Rightarrow> 'regval option"
    and write_regval :: "register_name \<Rightarrow> 'regval \<Rightarrow> 'regs \<Rightarrow> 'regs option"
begin

abbreviation "s_emit_event e s \<equiv> emitEventS (read_regval, write_regval) e s"
abbreviation "s_run_trace t s \<equiv> runTraceS (read_regval, write_regval) t s"
abbreviation "s_allows_trace t s \<equiv> \<exists>s'. s_run_trace t s = Some s'"

end

locale CHERI_ISA_State = CHERI_ISA CC ISA + Register_Accessors read_regval write_regval
  for ISA :: "('cap, 'regval, 'instr, 'e) isa"
  and CC :: "'cap Capability_class"
  and read_regval :: "register_name \<Rightarrow> 'regs \<Rightarrow> 'regval option"
  and write_regval :: "register_name \<Rightarrow> 'regval \<Rightarrow> 'regs \<Rightarrow> 'regs option" +
  (* State versions of ISA model parameters *)
  fixes s_translation_tables :: "'regs sequential_state \<Rightarrow> nat set"
    and s_translate_address :: "nat \<Rightarrow> acctype \<Rightarrow> 'regs sequential_state \<Rightarrow> nat option"
  assumes read_absorb_write: "\<And>r v s s'. write_regval r v s = Some s' \<Longrightarrow> read_regval r s' = Some v"
    and read_ignore_write: "\<And>r r' v s s'. write_regval r v s = Some s' \<Longrightarrow> r' \<noteq> r \<Longrightarrow> read_regval r' s' = read_regval r' s"
    and translation_tables_sound: "\<And>t s. s_allows_trace t s \<Longrightarrow> translation_tables ISA t \<subseteq> s_translation_tables s"
    and translate_address_sound: "\<And>t s vaddr paddr load.
          s_allows_trace t s \<Longrightarrow>
          translate_address ISA vaddr load t = Some paddr \<Longrightarrow>
          s_translate_address vaddr load s = Some paddr"
    and translate_address_tag_aligned_iff: "\<And>s vaddr paddr load.
          s_translate_address vaddr load s = Some paddr \<Longrightarrow>
          address_tag_aligned ISA paddr \<longleftrightarrow> address_tag_aligned ISA vaddr"
begin

subsection \<open>Reachable capabilities\<close>

fun get_reg_val :: "register_name \<Rightarrow> 'regs sequential_state \<Rightarrow> 'regval option" where
  "get_reg_val r s = read_regval r (regstate s)"

fun put_reg_val :: "register_name \<Rightarrow> 'regval \<Rightarrow> 'regs sequential_state \<Rightarrow> 'regs sequential_state option" where
  "put_reg_val r v s = map_option (\<lambda>rs'. s\<lparr>regstate := rs'\<rparr>) (write_regval r v (regstate s))"

fun get_reg_caps :: "register_name \<Rightarrow> 'regs sequential_state \<Rightarrow> 'cap set" where
  "get_reg_caps r s = (case read_regval r (regstate s) of Some v \<Rightarrow> {c \<in> caps_of_regval ISA v. is_tagged_method CC c} | None \<Rightarrow> {})"

fun get_mem_cap :: "nat \<Rightarrow> nat \<Rightarrow> 'regs sequential_state \<Rightarrow> 'cap option" where
  "get_mem_cap addr sz s =
     Option.bind (get_mem_bytes addr sz s) (\<lambda>(bytes, tag).
     Option.bind (cap_of_mem_bytes_method CC bytes tag) (\<lambda>c.
     if is_tagged_method CC c then Some c else None))"

fun get_aligned_mem_cap :: "nat \<Rightarrow> nat \<Rightarrow> 'regs sequential_state \<Rightarrow> 'cap option" where
  "get_aligned_mem_cap vaddr sz s =
     (if address_tag_aligned ISA vaddr \<and> sz = tag_granule ISA then get_mem_cap vaddr sz s else None)"

inductive_set reachable_caps :: "'regs sequential_state \<Rightarrow> 'cap set" for s :: "'regs sequential_state" where
  Reg: "\<lbrakk>c \<in> get_reg_caps r s; r \<notin> privileged_regs ISA; is_tagged_method CC c\<rbrakk> \<Longrightarrow> c \<in> reachable_caps s"
| SysReg:
    "\<lbrakk>c \<in> get_reg_caps r s; r \<in> privileged_regs ISA; c' \<in> reachable_caps s;
      permit_system_access (get_perms_method CC c'); \<not>is_sealed_method CC c';
      is_tagged_method CC c\<rbrakk>
     \<Longrightarrow> c \<in> reachable_caps s"
| Mem:
    "\<lbrakk>get_aligned_mem_cap addr (tag_granule ISA) s = Some c;
      s_translate_address vaddr Load s = Some addr;
      c' \<in> reachable_caps s; is_tagged_method CC c'; \<not>is_sealed_method CC c';
      set (address_range vaddr (tag_granule ISA)) \<subseteq> get_mem_region_method CC c';
      permit_load_capability (get_perms_method CC c');
      is_tagged_method CC c\<rbrakk>
     \<Longrightarrow> c \<in> reachable_caps s"
| Restrict: "\<lbrakk>c \<in> reachable_caps s; leq_cap CC c' c\<rbrakk> \<Longrightarrow> c' \<in> reachable_caps s"
| Seal:
    "\<lbrakk>c' \<in> reachable_caps s; c'' \<in> reachable_caps s; is_tagged_method CC c'; is_tagged_method CC c'';
      \<not>is_sealed_method CC c''; \<not>is_sealed_method CC c'; permit_seal (get_perms_method CC c'')\<rbrakk> \<Longrightarrow>
     seal CC c' (get_cursor_method CC c'') \<in> reachable_caps s"
| Unseal:
    "\<lbrakk>c' \<in> reachable_caps s; c'' \<in> reachable_caps s; is_tagged_method CC c'; is_tagged_method CC c'';
      \<not>is_sealed_method CC c''; is_sealed_method CC c'; permit_unseal (get_perms_method CC c'');
      get_obj_type_method CC c' = get_cursor_method CC c''\<rbrakk> \<Longrightarrow>
     unseal CC c' (get_global CC c'') \<in> reachable_caps s"

lemma derivable_subseteq_reachableI:
  assumes "C \<subseteq> reachable_caps s"
  shows "derivable C \<subseteq> reachable_caps s"
proof
  fix c
  assume "c \<in> derivable C"
  then show "c \<in> reachable_caps s" using assms
    by induction (auto intro: reachable_caps.intros)
qed

lemma derivable_subseteq_reachableE:
  assumes "derivable C \<subseteq> reachable_caps s"
  shows "C \<subseteq> reachable_caps s"
  using assms by (auto intro: derivable.intros)

lemma derivable_reachable_caps_idem[simp]: "derivable (reachable_caps s) = reachable_caps s"
  using derivable_subseteq_reachableI[of "reachable_caps s" s] derivable_refl
  by auto

lemma runTraceS_rev_induct[consumes 1, case_names Init Step]:
  assumes "s_run_trace t s = Some s'"
    and Init: "P [] s"
    and Step: "\<And>t e s'' s'. s_run_trace t s = Some s'' \<Longrightarrow> s_emit_event e s'' = Some s' \<Longrightarrow> P t s'' \<Longrightarrow> P (t @ [e]) s'"
  shows "P t s'"
  using assms
  by (induction t arbitrary: s' rule: rev_induct)
     (auto elim: runTraceS_appendE runTraceS_ConsE simp: bind_eq_Some_conv)

lemma get_reg_val_s_run_trace_cases:
  assumes v: "get_reg_val r s' = Some v" and c: "c \<in> caps_of_regval ISA v"
    and s': "s_run_trace t s = Some s'"
  obtains (Init) "get_reg_val r s = Some v"
  | (Update) j v' where "t ! j = E_write_reg r v'" and "c \<in> caps_of_regval ISA v'" and "j < length t"
proof (use s' v c in \<open>induction rule: runTraceS_rev_induct\<close>)
  case (Step t e s'' s')
  note Init = Step(4)
  note Update = Step(5)
  note c = \<open>c \<in> caps_of_regval ISA v\<close>
  show ?case
  proof cases
    assume v_s'': "get_reg_val r s'' = Some v"
    show ?thesis
    proof (rule Step.IH[OF _ _ v_s'' c])
      assume "get_reg_val r s = Some v"
      then show thesis by (intro Init)
    next
      fix j v'
      assume "t ! j = E_write_reg r v'" and "c \<in> caps_of_regval ISA v'" and "j < length t"
      then show thesis by (intro Update[of j v']) (auto simp: nth_append_left)
    qed
  next
    assume v_s'': "get_reg_val r s'' \<noteq> Some v"
    note e = \<open>s_emit_event e s'' = Some s'\<close>
    note v_s' = \<open>get_reg_val r s' = Some v\<close>
    from e v_s' v_s'' have "e = E_write_reg r v"
    proof (cases rule: emitEventS_update_cases)
      case (Write_reg r' v' rs')
      then show ?thesis
        using v_s' v_s''
        by (cases "r' = r") (auto simp: read_ignore_write read_absorb_write)
    qed (auto simp: put_mem_bytes_def Let_def)
    then show thesis using c by (auto intro: Update[of "length t" v])
  qed
qed auto

lemma reads_reg_cap_at_idx_provenance[consumes 5]:
  assumes r: "t ! i = E_read_reg r v" and c: "c \<in> caps_of_regval ISA v" and tag: "is_tagged_method CC c"
    and s': "s_run_trace t s = Some s'" and i: "i < length t"
  obtains (Initial) "c \<in> get_reg_caps r s"
  | (Update) j where "c \<in> writes_reg_caps CC (caps_of_regval ISA) (t ! j)"
      and "writes_to_reg (t ! j) = Some r" and "j < i"
proof -
  from s' i obtain s1 s2
    where s1: "s_run_trace (take i t) s = Some s1"
      and s2: "s_emit_event (t ! i) s1 = Some s2"
    by (blast elim: runTraceS_nth_split)
  from s2 c r tag have "c \<in> get_reg_caps r s1"
    by (auto simp: bind_eq_Some_conv split: option.splits if_splits)
  with s1 Update show thesis using i
  proof (induction "take i t" s1 arbitrary: i t rule: runTraceS_rev_induct)
    case Init
    then show ?case by (intro Initial)
  next
    case (Step t' e s'' s' i t)
    then obtain j where j: "i = Suc j" by (cases i) auto
    then have t': "t' = take j t" and e: "e = t ! j"
      using Step by (auto simp: take_hd_drop[symmetric] hd_drop_conv_nth)
    note IH = Step(3)[of j t]
    note Update = Step(5)
    note i = \<open>i < length t\<close>
    show ?case
    proof (use \<open>s_emit_event e s'' = Some s'\<close> in \<open>cases rule: emitEventS_update_cases\<close>)
      case (Write_mem wk addr sz v tag res)
      then have c: "c \<in> get_reg_caps r s''"
        using Step
        by (auto simp: put_mem_bytes_def bind_eq_Some_conv Let_def)
      show ?thesis
        by (rule IH) (use c t' i j Update in \<open>auto\<close>)
    next
      case (Write_reg r' v rs')
      show ?thesis
      proof cases
        assume "r' = r"
        then show ?thesis
          using Write_reg e j \<open>c \<in> get_reg_caps r s'\<close>
          by (intro Update[of j]) (auto simp: read_absorb_write)
      next
        assume "r' \<noteq> r"
        show ?thesis
          by (rule IH)
             (use \<open>r' \<noteq> r\<close> Write_reg e t' i j \<open>c \<in> get_reg_caps r s'\<close> Update in
              \<open>auto simp: read_ignore_write\<close>)
      qed
    next
      case Read
      show ?thesis
        by (rule IH) (use Read Step.prems t' i j Update in \<open>auto\<close>)
    qed
  qed
qed

lemma reads_reg_cap_at_idx_from_initial:
  assumes r: "t ! i = E_read_reg r v" and c: "c \<in> caps_of_regval ISA v" and tag: "is_tagged_method CC c"
    and s': "s_run_trace t s = Some s'" and i: "i < length t"
    and "\<not> cap_reg_written_before_idx CC ISA i r t"
  shows "c \<in> get_reg_caps r s"
  using assms
  by (elim reads_reg_cap_at_idx_provenance)
     (auto simp: cap_reg_written_before_idx_def writes_reg_caps_at_idx_def)

subsection \<open>Capability monotonicity\<close>

lemma available_caps_mono:
  assumes j: "j < i"
  shows "available_caps CC ISA j t \<subseteq> available_caps CC ISA i t"
proof -
  have "available_caps CC ISA j t \<subseteq> available_caps CC ISA (Suc (j + k)) t" for k
    by (induction k) (auto simp: available_caps_Suc image_iff subset_iff)
  then show ?thesis using assms less_iff_Suc_add[of j i] by blast
qed

lemma reads_reg_cap_non_privileged_accessible[intro]:
  assumes "c \<in> caps_of_regval ISA v" and "t ! j = E_read_reg r v"
    and "\<not>cap_reg_written_before_idx CC ISA j r t"
    and "r \<notin> privileged_regs ISA"
    and "is_tagged_method CC c"
    and "j < i"
    and "j < length t"
  shows "c \<in> available_caps CC ISA i t"
proof -
  from assms have c: "c \<in> available_caps CC ISA (Suc j) t"
    by (auto simp: bind_eq_Some_conv image_iff available_caps.simps)
  consider "i = Suc j" | "Suc j < i" using \<open>j < i\<close>
    by (cases "i = Suc j") auto
  then show "c \<in> available_caps CC ISA i t"
    using c available_caps_mono[of "Suc j" i t]
    by cases auto
qed

lemma system_access_permitted_at_idx_available_caps:
  assumes "system_access_permitted_before_idx CC ISA i t"
  obtains c where "c \<in> available_caps CC ISA i t" and "is_tagged_method CC c"
    and "\<not>is_sealed_method CC c" and "permit_system_access (get_perms_method CC c)"
  using assms
  by (auto simp: system_access_permitted_before_idx_def; blast)

lemma writes_reg_cap_nth_provenance[consumes 4]:
  assumes "t ! i = E_write_reg r v" and "c \<in> caps_of_regval ISA v"
    and "cheri_axioms CC ISA is_fetch has_ex inv_caps t"
    and "i < length t"
    and tagged: "is_tagged_method CC c"
  obtains (Accessible) "c \<in> derivable (available_caps CC ISA i t)"
  | (Exception) v' r' j where "c \<in> exception_targets ISA {v. \<exists>r j. j < i \<and> j < length t \<and> t ! j = E_read_reg r v \<and> r \<in> KCC ISA}" (* "leq_cap CC c c'"*)
    (*and "t ! j = E_read_reg r' v'" and "j < i"*) (*and "c' \<in> caps_of_regval ISA v'"*)
    (*and "r' \<in> KCC ISA"*) and "r \<in> PCC ISA" and "has_ex"
  | (CCall) cc cd c' where "inv_caps" (*"(cc, cd) \<in> inv_caps"*) and "invokable CC cc cd"
    and "cc \<in> derivable (available_caps CC ISA i t)"
    and "cd \<in> derivable (available_caps CC ISA i t)"
    and "(r \<in> PCC ISA \<and> leq_cap CC c (unseal CC cc True)) \<or>
         (r \<in> IDC ISA \<and> leq_cap CC c (unseal CC cd True))"
  using assms
  unfolding cheri_axioms_def store_cap_reg_axiom_def writes_reg_caps_at_idx_def cap_derivable_iff_derivable
  by (elim impE conjE allE[where x = i] allE[where x = c])
     (auto simp: eq_commute[where b = "t ! j" for t j])

lemma get_mem_cap_run_trace_cases:
  assumes c: "get_mem_cap addr (tag_granule ISA) s' = Some c"
    and s': "s_run_trace t s = Some s'"
    and tagged: "is_tagged_method CC c"
    and aligned: "address_tag_aligned ISA addr"
    and axiom: "store_tag_axiom CC ISA t"
  obtains (Initial)  "get_mem_cap addr (tag_granule ISA) s = Some c"
  | (Update) k wk bytes r where "k < length t"
    and "t ! k = E_write_memt wk addr (tag_granule ISA) bytes B1 r"
    and "cap_of_mem_bytes_method CC bytes B1 = Some c"
proof (use s' c axiom in \<open>induction rule: runTraceS_rev_induct\<close>)
  case (Step t e s'' s')
  note Update = Step.prems(2)
  have axiom: "store_tag_axiom CC ISA t"
    using \<open>store_tag_axiom CC ISA (t @ [e])\<close>
    by (auto simp: store_tag_axiom_def writes_mem_val_at_idx_def nth_append bind_eq_Some_conv split: if_splits; metis less_SucI)
  have IH: "thesis" if "get_mem_cap addr (tag_granule ISA) s'' = Some c"
  proof (rule Step.IH[OF _ _ that axiom])
    assume "get_mem_cap addr (tag_granule ISA) s = Some c"
    then show thesis by (rule Initial)
  next
    fix k wk bytes r
    assume "k < length t" and "t ! k = E_write_memt wk addr (tag_granule ISA) bytes B1 r"
      and "cap_of_mem_bytes_method CC bytes B1 = Some c"
    then show thesis
      by (intro Update[of k wk bytes r]) (auto simp: nth_append)
  qed
  obtain v tag
    where v: "get_mem_bytes addr (tag_granule ISA) s' = Some (v, tag)"
      and cv: "cap_of_mem_bytes_method CC v tag = Some c"
    using \<open>get_mem_cap addr (tag_granule ISA) s' = Some c\<close>
    by (auto simp: bind_eq_Some_conv bool_of_bitU_def split: if_splits)
  then have tag: "tag = B1" using tagged by auto
  from \<open>s_emit_event e s'' = Some s'\<close> show thesis
  proof (cases rule: emitEventS_update_cases)
    case (Write_mem wk addr' sz' v' tag' r)
    have sz': "tag' = B1 \<longrightarrow> (address_tag_aligned ISA addr' \<and> sz' = tag_granule ISA)"
      and len_v': "length v' = sz'"
      using \<open>store_tag_axiom CC ISA (t @ [e])\<close> Write_mem
      by (auto simp: store_tag_axiom_def writes_mem_val_at_idx_def bind_eq_Some_conv nth_append split: if_splits)
    show ?thesis
    proof cases
      assume addr_disj: "{addr..<tag_granule ISA + addr} \<inter> {addr'..<sz' + addr'} = {}"
      then have "get_mem_bytes addr (tag_granule ISA) s'' = get_mem_bytes addr (tag_granule ISA) s'"
        using Write_mem len_v'
        by (intro get_mem_bytes_cong) (auto simp: memstate_put_mem_bytes tagstate_put_mem_bytes)
      then show thesis
        using v cv tag
        by (intro IH) auto
    next
      assume addr_overlap: "{addr..<tag_granule ISA + addr} \<inter> {addr'..<sz' + addr'} \<noteq> {}"
      then have tag': "tag' = B1"
      proof -
        obtain addr''
          where addr_orig: "addr'' \<in> {addr..<tag_granule ISA + addr}"
            and addr_prime: "addr'' \<in> {addr'..<sz' + addr'}"
          using addr_overlap
          by blast
        have "tagstate s' addr'' = Some B1"
          using addr_orig get_mem_bytes_tagged_tagstate[OF v[unfolded tag]]
          by auto
        then show "tag' = B1"
          using addr_prime Write_mem len_v'
          by (auto simp: tagstate_put_mem_bytes)
      qed
      with addr_overlap aligned sz' have addr': "addr' = addr"
        by (auto simp: address_tag_aligned_def dvd_def mult_Suc_right[symmetric]
                 simp del: mult_Suc_right)
      then have v': "v' = v"
        using v tag tag' sz' len_v' Write_mem
        by (auto simp: get_mem_bytes_put_mem_bytes_same_addr)
      then show thesis
        using Write_mem cv tag' addr' sz' tag
        by (intro Step.prems(2)[of "length t"]) (auto simp: writes_mem_cap_def)
    qed
  next
    case (Write_reg r v rs')
    with \<open>get_mem_cap addr (tag_granule ISA) s' = Some c\<close> show thesis
      by (auto intro: IH simp: get_mem_bytes_def)
  next
    case Read
    with \<open>get_mem_cap addr (tag_granule ISA) s' = Some c\<close> show thesis
      by (auto intro: IH)
  qed
qed auto

lemma reads_mem_cap_at_idx_provenance:
  assumes read: "t ! i = E_read_memt rk addr (tag_granule ISA) (bytes, B1)"
    and c: "cap_of_mem_bytes_method CC bytes B1 = Some c"
    and s': "s_run_trace t s = Some s'"
    and axioms: "cheri_axioms CC ISA is_fetch has_ex inv_caps t"
    and i: "i < length t"
    and tagged: "is_tagged_method CC c"
    and aligned: "address_tag_aligned ISA addr"
  obtains (Initial) "get_mem_cap addr (tag_granule ISA) s = Some c"
  | (Update) k wk bytes' r where "k < i"
    and "t ! k = E_write_memt wk addr (tag_granule ISA) bytes' B1 r"
    and "cap_of_mem_bytes_method CC bytes' B1 = Some c"
proof -
  obtain s''
    where s'': "s_run_trace (take i t) s = Some s''"
      and c': "get_mem_cap addr (tag_granule ISA) s'' = Some c"
    using s' i read c tagged
    by (cases rule: runTraceS_nth_split; cases "t ! i")
       (auto simp: bind_eq_Some_conv reads_mem_cap_def split: if_splits)
  have "store_tag_axiom CC ISA (take i t)"
    using axioms
    by (fastforce simp: cheri_axioms_def store_tag_axiom_def writes_mem_val_at_idx_def bind_eq_Some_conv)
  with c' s'' tagged aligned show thesis
    by (cases rule: get_mem_cap_run_trace_cases) (auto intro: that)
qed

fun s_invariant :: "('regs sequential_state \<Rightarrow> 'a) \<Rightarrow> 'regval trace \<Rightarrow> 'regs sequential_state \<Rightarrow> bool" where
  "s_invariant f [] s = True"
| "s_invariant f (e # t) s = (case s_emit_event e s of Some s' \<Rightarrow> f s' = f s \<and> s_invariant f t s' | None \<Rightarrow> False)"

abbreviation s_invariant_holds :: "('regs sequential_state \<Rightarrow> bool) \<Rightarrow> 'regval trace \<Rightarrow> 'regs sequential_state \<Rightarrow> bool" where
  "s_invariant_holds P t s \<equiv> P s \<and> s_invariant P t s"

lemma s_invariant_append:
  "s_invariant f (\<beta> @ \<alpha>) s \<longleftrightarrow>
   (\<exists>s'. s_invariant f \<beta> s \<and> s_run_trace \<beta> s = Some s' \<and> s_invariant f \<alpha> s')"
  by (induction \<beta> arbitrary: s) (auto split: option.splits simp: runTraceS_Cons_tl)

lemma s_invariant_takeI:
  assumes "s_invariant f t s"
  shows "s_invariant f (take n t) s"
proof -
  from assms have "s_invariant f (take n t @ drop n t) s" by auto
  then show ?thesis unfolding s_invariant_append by auto
qed

lemma s_invariant_run_trace_eq:
  assumes "s_invariant f t s" and "s_run_trace t s = Some s'"
  shows "f s' = f s"
  using assms
  by (induction f t s rule: s_invariant.induct)
     (auto split: option.splits elim: runTraceS_ConsE)

definition no_caps_in_translation_tables :: "'regs sequential_state \<Rightarrow> bool" where
  "no_caps_in_translation_tables s \<equiv>
     \<forall>addr sz c. get_mem_cap addr sz s = Some c \<and> is_tagged_method CC c \<longrightarrow>
                 addr \<notin> s_translation_tables s"

lemma derivable_available_caps_subseteq_reachable_caps:
  assumes axioms: "cheri_axioms CC ISA is_fetch has_ex inv_caps t"
    and t: "s_run_trace t s = Some s'"
    and translation_table_addrs_invariant: "s_invariant s_translation_tables t s"
    and no_caps_in_translation_tables: "s_invariant_holds no_caps_in_translation_tables t s"
  shows "derivable (available_caps CC ISA i t) \<subseteq> reachable_caps s"
proof (induction i rule: less_induct)
  case (less i)
  show ?case proof
    fix c
    assume "c \<in> derivable (available_caps CC ISA i t)"
    then show "c \<in> reachable_caps s"
    proof induction
      fix c
      assume "c \<in> available_caps CC ISA i t"
      then show "c \<in> reachable_caps s"
      proof (cases rule: available_caps_cases)
        case (Reg r v j)
        with t have initial: "c \<in> get_reg_caps r s"
          by (blast intro: reads_reg_cap_at_idx_from_initial)
        show ?thesis
        proof cases
          assume r: "r \<in> privileged_regs ISA"
          then obtain c' where c': "c' \<in> reachable_caps s" and "is_tagged_method CC c'"
            and "\<not>is_sealed_method CC c'" and p: "permit_system_access (get_perms_method CC c')"
            using Reg less.IH[OF \<open>j < i\<close>] derivable_refl[of "available_caps CC ISA j t"]
            by (auto elim!: system_access_permitted_at_idx_available_caps)
          then show ?thesis
            using Reg
            by (auto intro: reachable_caps.SysReg[OF initial r c'])
        next
          assume "r \<notin> privileged_regs ISA"
          then show ?thesis using initial Reg by (auto intro: reachable_caps.Reg)
        qed
      next
        case (Mem wk paddr bytes j sz)
        note read = \<open>t ! j = E_read_memt wk paddr sz (bytes, B1)\<close>
        note bytes = \<open>cap_of_mem_bytes_method CC bytes B1 = Some c\<close>
        have addr: "paddr \<notin> translation_tables ISA (take j t)"
        proof
          assume paddr_j: "paddr \<in> translation_tables ISA (take j t)"
          then have "paddr \<in> s_translation_tables s"
            using translation_tables_sound[of "take j t" s] t \<open>j < length t\<close>
            by (auto elim: runTraceS_nth_split)
          moreover have "paddr \<notin> s_translation_tables s"
          proof -
            obtain s''
              where s'': "s_run_trace (take j t) s = Some s''"
                and c_s'': "get_mem_cap paddr sz s'' = Some c"
              using t \<open>j < length t\<close> read bytes \<open>is_tagged_method CC c\<close>
              by (cases rule: runTraceS_nth_split; cases "t ! j")
                 (auto simp: bind_eq_Some_conv reads_mem_cap_def split: if_splits)
            moreover have "no_caps_in_translation_tables s''"
              using no_caps_in_translation_tables s''
              using s_invariant_takeI[of no_caps_in_translation_tables t s j]
              using s_invariant_run_trace_eq[of no_caps_in_translation_tables "take j t" s s'']
              by auto
            moreover have "s_translation_tables s'' = s_translation_tables s"
              using translation_table_addrs_invariant s''
              by (intro s_invariant_run_trace_eq) (auto intro: s_invariant_takeI)
            ultimately show ?thesis
              using \<open>is_tagged_method CC c\<close>
              by (fastforce simp: no_caps_in_translation_tables_def bind_eq_Some_conv)
          qed
          ultimately show False by blast
        qed
        then obtain vaddr c'
          where vaddr: "translate_address ISA vaddr Load (take j t) = Some paddr"
            and c': "c' \<in> derivable (available_caps CC ISA j t)"
                    "is_tagged_method CC c'" "\<not>is_sealed_method CC c'"
                    "set (address_range vaddr sz) \<subseteq> get_mem_region_method CC c'"
                    "permit_load (get_perms_method CC c')"
                    "permit_load_capability (get_perms_method CC c')"
            and sz: "sz = tag_granule ISA"
            and aligned: "address_tag_aligned ISA paddr"
          using read t axioms \<open>j < length t\<close> \<open>is_tagged_method CC c\<close>
          unfolding cheri_axioms_def load_mem_axiom_def reads_mem_cap_def
          by (fastforce simp: reads_mem_val_at_idx_def bind_eq_Some_conv cap_derivable_iff_derivable split: if_splits)
        have s_vaddr: "s_translate_address vaddr Load s = Some paddr"
          using vaddr t \<open>j < length t\<close>
          by (blast intro: translate_address_sound[of "take j t"] elim: runTraceS_nth_split)
        from read[unfolded sz] bytes t axioms \<open>j < length t\<close> \<open>is_tagged_method CC c\<close> aligned
        show ?thesis
        proof (cases rule: reads_mem_cap_at_idx_provenance)
          case Initial
          then show ?thesis
            using Mem s_vaddr less.IH[of j] c' aligned sz
            by (intro reachable_caps.Mem[of paddr s c vaddr c'])
               (auto simp: bind_eq_Some_conv translate_address_tag_aligned_iff permits_cap_load_def)
        next
          case (Update k wk bytes' r)
          then show ?thesis
            using axioms \<open>is_tagged_method CC c\<close> \<open>j < length t\<close> \<open>j < i\<close> less.IH[of k]
            unfolding cheri_axioms_def store_cap_mem_axiom_def
            by (auto simp: writes_mem_cap_at_idx_def writes_mem_cap_Some_iff bind_eq_Some_conv cap_derivable_iff_derivable)
        qed
      qed
    qed (auto intro: reachable_caps.intros)
  qed
qed

lemma put_regval_get_mem_cap:
  assumes s': "put_reg_val r v s = Some s'"
    and "s_translate_address addr acctype s' = s_translate_address addr acctype s"
  shows "get_mem_cap addr sz s' = get_mem_cap addr sz s"
  using assms by (auto cong: bind_option_cong simp: get_mem_bytes_def)

definition system_access_reachable :: "'regs sequential_state \<Rightarrow> bool" where
  "system_access_reachable s \<equiv> \<exists>c \<in> reachable_caps s.
     permit_system_access (get_perms_method CC c) \<and> \<not>is_sealed_method CC c"

lemma get_reg_cap_intra_domain_trace_reachable:
  assumes r: "c \<in> get_reg_caps r s'"
    (*and t: "hasTrace t (instr_sem ISA instr)"*) and s': "s_run_trace t s = Some s'"
    and axioms: "cheri_axioms CC ISA is_fetch False False t"
    (*and no_exception: "\<not>hasException t (instr_sem ISA instr)"
    and no_ccall: "invoked_caps ISA instr t = {}"*)
    and translation_table_addrs_invariant: "s_invariant s_translation_tables t s"
    and no_caps_in_translation_tables: "s_invariant_holds no_caps_in_translation_tables t s"
    and tag: "is_tagged_method CC c"
    and priv: "r \<in> privileged_regs ISA \<longrightarrow> system_access_reachable s"
  shows "c \<in> reachable_caps s"
proof -
  from r obtain v where v: "get_reg_val r s' = Some v" and c: "c \<in> caps_of_regval ISA v"
    by (auto simp: bind_eq_Some_conv split: option.splits)
  from v c s' show "c \<in> reachable_caps s"
  proof (cases rule: get_reg_val_s_run_trace_cases)
    case Init
    show ?thesis
    proof cases
      assume r: "r \<in> privileged_regs ISA"
      with priv obtain c' where c': "c' \<in> reachable_caps s"
        and "permit_system_access (get_perms_method CC c')" and "\<not>is_sealed_method CC c'"
        by (auto simp: system_access_reachable_def)
      then show ?thesis using Init c tag by (intro reachable_caps.SysReg[OF _ r c']) auto
    next
      assume "r \<notin> privileged_regs ISA"
      then show ?thesis using Init c tag by (intro reachable_caps.Reg) auto
    qed
  next
    case (Update j v')
    then have *: "c \<in> writes_reg_caps CC (caps_of_regval ISA) (t ! j)"
      and "writes_to_reg (t ! j) = Some r"
      using c tag by auto
    then have "c \<in> derivable (available_caps CC ISA j t)"
      using axioms tag \<open>j < length t\<close>
      unfolding cheri_axioms_def store_cap_reg_axiom_def
      by (fastforce simp: cap_derivable_iff_derivable)
    moreover have "derivable (available_caps CC ISA j t) \<subseteq> reachable_caps s"
      using axioms s' translation_table_addrs_invariant no_caps_in_translation_tables
      by (intro derivable_available_caps_subseteq_reachable_caps)
    ultimately show ?thesis by auto
  qed
qed

lemma reachable_caps_trace_intradomain_monotonicity:
  assumes axioms: "cheri_axioms CC ISA is_fetch False False t"
    and s': "s_run_trace t s = Some s'"
    and addr_trans_inv: "s_invariant (\<lambda>s' addr load. s_translate_address addr load s') t s"
    and translation_table_addrs_invariant: "s_invariant s_translation_tables t s"
    and no_caps_in_translation_tables: "s_invariant_holds no_caps_in_translation_tables t s"
  shows "reachable_caps s' \<subseteq> reachable_caps s"
proof
  fix c
  assume "c \<in> reachable_caps s'"
  then show "c \<in> reachable_caps s"
  proof induction
    case (Reg r c)
    then show ?case
      using axioms s' translation_table_addrs_invariant no_caps_in_translation_tables
      by (intro get_reg_cap_intra_domain_trace_reachable) auto
  next
    case (SysReg r c c')
    then show ?case
      using axioms s' translation_table_addrs_invariant no_caps_in_translation_tables
      by (intro get_reg_cap_intra_domain_trace_reachable) (auto simp: system_access_reachable_def)
  next
    case (Mem addr c vaddr c')
    then have c: "get_mem_cap addr (tag_granule ISA) s' = Some c"
      and aligned: "address_tag_aligned ISA addr"
      by (auto split: if_splits)
    have axiom: "store_tag_axiom CC ISA t"
      using axioms
      by (auto simp: cheri_axioms_def)
    from c s' \<open>is_tagged_method CC c\<close> aligned axiom show ?case
    proof (cases rule: get_mem_cap_run_trace_cases)
      case Initial
      have "s_translate_address vaddr Load s' = s_translate_address vaddr Load s"
        using s_invariant_run_trace_eq[OF addr_trans_inv s']
        by meson
      then show ?thesis
        using Initial Mem
        by (intro reachable_caps.Mem[of addr s c vaddr c']) (auto split: if_splits)
    next
      case (Update k wk bytes r)
      have "derivable (available_caps CC ISA k t) \<subseteq> reachable_caps s"
        using assms axioms
        by (intro derivable_available_caps_subseteq_reachable_caps)
      then show ?thesis
        using Update \<open>is_tagged_method CC c\<close> axioms
        unfolding cheri_axioms_def store_cap_mem_axiom_def cap_derivable_iff_derivable
        by (auto simp: writes_mem_cap_at_idx_def writes_mem_cap_Some_iff)
    qed
  qed (auto intro: reachable_caps.intros)
qed

lemma reachable_caps_instr_trace_intradomain_monotonicity:
  assumes t: "hasTrace t (instr_sem ISA instr)"
    and ta: "instr_assms t"
    and s': "s_run_trace t s = Some s'"
    and no_exception: "\<not>instr_raises_ex ISA instr t"
    and no_ccall: "\<not>invokes_caps ISA instr t"
    and addr_trans_inv: "s_invariant (\<lambda>s' addr load. s_translate_address addr load s') t s"
    and translation_table_addrs_invariant: "s_invariant s_translation_tables t s"
    and no_caps_in_translation_tables: "s_invariant_holds no_caps_in_translation_tables t s"
  shows "reachable_caps s' \<subseteq> reachable_caps s"
  using assms instr_cheri_axioms[OF t ta]
  by (intro reachable_caps_trace_intradomain_monotonicity) auto

lemma reachable_caps_fetch_trace_intradomain_monotonicity:
  assumes t: "hasTrace t (instr_fetch ISA)"
    and ta: "fetch_assms t"
    and s': "s_run_trace t s = Some s'"
    and no_exception: "\<not>fetch_raises_ex ISA t"
    and addr_trans_inv: "s_invariant (\<lambda>s' addr load. s_translate_address addr load s') t s"
    and translation_table_addrs_invariant: "s_invariant s_translation_tables t s"
    and no_caps_in_translation_tables: "s_invariant_holds no_caps_in_translation_tables t s"
  shows "reachable_caps s' \<subseteq> reachable_caps s"
  using assms fetch_cheri_axioms[OF t ta]
  by (intro reachable_caps_trace_intradomain_monotonicity) auto

end

text \<open>Multi-instruction sequences\<close>

fun fetch_execute_loop :: "('cap, 'regval, 'instr, 'e) isa \<Rightarrow> nat \<Rightarrow> ('regval, unit, 'e) monad" where
  "fetch_execute_loop ISA (Suc bound) = (instr_fetch ISA \<bind> instr_sem ISA) \<then> fetch_execute_loop ISA bound"
| "fetch_execute_loop ISA 0 = return ()"

fun instrs_raise_ex :: "('cap, 'regval, 'instr, 'e) isa \<Rightarrow> nat \<Rightarrow> 'regval trace \<Rightarrow> bool" where
  "instrs_raise_ex ISA (Suc bound) t =
    (\<exists>tf t'. t = tf @ t' \<and> hasTrace tf (instr_fetch ISA) \<and>
             (fetch_raises_ex ISA tf \<or>
              (\<exists>instr ti t''. t' = ti @ t'' \<and>
                 runTrace tf (instr_fetch ISA) = Some (Done instr) \<and>
                 hasTrace ti (instr_sem ISA instr) \<and>
                 (instr_raises_ex ISA instr ti \<or>
                  instrs_raise_ex ISA bound t''))))"
| "instrs_raise_ex ISA 0 t = False"

fun instrs_invoke_caps :: "('cap, 'regval, 'instr, 'e) isa \<Rightarrow> nat \<Rightarrow> 'regval trace \<Rightarrow> bool" where
  "instrs_invoke_caps ISA (Suc bound) t =
    (\<exists>tf t'. t = tf @ t' \<and> hasTrace tf (instr_fetch ISA) \<and>
          (\<exists>instr ti t''. t' = ti @ t'' \<and>
             runTrace tf (instr_fetch ISA) = Some (Done instr) \<and>
             hasTrace ti (instr_sem ISA instr) \<and>
             (invokes_caps ISA instr ti \<or>
              instrs_invoke_caps ISA bound t'')))"
| "instrs_invoke_caps ISA 0 t = False"

context CHERI_ISA_State
begin

lemma reachable_caps_instrs_trace_intradomain_monotonicity:
  assumes t: "hasTrace t (fetch_execute_loop ISA n)"
    and ta: "fetch_assms t"
    and s': "s_run_trace t s = Some s'"
    and no_exception: "\<not>instrs_raise_ex ISA n t"
    and no_ccall: "\<not>instrs_invoke_caps ISA n t"
    and addr_trans_inv: "s_invariant (\<lambda>s' addr load. s_translate_address addr load s') t s"
    and translation_table_addrs_invariant: "s_invariant s_translation_tables t s"
    and no_caps_in_translation_tables: "s_invariant_holds no_caps_in_translation_tables t s"
  shows "reachable_caps s' \<subseteq> reachable_caps s"
proof (use assms in \<open>induction n arbitrary: s t\<close>)
  case 0
  then show ?case by (auto simp: return_def hasTrace_iff_Traces_final)
next
  case (Suc n)
  then obtain m'
    where "(instr_fetch ISA \<bind> (\<lambda>instr. \<lbrakk>instr\<rbrakk> \<then> fetch_execute_loop ISA n), t, m') \<in> Traces"
    and m': "final m'"
    by (auto simp: hasTrace_iff_Traces_final)
  then show ?case
  proof (cases rule: bind_Traces_cases)
    case (Left m'')
    then have "hasTrace t (instr_fetch ISA)"
      using m'
      by (auto elim!: final_bind_cases) (auto simp: hasTrace_iff_Traces_final final_def)
    then show ?thesis
      using Suc.prems
      by (intro reachable_caps_fetch_trace_intradomain_monotonicity) auto
  next
    case (Bind tf instr t')
    obtain s'' where s'': "s_run_trace tf s = Some s''" and t': "s_run_trace t' s'' = Some s'"
      using Bind Suc
      by (auto elim: runTraceS_appendE)
    have tf: "hasTrace tf (instr_fetch ISA)"
      using Bind
      by (auto simp: hasTrace_iff_Traces_final final_def)
    have invs':
      "s_invariant (\<lambda>s' addr load. s_translate_address addr load s') t' s''"
      "s_invariant s_translation_tables t' s''"
      "s_invariant_holds no_caps_in_translation_tables t' s''"
      using tf s'' Bind Suc.prems
      using s_invariant_run_trace_eq[of no_caps_in_translation_tables tf s s'']
      by (auto simp: s_invariant_append)
    have ta': "fetch_assms tf" "instr_assms t'"
      using Bind Suc.prems fetch_assms_appendE
      by auto
    from \<open>(\<lbrakk>instr\<rbrakk> \<then> fetch_execute_loop ISA n, t', m') \<in> Traces\<close>
    have "reachable_caps s' \<subseteq> reachable_caps s''"
    proof (cases rule: bind_Traces_cases)
      case (Left m'')
      then have "hasTrace t' \<lbrakk>instr\<rbrakk>"
        using m'
        by (auto elim!: final_bind_cases) (auto simp: hasTrace_iff_Traces_final final_def)
      then show ?thesis
        using tf t' s'' Bind Suc.prems invs' ta'
        by (intro reachable_caps_instr_trace_intradomain_monotonicity)
           (auto simp: runTrace_iff_Traces)
    next
      case (Bind ti am t'')
      obtain s''' where s''': "s_run_trace ti s'' = Some s'''" and t'': "s_run_trace t'' s''' = Some s'"
        using Bind t'
        by (auto elim: runTraceS_appendE)
      have ti: "hasTrace ti \<lbrakk>instr\<rbrakk>"
        using Bind
        by (auto simp: hasTrace_iff_Traces_final final_def)
      have invs'':
        "s_invariant (\<lambda>s' addr load. s_translate_address addr load s') t'' s'''"
        "s_invariant s_translation_tables t'' s'''"
        "s_invariant_holds no_caps_in_translation_tables t'' s'''"
        using invs' s''' Bind
        using s_invariant_run_trace_eq[of no_caps_in_translation_tables ti s'' s''']
        by (auto simp: s_invariant_append)
      have ta'': "instr_assms ti" "fetch_assms t''"
        using Bind ta' instr_assms_appendE
        by auto
      have no_exception': "\<not>fetch_raises_ex ISA tf" "\<not>instr_raises_ex ISA instr ti"
        and no_ccall': "\<not>invokes_caps ISA instr ti"
        and no_exception'': "\<not>instrs_raise_ex ISA n t''"
        and no_ccall'': "\<not>instrs_invoke_caps ISA n t''"
        using ti tf Suc.prems Bind \<open>t = tf @ t'\<close>
        using \<open>Run (instr_fetch ISA) tf instr\<close>
        by (auto simp: runTrace_iff_Traces)
      then have "reachable_caps s' \<subseteq> reachable_caps s'''"
        using Bind m' t'' invs'' ta''
        by (intro Suc.IH) (auto simp: hasTrace_iff_Traces_final final_def)
      also have "reachable_caps s''' \<subseteq> reachable_caps s''"
        using ti s''' no_exception' no_ccall' invs' \<open>t' = ti @ t''\<close> ta''
        by (intro reachable_caps_instr_trace_intradomain_monotonicity)
           (auto simp: s_invariant_append)
      finally show ?thesis .
    qed
    also have "reachable_caps s'' \<subseteq> reachable_caps s"
      using tf s'' Bind Suc.prems ta'
      by (intro reachable_caps_fetch_trace_intradomain_monotonicity)
         (auto simp: s_invariant_append)
    finally show ?thesis .
  qed
qed

end

end


(*
 * Copyright 2016, NICTA
 *
 * 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(NICTA_GPL)
 *)

theory FsopSyncR
imports
  "../lib/CogentCorres"
  "../refine/AfsFsopR"
  "../refine/OstoreR"
begin

definition
 rsync_res :: "(afs_state \<times> (unit,ErrCode) R\<^sub>T) \<Rightarrow> FsopFsP\<^sub>T \<times> (32 word, unit) R \<Rightarrow> bool"
where
 "rsync_res \<equiv> (\<lambda>(afs, ra) (fsr, rc). ra = rc \<and> afs_fsop_rel afs (FsopFsP.fs_st\<^sub>f fsr))"

lemmas rsync_simp = rsync_res_def afs_fsop_rel_def Let_def
   afmsu_def afs_fsop_match_step_updates_def match_afs_data_fs_state_def

lemma fold_comp[rule_format]:
  "xs = ys @ zs \<longrightarrow> fold f xs accu = (fold f zs (fold f ys accu))"
  by (induct_tac xs, simp+)

lemma corres_sync_err:
"afs_fsop_rel afs fs_st \<Longrightarrow>
 cogent_corres rsync_res (return (afs, R.Error e)) (\<lparr>FsopFsP.ex\<^sub>f = ex, fs_st\<^sub>f = fs_st\<rparr>, R.Error e)"
  by (simp add: rsync_res_def cogent_corres_def  return_def)

lemma length_updates_eqD:
 "afs_fsop_rel afs fs_st \<Longrightarrow>
 length (\<alpha>_updates (FsState.ostore_st\<^sub>f fs_st)) = length (a_medium_updates afs)"
 by (clarsimp simp: rsync_simp)

lemma afs_fsop_match_updates:
 "afs_fsop_match (fold id xs' a) (fold id ys' c) \<Longrightarrow> xs' = xs \<Longrightarrow> ys' = ys \<Longrightarrow>
  afs_fsop_match (fold id xs a) (fold id ys c)"
by simp

lemma updates_take_eq:
 "na \<le> (length xs - n) \<Longrightarrow>
  n \<le> length xs \<Longrightarrow>
  length xs = length ys \<Longrightarrow>
  take (min (length ys) n + min (length (drop n ys)) na) xs =
    take n xs @ take na (drop n xs)"
  by (simp add: min_absorb2 take_add)

lemma refine_sync:
notes length_drop[simp del]
assumes rel:"afs_fsop_rel afs fs_st"
shows
  "\<And>ex. cogent_corres rsync_res
         (afs_sync afs) (fsop_sync_fs (FsopFsP.make ex fs_st))"
  unfolding afs_sync_def fsop_sync_fs_def[simplified tuple_simps sanitizers, folded eIO_def]
using [[goals_limit=5]]
  apply (rule cogent_corres_conc_let_exec, simp only: prod.case_eq_if)
  apply (rule cogent_corres_conc_let_exec, simp only: prod.case_eq_if)
  apply (rule cogent_corres_if)
    apply (simp add: FsopFsP.make_def)
    apply (fold eRoFs_def)
    apply (rule corres_sync_err[OF rel])
   apply (rule cogent_corres_conc_let_exec, simp only: prod.case_eq_if)
   apply (rule cogent_corres_conc_let_exec, simp only: prod.case_eq_if)
   apply (simp only:  FsopFsP.defs)
   apply (fold ostoreWriteNone_def)

  apply (rule ostore_sync_ret)
       using rel apply (simp add: rsync_simp)
      using rel apply (simp add: rsync_simp)
     using rel apply (simp add: rsync_simp)
     apply (clarsimp)
    apply (rule_tac v="length (a_medium_updates afs)" in cogent_corres_select, simp)
    apply (simp add: Let_def)
    apply (rule cogent_corres_return)
    using rel apply (clarsimp simp add: rsync_simp prod.case_eq_if)
    apply (erule_tac x="length (a_medium_updates afs)" in allE)
    apply (clarsimp simp: updated_afs_def id_def a_afs_updated_def \<alpha>_ostore_uptodate_def)
    apply (drule afs_inv_steps_updated_afsD)
    apply (simp add: afs_inv_steps_def updated_afs_def a_afs_updated_def id_def)
   apply clarsimp
   apply (rule_tac v="n" in cogent_corres_select)
    apply (simp)
    using length_updates_eqD[OF rel]
    apply simp
   using length_updates_eqD[OF rel]
   apply (simp add: Let_def)
   apply (rule_tac v="e" in cogent_corres_select, simp)
   apply (rule cogent_corres_return)
   using rel apply (clarsimp simp add: rsync_simp updated_afs_def)
    apply (rule conjI)
    apply (simp add: afs_inv_steps_def updated_afs_def a_afs_updated_def id_def)
     apply (fold id_def)
     apply clarsimp
     apply (subst fold_comp[symmetric], rule refl)+
     apply (erule_tac x="n+na" in allE)
     apply (fastforce simp add: take_add length_drop)
   apply (rule conjI)
    using length_updates_eqD[OF rel]
    apply (fastforce simp add: length_drop)
   apply clarsimp
    apply (rename_tac na)
    apply (erule_tac x="n + na" in allE)
    apply (erule impE)
     apply (drule sym[where s="length _" and t = "length _"])
     apply (simp only: length_drop)
     apply (subst fold_comp[symmetric], rule refl)+
     apply (erule afs_fsop_match_updates)
     apply (fastforce simp only: take_add)+
   using rel
   apply (simp add: rsync_simp FsopFsP.defs)
 done
end


(*<*)

(* Author: Kyndylan Nienhuis *)

theory UnsealCap

imports
  "UnpredictableBehaviour"
  "ExceptionFlag"
  "ExecutionStep"
begin

(*>*)
section \<open>Semantics of @{const UnsealCapAction}\<close>

definition SemanticsUnsealPost where
  "SemanticsUnsealPost authCap cap cd' \<equiv>
   return (getSealed cap \<and>
           Permit_Unseal (getPerms authCap) \<and>
           getTag authCap \<and>
           \<not> getSealed authCap \<and>
           ucast (getType cap) \<in> RegionOfCap authCap) \<and>\<^sub>b
   bind (read_state (getCAPR cd'))
        (\<lambda>cap'. return (cap' \<le> setType (setSealed (cap, False), 0)))"

lemma Commute_SemanticsUnsealPost [Commute_compositeI]:
  assumes "Commute (read_state (getCAPR cd')) m"
  shows "Commute (SemanticsUnsealPost authCap cap cd') m"
unfolding SemanticsUnsealPost_def
by (Commute intro: assms)

lemma SemanticsUnseal_CUnseal_aux:
  fixes x y z :: "'a::len0 word"
  shows "(x + y = z) \<longleftrightarrow> (z - x = y)"
by auto

lemma SemanticsUnseal_CUnseal:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getCAPR cd)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind (CUnsealActions v) (\<lambda>prov. return (UnsealCapAction auth cd cd' \<in> prov)))
                 (dfn'CUnseal v)
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsUnsealPost authCap cap cd' \<and>\<^sub>b
                      return authAccessible)"
unfolding dfn'CUnseal_alt_def CUnsealActions_def
unfolding SemanticsUnsealPost_def
by (HoareTriple intro: nonExceptionCase_exceptions[THEN HoareTriple_post_weakening])
   (auto simp: not_less not_le setPerms_le
               Region_member_simp
               SemanticsUnseal_CUnseal_aux
         split: if_splits
         elim!: notE[OF _ rec'Perms_AND_leq_forget_right])

lemma SemanticsUnseal_Run_aux:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getCAPR cd)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind (RunActions v) (\<lambda>prov. return (UnsealCapAction auth cd cd' \<in> prov)))
                 (Run v)
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsUnsealPost authCap cap cd' \<and>\<^sub>b
                      return authAccessible)"
unfolding Run_alt_def RunActions_def HoareTriple_def
using HoareTripleE[OF SemanticsUnseal_CUnseal]
by (auto simp: ValueAndStatePart_simp split: all_split)

lemmas SemanticsUnseal_Run =
  HoareTriple_weakest_pre_disj[OF SemanticsUnseal_Run_aux
                              UndefinedCase_Run]

lemma SemanticsUnseal_Fetch:
  fixes auth cd cd' authCap cap cdAccessible cd'Accessible authAccessible
  defines "p \<equiv> \<lambda>w. (return cap =\<^sub>b read_state (getCAPR cd)) \<and>\<^sub>b
                    (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                    (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                    bind (RunActions (Decode w)) (\<lambda>ac. return (UnsealCapAction auth cd cd' \<in> ac))"
  shows "HoareTriple (bind NextInstruction (case_option (return True) p))
                  Fetch
                  (\<lambda>b. case b of None \<Rightarrow> read_state getExceptionSignalled
                               | Some y \<Rightarrow> read_state isUnpredictable \<or>\<^sub>b p y)"
unfolding p_def
by (intro HoareTriple_Fetch) Commute+

lemma SemanticsUnseal_NextWithGhostState:
  shows "HoareTriple ((return cap =\<^sub>b read_state (getCAPR cd)) \<and>\<^sub>b
                  (return authCap =\<^sub>b read_state (getCapReg auth)) \<and>\<^sub>b
                  (return authAccessible =\<^sub>b read_state (getRegisterIsAccessible auth)) \<and>\<^sub>b
                  bind DomainActions (\<lambda>prov. return (UnsealCapAction auth cd cd' \<in> prov)))
                 NextWithGhostState
                 (\<lambda>_. read_state getExceptionSignalled \<or>\<^sub>b
                      read_state isUnpredictable \<or>\<^sub>b
                      SemanticsUnsealPost authCap cap cd' \<and>\<^sub>b
                      return authAccessible)"
proof -
  note intros = SemanticsUnseal_Run[where cap=cap and authCap=authCap and
                                          auth=auth and cd=cd and cd'=cd' and
                                          authAccessible=authAccessible]
                SemanticsUnseal_Fetch[where cap=cap and authCap=authCap and
                                            auth=auth and cd=cd and cd'=cd' and
                                            authAccessible=authAccessible]
  show ?thesis
    unfolding NextWithGhostState_def DomainActions_def
    by (HoareTriple intro: intros[THEN HoareTriple_post_weakening] UndefinedCase_TakeBranch)
       (auto split: option.splits)
qed

theorem SemanticsUnsealCap:
  assumes prov: "UnsealCapAction auth cd cd' \<in> actions"
      and suc: "(PreserveDomain actions, s') \<in> SemanticsCheriMips s"
  shows "Permit_Unseal (getPerms (getCapReg auth s))"
        "getTag (getCapReg auth s)"
        "\<not> getSealed (getCapReg auth s)"
        "ucast (getType (getCAPR cd s)) \<in> RegionOfCap (getCapReg auth s)"
        "getSealed (getCAPR cd s)"
        "getRegisterIsAccessible auth s"
        "getCAPR cd' s' \<le> setType (setSealed ((getCAPR cd s), False), 0)"
using assms
using SemanticsUnseal_NextWithGhostState
         [where cap="getCAPR cd s" and cd=cd and cd'=cd' and
                authCap="getCapReg auth s" and auth=auth and
                authAccessible="getRegisterIsAccessible auth s",
          THEN HoareTripleE[where s=s]]
unfolding SemanticsUnsealPost_def
unfolding SemanticsCheriMips_def Next_NextWithGhostState NextNonExceptionStep_def
by (auto simp: ValueAndStatePart_simp split: if_splits option.splits)

corollary UnsealCapInstantiation:
  assumes "(lbl, s') \<in> SemanticsCheriMips s"
  shows "UnsealCapProp s lbl s'"
unfolding UnsealCapProp_def
using assms SemanticsUnsealCap
by auto

(*<*)
end
(*>*)


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__43_on_rules imports n_german_lemma_on_inv__43
begin
section{*All lemmas on causal relation between inv__43*}
lemma lemma_inv__43_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__43  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__43) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

end