theory MMU_Instants_TLB_Tag
imports
  Simp_Lemmas_ASIDs
  TLBJ.ARM_Monadic

begin

datatype asid_flush_type = FlushASID asid
                         | FlushASIDvarange  asid "vaddr set"

class  mmu_extended = mmu +
  fixes update_ASID      :: "asid \<Rightarrow> 'a state_scheme \<Rightarrow>  unit \<times> 'a state_scheme"
  fixes flush_with_ASID  :: "asid_flush_type \<Rightarrow>'a state_scheme \<Rightarrow>  unit \<times> 'a state_scheme"

definition
  flush_tlb_asid :: "tlb_with_asids \<Rightarrow> asid \<Rightarrow> tlb_with_asids"
where
  "flush_tlb_asid t a =  t - {e\<in>t. asid_of e = Some a}"

definition
  flush_tlb_a_vset :: "tlb_with_asids \<Rightarrow> asid \<Rightarrow> vaddr set \<Rightarrow> tlb_with_asids"
where
  "flush_tlb_a_vset t a vset = t - (\<Union>v\<in>vset. {e\<in>t. v \<in> range_of e \<and> asid_of e = Some a})"

record non_det_tlb_state = state +
           non_det_asid :: asid
           non_det_tlb  :: "asid tlb"

record det_tlb_state = state +
           det_asid :: asid
           det_tlb  :: "asid tlb"

record sat_tlb_state = state +
           sat_asid :: asid
           sat_tlb  :: "asid tlb"

record set_tlb =
  iset       :: "vaddr set"
  global_set :: "vaddr set" (* "(asid tlb_entry) set" *)
  snapshot   :: "asid \<Rightarrow> (vaddr set \<times> (vaddr \<Rightarrow> asid tlb_entry option))"

record set_tlb_state  = state +
            set_asid :: asid
            set_tlb  :: set_tlb

definition
  typ_non_det_tlb :: "'a non_det_tlb_state_scheme \<Rightarrow> (asid \<times> asid tlb_entry set) state_scheme"
where
  "typ_non_det_tlb s =  state.extend (state.truncate s) (non_det_asid s, non_det_tlb s)"

definition
  typ_det_tlb :: "'a det_tlb_state_scheme \<Rightarrow> (asid \<times> asid tlb_entry set) state_scheme"
where
  "typ_det_tlb s =  state.extend (state.truncate s) (det_asid  s, det_tlb s)"

definition
  typ_sat_tlb :: "'a sat_tlb_state_scheme \<Rightarrow> (asid \<times> asid tlb_entry set) state_scheme"
where
  "typ_sat_tlb s =  state.extend (state.truncate s) (sat_asid s, sat_tlb s)"

definition
  typ_set_tlb :: "'a set_tlb_state_scheme \<Rightarrow> (asid \<times> set_tlb) state_scheme"
where
  "typ_set_tlb s =  state.extend (state.truncate s) (set_asid s, set_tlb s)"

lemma non_det_tlb_more [simp]:
  "state.more (typ_non_det_tlb s) = (non_det_asid s, non_det_tlb s)"
  by (clarsimp simp: typ_non_det_tlb_def state.defs)

lemma det_tlb_more [simp]:
  "state.more (typ_det_tlb s) = (det_asid  s, det_tlb s)"
  by (clarsimp simp: typ_det_tlb_def state.defs)

lemma sat_tlb_more [simp]:
  "state.more (typ_sat_tlb s) = (sat_asid s, sat_tlb s)"
  by (clarsimp simp: typ_sat_tlb_def state.defs)

lemma set_tlb_more' [simp]:
  "state.more (typ_set_tlb s) = (set_asid s, set_tlb s)"
  by (clarsimp simp: typ_set_tlb_def state.defs)

lemma non_det_tlb_truncate [simp]:
  "state.truncate (typ_non_det_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_non_det_tlb_def state.defs)

lemma det_tlb_truncate [simp]:
  "state.truncate (typ_det_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_det_tlb_def state.defs)

lemma sat_tlb_truncate [simp]:
  "state.truncate (typ_sat_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_sat_tlb_def state.defs)

lemma set_tlb_truncate [simp]:
  "state.truncate (typ_set_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_set_tlb_def state.defs)

lemma typ_non_det_prim_parameter [simp]:
  " TTBR0 (typ_non_det_tlb s) =  TTBR0 s \<and>
           MEM (typ_non_det_tlb s) = MEM s \<and> exception (typ_non_det_tlb s) = exception s"
  by (clarsimp simp: typ_non_det_tlb_def  state.defs)

lemma typ_det_prim_parameter [simp]:
  "TTBR0 (typ_det_tlb s) =  TTBR0 s \<and> MEM (typ_det_tlb s) = MEM s \<and> exception (typ_det_tlb s) = exception s"
  by (clarsimp simp: typ_det_tlb_def  state.defs)

lemma typ_sat_prim_parameter [simp]:
  "TTBR0 (typ_sat_tlb s) =  TTBR0 s \<and> MEM (typ_sat_tlb s) = MEM s \<and> exception (typ_sat_tlb s) = exception s"
  by (clarsimp simp: typ_sat_tlb_def  state.defs)

lemma typ_set_prim_parameter [simp]:
  "TTBR0 (typ_set_tlb s) =  TTBR0 s \<and> MEM (typ_set_tlb s) = MEM s \<and> exception (typ_set_tlb s) = exception s"
  by (clarsimp simp: typ_set_tlb_def  state.defs)

abbreviation
  "consistent (s:: (asid \<times> asid tlb_entry set) state_scheme) \<equiv>
               consistent0  (lookup'' (snd (state.more s)) (fst (state.more s))) (pt_walk (fst (state.more s)) (MEM s) (TTBR0 s))"

definition
  saturated :: "(asid \<times> asid tlb_entry set) state_scheme \<Rightarrow> bool"
where
  "saturated s  \<equiv> the ` {e\<in>pt_walk (fst (state.more s)) (MEM s) (TTBR0 s) ` UNIV. \<not>is_fault e} \<subseteq> snd (state.more s)"

definition
  tlb_rel_det :: "(asid \<times> asid tlb_entry set)  state_scheme \<Rightarrow>(asid \<times> asid tlb_entry set)  state_scheme \<Rightarrow> bool"
where
  "tlb_rel_det s t \<equiv> state.truncate s = state.truncate t \<and>  fst(state.more s) = fst(state.more t) \<and>  snd(state.more s) \<subseteq> snd(state.more t)"

definition
  tlb_rel_sat :: "(asid \<times> asid tlb_entry set) state_scheme \<Rightarrow> (asid \<times> asid tlb_entry set) state_scheme \<Rightarrow> bool"
where
  "tlb_rel_sat s t \<equiv> state.truncate s = state.truncate t \<and> fst(state.more s) = fst(state.more t) \<and>  snd(state.more s) \<subseteq> snd(state.more t)  \<and>  saturated t"

definition
   inconsistent_vaddrs :: "(asid \<times> asid tlb_entry set) state_scheme \<Rightarrow>  vaddr set"
where
  "inconsistent_vaddrs s  \<equiv>  {va. lookup'' (snd(state.more s)) (fst(state.more s)) va = Incon}"

definition
   incoherrent_vaddrs :: "(asid \<times> asid tlb_entry set) state_scheme \<Rightarrow>  vaddr set"
where
  "incoherrent_vaddrs s  \<equiv> {va. \<exists>x. lookup'' (snd(state.more s)) (fst(state.more s)) va = Hit x \<and>
                               is_fault (pt_walk  (fst(state.more s)) (MEM s) (TTBR0 s) va)} "

definition
   incon_addrs :: "(asid \<times> asid tlb_entry set) state_scheme \<Rightarrow>  vaddr set"
where
  "incon_addrs s  \<equiv>  inconsistent_vaddrs s \<union> incoherrent_vaddrs s"

definition
  snap_conv' :: "(vaddr set \<times> (vaddr \<Rightarrow> asid tlb_entry option)) \<Rightarrow> (vaddr \<Rightarrow> asid tlb_entry lookup_type)"
  where
  "snap_conv' snp  \<equiv> \<lambda>v. if v \<in> (fst snp) then Incon else
                          case (snd snp) v of None         \<Rightarrow> Miss
                                           |  Some entry   \<Rightarrow> if asid_of entry = None then Miss else Hit entry"

definition
   "lookup_from' snp a v \<equiv> snap_conv' (snp a) v"

definition
  tlb_rel_abs :: "(asid \<times> asid tlb_entry set) state_scheme  \<Rightarrow> (asid \<times> set_tlb) state_scheme \<Rightarrow> bool"
where
"tlb_rel_abs s t \<equiv>  state.truncate s = state.truncate t \<and> fst(state.more s) = fst(state.more t) \<and>
                     saturated s \<and>
                     incon_addrs s \<subseteq>  iset (snd(state.more t)) \<and>
                      \<Union>(range_of `  global_entries (snd(state.more s))) \<subseteq>  global_set (snd(state.more t)) \<and>
                     (\<forall>a v. a \<noteq> fst (state.more s) \<longrightarrow>  lookup'' (snd (state.more s) - global_entries (snd (state.more s))) a v \<le>
                                                          lookup_from' (snapshot (snd (state.more t))) a v)"
(*
definition
  tlb_rel_abs :: "(asid \<times> asid tlb_entry set) state_scheme  \<Rightarrow> (asid \<times> set_tlb) state_scheme \<Rightarrow> bool"
where
"tlb_rel_abs s t \<equiv>  state.truncate s = state.truncate t \<and> fst(state.more s) = fst(state.more t) \<and>
                     saturated s \<and>
                     incon_addrs s \<subseteq>  iset (snd(state.more t)) \<and>
                     global_entries (snd(state.more s)) \<subseteq>  global_set (snd(state.more t)) \<and>
                     (\<forall>a v. a \<noteq> fst (state.more s) \<longrightarrow>  lookup'' (snd (state.more s) - global_entries (snd (state.more s))) a v \<le>
                                                          lookup_from' (snapshot (snd (state.more t))) a v)"
*)

thm tlb_rel_abs_def

declare return_def [simp add]
declare bind_def [simp add]
declare read_state_def [simp add]
declare update_state_def [simp add]
declare extend_state_def [simp add]
declare trim_state_def [simp add]

lemma tlb_rel_detD:
  "tlb_rel_det s t \<Longrightarrow>  MEM t = MEM s \<and> TTBR0 t = TTBR0 s \<and> fst(state.more s) = fst (state.more t) \<and>
                                          snd(state.more s) \<subseteq> snd(state.more t)  \<and>  exception t = exception s"
  by (clarsimp simp: tlb_rel_det_def state.defs)

lemma tlb_rel_satD:
  "tlb_rel_sat s t \<Longrightarrow> MEM t = MEM s \<and> TTBR0 t = TTBR0 s \<and> fst(state.more s) = fst (state.more t) \<and> snd(state.more s) \<subseteq> snd(state.more t) \<and> exception t = exception s  \<and> saturated t"
  by (clarsimp simp: tlb_rel_sat_def state.defs)

lemma tlb_rel_absD':
  "tlb_rel_abs s t \<Longrightarrow> MEM t = MEM s \<and> TTBR0 t = TTBR0 s  \<and> fst(state.more s) = fst (state.more t) \<and> saturated s \<and>
                         incon_addrs s \<subseteq> iset (snd(state.more t)) \<and>   \<Union>(range_of `  global_entries (snd(state.more s))) \<subseteq> global_set (snd(state.more t)) \<and>
                          exception t = exception s"
  by (clarsimp simp: tlb_rel_abs_def state.defs)

lemma tlb_rel_det_consistent:
  "\<lbrakk> tlb_rel_det s t; consistent t va \<rbrakk> \<Longrightarrow> consistent s va"
   by (insert tlb_rel_detD [of s t] , clarsimp ,drule asid_tlb_mono [of _ _ "fst (state.more s)" "va"] ,auto simp: consistent0_def less_eq_lookup_type)

lemma tlb_rel_sat_consistent:
  "\<lbrakk> tlb_rel_sat s t; consistent t va \<rbrakk> \<Longrightarrow> consistent s va"
   by (insert tlb_rel_satD [of s t] , clarsimp ,drule asid_tlb_mono [of _ _ "fst (state.more s)" "va"] ,auto simp: consistent0_def less_eq_lookup_type)

lemma sat_state_tlb:
  "saturated s  \<Longrightarrow> snd(state.more s) =
         snd(state.more s) \<union> the ` {e \<in> range (pt_walk (fst(state.more s)) (MEM s) (TTBR0 s)). \<not> is_fault e}"
  by (fastforce simp: saturated_def)

lemma saturated_tlb:
  "saturated (typ_sat_tlb s) \<Longrightarrow> (sat_tlb s) =
            sat_tlb s \<union> the ` {e\<in>pt_walk (sat_asid s) (MEM s) (TTBR0 s) ` UNIV. \<not>is_fault e}"
 apply (clarsimp simp:  saturated_def) apply (cases s ; clarsimp)  by blast

lemma sat_miss_fault:
  "\<lbrakk> saturated (typ_sat_tlb s); lookup'' (sat_tlb s) (sat_asid s)  va = Miss \<rbrakk> \<Longrightarrow>
           is_fault (pt_walk (sat_asid s) (MEM s) (TTBR0 s) va)"
  apply (subgoal_tac " lookup'' ((sat_tlb s)  \<union> the ` {e \<in> range (pt_walk(sat_asid s)  (MEM s) (TTBR0 s)). \<not> is_fault e}) (sat_asid s) va = Miss")
   apply (thin_tac "lookup'' ((sat_tlb s)) (sat_asid s) va = Miss")
   apply (drule lookup_asid_tlb_miss_union)
   apply clarsimp
   apply (drule asid_tlb_lookup_miss_is_fault)
   apply clarsimp
  using saturated_tlb by fastforce

lemma saturatd_lookup_hit_no_fault:
  "\<lbrakk>saturated (typ_sat_tlb s);
    lookup'' (sat_tlb s) (sat_asid s)  b = Hit x; \<not> is_fault (pt_walk (sat_asid s)  (MEM s) (TTBR0 s) b)\<rbrakk> \<Longrightarrow>
                       x = the (pt_walk (sat_asid s) (MEM s) (TTBR0 s) b)"
  apply (subgoal_tac "lookup''(sat_tlb s \<union>
                              the ` {e \<in> range (pt_walk (sat_asid s)  (MEM s) (TTBR0 s)). \<not> is_fault e}) (sat_asid s) b = Hit x")
   prefer 2
   apply (drule sat_state_tlb, clarsimp simp: state.defs)  defer
  apply (drule lookup_asid_tlb_hit_miss_or_hit')
  apply (erule disjE)
   apply (clarsimp simp: asid_tlb_lookup_range_pt_walk_hit)
  apply (frule asid_tlb_lookup_range_fault_pt_walk)
  by (drule_tac x = b in bspec; clarsimp simp: lookup_asid_tlb_hit_entry_range)

lemma saturated_global_entries_subset:
  " saturated (typ_sat_tlb s) \<Longrightarrow>
      global_entries (the ` {e \<in> range (pt_walk (sat_asid s) (MEM s) (TTBR0 s)). \<not> is_fault e}) \<subseteq>
          global_entries (sat_tlb s)"
  apply (subgoal_tac "global_entries (the ` {e \<in> range (pt_walk (sat_asid s) (MEM s) (TTBR0 s)). \<not> is_fault e})  \<subseteq>
                       the ` {e \<in> range (pt_walk (sat_asid s) (MEM s) (TTBR0 s)). \<not> is_fault e} ")
   apply (subgoal_tac "global_entries (sat_tlb s)  \<subseteq> sat_tlb s")
    apply (subgoal_tac "the ` {e \<in> range (pt_walk (sat_asid s) (MEM s) (TTBR0 s)). \<not> is_fault e}  \<subseteq> sat_tlb s ")
     apply (smt Un_absorb2 global_entries_union subset_Un_eq)
    apply (clarsimp simp: saturated_def)
  by (simp add: glb_tlb_subset)+

lemma saturated_global_subset_lookup_un_eq:
  "saturated (typ_sat_tlb s) \<Longrightarrow>
        lookup''(global_entries (sat_tlb s) \<union>
                 global_entries (the ` {e \<in> range (pt_walk a (MEM s) (TTBR0 s)). \<not> is_fault e}))  a v =
                 lookup'' (global_entries (sat_tlb s)) a v"
  apply (rule tlb_subset_lookup_un_eq)
  apply (subgoal_tac "global_entries (the ` {e \<in> range (pt_walk a (MEM s) (TTBR0 s)). \<not> is_fault e}) =
                       global_entries (the ` {e \<in> range (pt_walk (sat_asid s) (MEM s) (TTBR0 s)). \<not> is_fault e})")
   apply (simp only:)
   apply (clarsimp simp: saturated_def global_entries_def) apply blast
  by (rule global_entries_ptable_same)

lemma write_mem_eq_TLB:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') \<rbrakk>  \<Longrightarrow> state.more s' = state.more s"
   by (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)

lemma write_same_mem:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') ; write'mem1 (val, va, sz) t = ((), t') ;
      MEM s = MEM t\<rbrakk>  \<Longrightarrow>  MEM s' = MEM t'"
  by (clarsimp simp: write'mem1_def raise'exception_def split:if_split_asm)

lemma write_same_mem_excep:
  "\<lbrakk> write'mem1 (val, pa, sz) s = ((), s') ; write'mem1 (val, pa, sz) t = ((), t') ;
      MEM s = MEM t ; exception s = exception t \<rbrakk>  \<Longrightarrow> exception s' = exception t'"
   by (clarsimp simp: write'mem1_def raise'exception_def split:if_split_asm)

lemma write_mem_rel:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') \<rbrakk>  \<Longrightarrow> s' = s \<lparr> MEM:= MEM s' , exception:= exception s' \<rparr>"
   by (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)

lemma not_member_incon_consistent:
  "\<lbrakk>va \<notin>  incon_addrs (typ_sat_tlb s) ; saturated (typ_sat_tlb s) \<rbrakk> \<Longrightarrow>
                                       consistent (typ_sat_tlb s) va"
  apply (clarsimp simp: incon_addrs_def inconsistent_vaddrs_def incoherrent_vaddrs_def consistent0_def)
  apply (erule disjE)
   apply (rule conjI)
    apply (meson lookup_type.exhaust )
   apply (meson lookup_type.exhaust)
  using not_miss_incon_hit_asid_tlb saturatd_lookup_hit_no_fault by blast

lemma tlb_rel_abs_consistent' [simp]:
  "\<lbrakk>va \<notin> iset(set_tlb t) ;   tlb_rel_abs  (typ_sat_tlb s) (typ_set_tlb t)  \<rbrakk>  \<Longrightarrow>
           consistent (typ_sat_tlb s) va "
  apply (rule not_member_incon_consistent ; clarsimp simp: tlb_rel_abs_def)
  by blast

(*      ARM Monadic Simplification Lemmas     *)

lemma mem1_exception:
  "mem1 p s = (val, t) \<Longrightarrow>  t = s\<lparr>exception := exception t\<rparr>"
  apply (clarsimp simp: mem1_def)
  apply (cases "MEM s p")
   apply (clarsimp simp: raise'exception_def split: if_split_asm)
  apply clarsimp
done

lemma mem1_read_exception:
  "mem_read1 (a, sz) b = (val, r) \<Longrightarrow> r = b \<lparr>exception := exception r\<rparr>"
  apply (clarsimp simp: mem_read1_def)
  apply (clarsimp split: if_split_asm)
      apply (case_tac "mem1 (a r+ 0) b" , clarsimp)
      apply (clarsimp simp: mem1_exception)
     apply (case_tac "mem1 (a r+ 1) b" , clarsimp)
     apply (case_tac "mem1 (a r+ 0) ba", clarsimp)
     apply (drule mem1_exception)
     apply (drule mem1_exception)
     apply (cases b, case_tac ba, cases r ,clarsimp)
    apply (case_tac "mem1 (a r+ 3) b" , clarsimp)
    apply (case_tac "mem1 (a r+ 2) ba", clarsimp)
    apply (case_tac "mem1 (a r+ 1) baa", clarsimp)
    apply (case_tac "mem1 (a r+ 0) bb", clarsimp)
    apply (drule mem1_exception)
    apply (drule mem1_exception)
    apply (drule mem1_exception)
    apply (drule mem1_exception)
    apply (cases b, case_tac ba, case_tac baa, case_tac bb , cases r ,clarsimp)
   apply (case_tac "mem1 (a r+ 7) b" , clarsimp)
   apply (case_tac "mem1 (a r+ 6) ba", clarsimp)
   apply (case_tac "mem1 (a r+ 5) baa", clarsimp)
   apply (case_tac "mem1 (a r+ 4) bb", clarsimp)
   apply (case_tac "mem1 (a r+ 3) bc", clarsimp)
   apply (case_tac "mem1 (a r+ 2) bd", clarsimp)
   apply (case_tac "mem1 (a r+ 1) be", clarsimp)
   apply (case_tac "mem1 (a r+ 0) bf", clarsimp)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (cases b, case_tac ba, case_tac baa, case_tac bb ,case_tac bc ,
                   case_tac bd ,  case_tac be ,  case_tac bf , cases r ,clarsimp)
  apply (clarsimp simp: raise'exception_def split:if_split_asm)
done

lemma write_mem_state_trun_equal:
  "\<lbrakk>  write'mem1 (val, pa, sz) s = ((), s'); write'mem1 (val, pa, sz) t = ((), t');
     state.truncate s = state.truncate t \<rbrakk>  \<Longrightarrow> state.truncate s' = state.truncate t'"
  apply (frule write_mem_rel)
  apply rotate_tac
  apply (frule write_mem_rel)
  apply (subgoal_tac "MEM s' = MEM t' \<and> exception s' = exception t'")
   apply clarsimp
   apply (cases s, cases t, cases s', cases t', clarsimp simp: state.defs)
  apply (cases s, cases t, cases s', cases t', clarsimp simp: state.defs)
  apply (clarsimp simp: write'mem1_def Let_def state.defs raise'exception_def split:if_split_asm)
  done

lemma write_mem1_eq_ASID_TTBR0:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') \<rbrakk>  \<Longrightarrow> TTBR0 s' = TTBR0 s"
   by (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)

lemma tlb_sat_set_mem1 [simp]:
  "sat_tlb (snd (mem1 ps s)) = sat_tlb s"
  by (simp add: mem1_def raise'exception_def split: option.splits)

consts tlb_evict :: "('a \<times> 'b) state_scheme \<Rightarrow> 'b"

instantiation non_det_tlb_state_ext :: (type) mmu_extended
begin
  definition
  "(mmu_translate va :: ('a non_det_tlb_state_scheme \<Rightarrow> _))
 = do {
     update_state (\<lambda>s. s\<lparr> non_det_tlb := non_det_tlb s - tlb_evict (typ_non_det_tlb s) \<rparr>);
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     asid <- read_state non_det_asid;
     tlb   <- read_state non_det_tlb;
          case lookup'' tlb asid va of
               Hit entry \<Rightarrow> return (va_to_pa va entry)
          |    Miss \<Rightarrow>
                   do {
                       let entry = pt_walk asid mem ttbr0 va;
                       if is_fault entry
                       then raise'exception (PAGE_FAULT ''more info'')
                       else do {
                                   update_state (\<lambda>s. s\<lparr> non_det_tlb := non_det_tlb s \<union>  {the entry} \<rparr>);
                                   return (va_to_pa va (the entry)) } }
          |    Incon \<Rightarrow> raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
   }"

thm mmu_translate_non_det_tlb_state_ext_def

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a non_det_tlb_state_scheme \<Rightarrow> bool list \<times>  'a non_det_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a non_det_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a non_det_tlb_state_scheme \<Rightarrow> unit \<times> 'a non_det_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
     pa <- mmu_translate va :: ('a non_det_tlb_state_scheme \<Rightarrow> _);
     exception <- read_state exception;
     if exception = NoException
       then  write'mem1 (value, pa, size)
       else return ()
  }"
(* print_context *)

definition
  "(update_TTBR0 r :: ('a non_det_tlb_state_scheme \<Rightarrow> _))  =
do {
    update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>)
  } "

definition
  "(update_ASID a :: ('a non_det_tlb_state_scheme \<Rightarrow> _))  =
    do {  update_state (\<lambda>s. s\<lparr> non_det_asid := a \<rparr>) }"

definition
  "(flush f :: ('a non_det_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushTLB \<Rightarrow> update_state (\<lambda>s. s\<lparr> non_det_tlb := {} \<rparr>)
                  | Flushvarange vset \<Rightarrow> do {
                                         update_state (\<lambda>s. s\<lparr> non_det_tlb := flush_tlb_vset (non_det_tlb s) vset \<rparr>)}"

definition
  "(flush_with_ASID f :: ('a non_det_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushASID a \<Rightarrow> do { update_state (\<lambda>s. s\<lparr> non_det_tlb := flush_tlb_asid (non_det_tlb s) a \<rparr>)}
                  |  FlushASIDvarange a vset \<Rightarrow> do {
                                         update_state (\<lambda>s. s\<lparr> non_det_tlb := flush_tlb_a_vset (non_det_tlb s) a vset \<rparr>)}"

  instance ..
end

instantiation det_tlb_state_ext :: (_) mmu_extended
begin
  definition
  "(mmu_translate va :: ('a det_tlb_state_scheme \<Rightarrow> _))
 = do {
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     asid <- read_state det_asid;
     tlb   <- read_state det_tlb;
          case lookup'' tlb asid va of
               Hit entry \<Rightarrow> return (va_to_pa va entry)
          |    Miss \<Rightarrow>
                   do {
                       let entry = pt_walk asid mem ttbr0 va;
                       if is_fault entry
                       then raise'exception (PAGE_FAULT ''more info'')
                       else do {
                                   update_state (\<lambda>s. s\<lparr> det_tlb := det_tlb s \<union>  {the entry} \<rparr>);
                                   return (va_to_pa va (the entry)) } }
          |    Incon \<Rightarrow> raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
   }"

thm mmu_translate_non_det_tlb_state_ext_def

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a det_tlb_state_scheme \<Rightarrow> bool list \<times>  'a det_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a det_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a det_tlb_state_scheme \<Rightarrow> unit \<times> 'a det_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
     pa <- mmu_translate va :: ('a det_tlb_state_scheme \<Rightarrow> _);
     exception <- read_state exception;
     if exception = NoException
       then  write'mem1 (value, pa, size)
       else return ()
  }"
(* print_context *)

definition
  "(update_TTBR0 r :: ('a det_tlb_state_scheme \<Rightarrow> _))  =
do {
    update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>)
  } "

definition
  "(update_ASID a :: ('a det_tlb_state_scheme \<Rightarrow> _))  =
    do {  update_state (\<lambda>s. s\<lparr> det_asid := a \<rparr>) }"

definition
  "(flush f :: ('a det_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushTLB \<Rightarrow> update_state (\<lambda>s. s\<lparr> det_tlb := {} \<rparr>)
                  | Flushvarange vset \<Rightarrow> do {
                                         update_state (\<lambda>s. s\<lparr> det_tlb := flush_tlb_vset (det_tlb s) vset \<rparr>)}"

definition
  "(flush_with_ASID f :: ('a det_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushASID a \<Rightarrow> do { update_state (\<lambda>s. s\<lparr> det_tlb := flush_tlb_asid (det_tlb s) a \<rparr>)}
                  |  FlushASIDvarange a vset \<Rightarrow> do {
                                         update_state (\<lambda>s. s\<lparr> det_tlb := flush_tlb_a_vset (det_tlb s) a vset \<rparr>)}"

  instance ..
end

instantiation sat_tlb_state_ext :: (_) mmu_extended
begin
  definition
  "(mmu_translate va :: ('a sat_tlb_state_scheme \<Rightarrow> _))
 = do {
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     asid <- read_state sat_asid;
     let tlb_new = the ` {e\<in>pt_walk asid mem ttbr0 ` UNIV. \<not>is_fault e};
     tlb   <- read_state sat_tlb;
     let sat_tlb' = tlb \<union> tlb_new;
     update_state (\<lambda>s. s\<lparr> sat_tlb := sat_tlb' \<rparr>);
          case lookup'' sat_tlb' asid va of
               Hit entry \<Rightarrow> return (va_to_pa va entry)
          |    Miss \<Rightarrow> raise'exception (PAGE_FAULT ''more info'')
          |    Incon \<Rightarrow> raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
   }"

thm mmu_translate_non_det_tlb_state_ext_def

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a sat_tlb_state_scheme \<Rightarrow> bool list \<times>  'a sat_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a sat_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a sat_tlb_state_scheme \<Rightarrow> unit \<times> 'a sat_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
      ttbr0 <- read_state TTBR0;
      asid <- read_state sat_asid;
      pa <- mmu_translate va :: ('a sat_tlb_state_scheme \<Rightarrow> _);
      tlb   <- read_state sat_tlb;
      exception <- read_state exception;
      if exception = NoException
       then  do {
                 write'mem1 (value, pa, size);
                 mem'  <- read_state MEM;
                 let tlb_new = the ` {e\<in>pt_walk asid mem' ttbr0 ` UNIV. \<not>is_fault e};
                 update_state (\<lambda>s. s\<lparr> sat_tlb := tlb \<union> tlb_new \<rparr>) }
       else return ()
  }"
(* print_context *)

definition
  "(update_TTBR0 r :: ('a sat_tlb_state_scheme \<Rightarrow> _))  =
do {
      update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>);
      mem   <- read_state MEM;
      asid <- read_state sat_asid;
      let all_entries = the ` {e\<in>pt_walk asid mem r ` UNIV. \<not>is_fault e};
      tlb   <- read_state sat_tlb;
      update_state (\<lambda>s. s\<lparr> sat_tlb := tlb \<union> all_entries \<rparr>)}"

definition
  "(update_ASID a :: ('a sat_tlb_state_scheme \<Rightarrow> _))  = do {
      update_state (\<lambda>s. s\<lparr> sat_asid := a \<rparr>);
      mem   <- read_state MEM;
      ttbr0 <- read_state TTBR0;
      let tlb_new = the `{e\<in>pt_walk a mem ttbr0 ` UNIV. \<not>is_fault e};
      tlb0   <- read_state sat_tlb;
      let tlb = tlb0 \<union> tlb_new;
      update_state (\<lambda>s. s\<lparr> sat_tlb := tlb \<rparr>)} "

definition
  "(flush f :: ('a sat_tlb_state_scheme \<Rightarrow> _))  \<equiv>  do {
      mem   <- read_state MEM;
      ttbr0 <- read_state TTBR0;
      asid <- read_state sat_asid;
      let tlb_new = the ` {e\<in>pt_walk asid mem ttbr0 ` UNIV. \<not>is_fault e};
      case f of FlushTLB \<Rightarrow>  update_state (\<lambda>s. s\<lparr> sat_tlb := tlb_new \<rparr>)
             | Flushvarange vset \<Rightarrow>  do {
                                  tlb0 <- read_state sat_tlb;
                                  update_state (\<lambda>s. s\<lparr> sat_tlb := flush_tlb_vset tlb0 vset \<union> tlb_new \<rparr>)}}"

definition
  "(flush_with_ASID f :: ('a sat_tlb_state_scheme \<Rightarrow> _))  \<equiv>  do {
      mem   <- read_state MEM;
      ttbr0 <- read_state TTBR0;
      asid <- read_state sat_asid;
      tlb0 <- read_state sat_tlb;
      let tlb_new = the ` {e\<in>pt_walk asid mem ttbr0 ` UNIV. \<not>is_fault e};
      case f of FlushASID a \<Rightarrow>  update_state (\<lambda>s. s\<lparr> sat_tlb := flush_tlb_asid tlb0 a \<union>  tlb_new \<rparr>)
             | FlushASIDvarange a vset \<Rightarrow>

                                  update_state (\<lambda>s. s\<lparr> sat_tlb := flush_tlb_a_vset tlb0 a vset \<union> tlb_new \<rparr>)}"

  instance ..
end

definition
  ptable_comp :: "(vaddr \<Rightarrow> asid tlb_entry option) \<Rightarrow> (vaddr \<Rightarrow> asid tlb_entry option) \<Rightarrow> vaddr set"
where
  "ptable_comp wlk wlk'  \<equiv> {va. \<not> is_fault (wlk va) \<and> \<not> is_fault (wlk' va) \<and> wlk va \<noteq> wlk' va \<or>
                                 \<not> is_fault (wlk va) \<and> is_fault (wlk' va)}"

definition
  incon_comp :: "asid \<Rightarrow> asid \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> paddr \<Rightarrow> paddr \<Rightarrow> vaddr set"
where
  "incon_comp  a a' hp hp' rt rt' \<equiv> ptable_comp (pt_walk a hp rt) (pt_walk a' hp' rt')"

definition
  snp_upd_cur :: "vaddr set \<Rightarrow> heap \<Rightarrow> ttbr0  \<Rightarrow> asid \<Rightarrow> (vaddr set \<times> (vaddr \<Rightarrow> asid tlb_entry option))"
where
  "snp_upd_cur ist m r  \<equiv> \<lambda>a. (ist, \<lambda>v. pt_walk a m r v)"

definition
  snp_upd_cur' :: "(asid \<Rightarrow> (vaddr set \<times> (vaddr \<Rightarrow> asid tlb_entry option))) \<Rightarrow> vaddr set \<Rightarrow>
                                 heap \<Rightarrow> ttbr0 \<Rightarrow> asid \<Rightarrow> (asid \<Rightarrow> (vaddr set \<times> (vaddr \<Rightarrow> asid tlb_entry option)))"
where
  "snp_upd_cur' snp ist mem ttbr0 a \<equiv> snp (a := snp_upd_cur ist mem ttbr0 a)"

instantiation set_tlb_state_ext :: (_) mmu_extended
begin
  definition
  "(mmu_translate va :: ('a set_tlb_state_scheme \<Rightarrow> _))
 = do {
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     asid <- read_state set_asid;
     iset_snapshot <- read_state set_tlb;
     let incon_vaddrs = iset (iset_snapshot);
     if  va \<in> incon_vaddrs
       then raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
       else let entry = pt_walk asid mem ttbr0 va in
             if is_fault entry
              then raise'exception (PAGE_FAULT ''more info'')
              else return (va_to_pa va (the entry))
    }"

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a set_tlb_state_scheme \<Rightarrow> bool list \<times>  'a set_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a set_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a set_tlb_state_scheme \<Rightarrow> unit \<times> 'a set_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
      ttbr0 <- read_state TTBR0;
      mem   <- read_state MEM;
      asid <- read_state set_asid;
      paddr <- mmu_translate va :: ('a set_tlb_state_scheme \<Rightarrow> _);
      iset_snapshot <- read_state set_tlb;
      let incon_vaddrs = iset (iset_snapshot);
      let global_set = global_set (iset_snapshot);
      exception <- read_state exception;
      if exception = NoException
        then  do {
                   write'mem1 (value, paddr, size);
                   mem' <- read_state MEM;
                   let ptable_comp = incon_comp asid asid mem mem' ttbr0 ttbr0;
                   let incon_vaddrs_new    = incon_vaddrs \<union>  ptable_comp;
               \<comment> \<open>let global_set_up = global_set \<union>  global_entries (the ` {e\<in>pt_walk asid mem' ttbr0 ` UNIV. \<not>is_fault e});\<close>
                   let global_set_up = global_set \<union>  \<Union> (range_of ` global_entries (the ` {e\<in>pt_walk asid mem' ttbr0 ` UNIV. \<not>is_fault e}));
                   let iset_snapshot = iset_snapshot \<lparr>iset := incon_vaddrs_new , global_set := global_set_up \<rparr>;
                   update_state (\<lambda>s. s\<lparr> set_tlb :=  iset_snapshot \<rparr>)
            }
        else return ()
   }"

definition
 "(update_TTBR0 r :: ('a set_tlb_state_scheme \<Rightarrow> _))  = do {
      ttbr0   <- read_state TTBR0;
      update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>);
      iset_snapshot   <- read_state set_tlb;
      let global_set = global_set (iset_snapshot);
      asid <- read_state set_asid;
      mem  <- read_state MEM;
       let incon_vaddrs_new = incon_comp asid asid mem mem ttbr0 r;
       let incon_set_n = iset iset_snapshot \<union>  incon_vaddrs_new;
   \<comment> \<open>let global_set_up = global_set \<union>  global_entries (the ` {e\<in>pt_walk asid mem r ` UNIV. \<not>is_fault e});\<close>
       let global_set_up = global_set \<union>  \<Union> (range_of `global_entries (the ` {e\<in>pt_walk asid mem r ` UNIV. \<not>is_fault e}));
       let iset_snapshot = iset_snapshot \<lparr>iset := incon_set_n , global_set := global_set_up \<rparr>;
      update_state (\<lambda>s. s\<lparr> set_tlb := iset_snapshot \<rparr>)
}"

definition
   "(update_ASID a :: ('a set_tlb_state_scheme \<Rightarrow> _))  = do {
      mem   <- read_state MEM;
      ttbr0 <- read_state TTBR0;
      asid  <- read_state set_asid;
      iset_snapshot   <- read_state set_tlb;
      let iset = iset iset_snapshot;  \<comment> \<open>current iset\<close>
      let global_set = global_set (iset_snapshot);
      let snapshot = snapshot iset_snapshot;

      \<comment> \<open>incon vaddrs that are global\<close>
      \<comment> \<open>let iset_global = iset \<inter> \<Union> (range_of ` global_set);\<close>
      let iset_global = iset \<inter> global_set;

      \<comment> \<open>snapshot update\<close>
      let snapshot_current = snp_upd_cur' snapshot iset mem ttbr0 asid;
      let set_tlb = iset_snapshot \<lparr>snapshot := snapshot_current \<rparr>;
      update_state (\<lambda>s. s\<lparr> set_tlb := set_tlb \<rparr>);

      \<comment> \<open>new ASID\<close>
      update_state (\<lambda>s. s\<lparr> set_asid := a \<rparr>);

     \<comment> \<open>for the new iset\<close>
     let iset_snp_incon = fst (snapshot_current a);
     let iset_snp = ptable_comp (snd(snapshot_current a)) (pt_walk a mem ttbr0);
     let set_tlb = set_tlb\<lparr> iset := iset_snp_incon \<union> iset_global \<union> iset_snp  \<rparr>;
     update_state (\<lambda>s. s\<lparr> set_tlb := set_tlb \<rparr>)
}"

definition
  "(flush f :: ('a set_tlb_state_scheme \<Rightarrow> _))  \<equiv> do  {
                       asid    <- read_state set_asid;
                       mem     <- read_state MEM;
                       ttbr0   <- read_state TTBR0;
                       set_tlb   <- read_state set_tlb;
                       let iset = iset set_tlb;
                       let global_set = global_set set_tlb;
                       let snapshot = snapshot set_tlb;
                       case f of FlushTLB \<Rightarrow> do {
                                            let empty_set_tlb = set_tlb \<lparr>iset := {},
                                                    global_set :=  \<Union>(range_of ` global_entries (the ` {e \<in> range (pt_walk asid mem ttbr0). \<not> is_fault e})),
                                                    snapshot := \<lambda> a. ({}, Map.empty) \<rparr>;
                                                    update_state (\<lambda>s. s\<lparr> set_tlb := empty_set_tlb \<rparr>) }
                               | Flushvarange vset \<Rightarrow>  do {
                                             let upd_set_tlb = set_tlb \<lparr>iset := iset - vset ,
                                                  \<comment> \<open>  global_set := (global_set  - \<Union>(entry_set global_set ` vset))  \<union>
                                                          global_entries (the ` {e \<in> range (pt_walk asid mem ttbr0). \<not> is_fault e}), \<close>
                                                          global_set := (global_set  - vset)  \<union>
                                                         \<Union>(range_of ` global_entries (the ` {e \<in> range (pt_walk asid mem ttbr0). \<not> is_fault e})),
                                                    snapshot := \<lambda> a. (fst(snapshot a) - vset,  \<lambda>v. if v \<in> vset then None else snd(snapshot a) v) \<rparr>;
                                                    update_state (\<lambda>s. s\<lparr> set_tlb := upd_set_tlb \<rparr>) }}"

definition
  "(flush_with_ASID f :: ('a set_tlb_state_scheme \<Rightarrow> _))  \<equiv> do {
                       asid    <- read_state set_asid;
                       mem     <- read_state MEM;
                       ttbr0   <- read_state TTBR0;
                       set_tlb   <- read_state set_tlb;
                       let iset = iset set_tlb;
                       let global_set = global_set set_tlb;
                       let snapshot = snapshot set_tlb;
                        case f of FlushASID a \<Rightarrow>
                           if a = asid then
                                update_state (\<lambda>s. s\<lparr> set_tlb := set_tlb \<lparr> iset := iset \<inter> global_set \<rparr> \<rparr> )
                           else do {
                               let upd_set_tlb = set_tlb \<lparr> snapshot := snapshot (a := ({}, \<lambda>v. None)) \<rparr>;
                                   update_state (\<lambda>s. s\<lparr> set_tlb := upd_set_tlb \<rparr>)
                             }
                  | FlushASIDvarange a vset \<Rightarrow>

                          if a = asid then
                               update_state (\<lambda>s. s\<lparr> set_tlb := set_tlb \<lparr> iset := iset - (vset - global_set)  \<rparr> \<rparr> )
                          else
                               update_state (\<lambda>s. s\<lparr> set_tlb := set_tlb \<lparr> snapshot := \<lambda>a'. if a' = a then (fst (snapshot a) - vset,
                                 \<lambda>v. if v \<in> vset then None else (snd (snapshot a)) v)  else snapshot a'  \<rparr> \<rparr> )
                         }"

  instance ..
end

end


(*  Title:       variants/c_gtobcast/OAodv.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "The `open' AODV model"

theory C_OAodv
imports C_Aodv AWN.OAWN_SOS_Labels AWN.OAWN_Convert
begin

text \<open>Definitions for stating and proving global network properties over individual processes.\<close>

definition \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' :: "((ip \<Rightarrow> state) \<times> ((state, msg, pseqp, pseqp label) seqp)) set"
where "\<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<equiv> {(\<lambda>i. aodv_init i, \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V PAodv)}"

abbreviation opaodv
  :: "ip \<Rightarrow> ((ip \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp, msg seq_action) automaton"
where
  "opaodv i \<equiv> \<lparr> init = \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V', trans = oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i \<rparr>"

lemma initiali_aodv [intro!, simp]: "initiali i (init (opaodv i)) (init (paodv i))"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def by rule simp_all

lemma oaodv_control_within [simp]: "control_within \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (init (opaodv i))"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def by (rule control_withinI) (auto simp del: \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_simps)

lemma \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_labels [simp]: "(\<sigma>, p) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<Longrightarrow>  labels \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V p = {PAodv-:0}"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def by simp

lemma oaodv_init_kD_empty [simp]:
  "(\<sigma>, p) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<Longrightarrow> kD (rt (\<sigma> i)) = {}"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def kD_def by simp

lemma oaodv_init_vD_empty [simp]:
  "(\<sigma>, p) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<Longrightarrow> vD (rt (\<sigma> i)) = {}"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def vD_def by simp

lemma oaodv_trans: "trans (opaodv i) = oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i"
  by simp

declare
  oseq_invariant_ctermsI [OF aodv_wf oaodv_control_within aodv_simple_labels oaodv_trans, cterms_intros]
  oseq_step_invariant_ctermsI [OF aodv_wf oaodv_control_within aodv_simple_labels oaodv_trans, cterms_intros]

end


theory DemoSetup
imports
  BruteForceAutomation
  "../HeapLang/Notation"
  "../IrisCore/Misc"
  "../IrisCore/AuthHeap"
begin

context
includes heap_syntax
fixes get_inv :: "gname \<Rightarrow> 'res :: ucamera \<Rightarrow> inv option"
  and put_inv
  and get_heap :: "gname \<Rightarrow> 'res \<Rightarrow> heap_lang_heap option"
  and put_heap
  and get_proph :: "gname \<Rightarrow> 'res \<Rightarrow> (proph_id, val\<times>val) proph_mapGS option"
  and put_proph
assumes inv_inG[inv_inG_axiom]: "inG get_inv put_inv"
  and heap_inG[heap_inG_axiom]: "inG get_heap put_heap"
  and prophm_inG[proph_inG_axiom]: "inG get_proph put_proph"
begin

lemmas wp_inG[inG_axioms] = inv_inG heap_inG prophm_inG

definition diaframe_hint :: "'res upred_f \<Rightarrow> ('b \<Rightarrow> 'res upred_f) \<Rightarrow> ('res upred_f \<Rightarrow> 'res upred_f) \<Rightarrow> ('a \<Rightarrow> 'res upred_f) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'res upred_f) \<Rightarrow> bool" where
  "diaframe_hint H L M A U \<equiv> \<forall>y::'b. (H \<^emph> L y \<turnstile> M (\<exists>\<^sub>u x::'a. A x \<^emph> U y x))"

lemma hintE: "diaframe_hint H L M A U \<Longrightarrow> (\<And>y::'b. (H \<^emph> L y \<turnstile> M (\<exists>\<^sub>u x::'a. A x \<^emph> U y x)))"
  unfolding diaframe_hint_def by simp

lemma inv_hint: "diaframe_hint upred_emp (\<lambda>x::'a. \<triangleright>(L x)) (ViewShift.linear_fupd put_inv E)
  (\<lambda>x::'a. inv put_inv N (L x)) (\<lambda>_ x::'a. inv put_inv N (L x))"
  apply (auto simp: diaframe_hint_def)
  apply (iMod rule: inv_alloc[OF inv_inG, to_entailment])
  apply iExistsR2
  apply (rule upred_entails_trans[OF upred_entail_eqR[OF persistent_dupl]])
  apply pers_solver apply (rule inv_inG)
  apply (rule upred_frame)
  by simp

lemma biabd_hint_apply_aux:
  assumes "diaframe_hint H L (ViewShift.fancy_upd put_inv E3 E2) A U"
  shows "H \<^emph> ViewShift.fancy_upd put_inv E1 E3 (\<exists>\<^sub>u y. L y \<^emph> (\<forall>\<^sub>u x. (U y x) -\<^emph> (G x)))
    \<turnstile> ViewShift.fancy_upd put_inv E1 E2 (\<exists>\<^sub>u x. G x \<^emph> A x)"
  apply (entails_substR rule: fupd_mask_trans[OF inv_inG, of _ E3])
  apply (iMod rule: fupd_frame_r[OF inv_inG, where ?R=H])
  apply iExistsL
  apply (iApply rule: hintE[OF assms])
  apply (iMod rule: fupd_frame_r[OF inv_inG, where ?R="(\<forall>\<^sub>ux. U _ x -\<^emph> G x)"])
  apply iExistsL subgoal for y x
  apply (iExistsR x)
  apply (move_sepL "\<forall>\<^sub>u x::'b. ?P x")
  apply (rule pull_forall_antecedent')
  apply (rule upred_entails_trans[OF upred_forall_inst[of _ x]])
  apply iApply_wand
  by iFrame_single
  done

lemma biabd_hint_apply:
assumes "diaframe_hint H L (ViewShift.fancy_upd put_inv E3 E2) A U"
  "\<Delta> \<turnstile> ViewShift.fancy_upd put_inv E1 E3 (\<exists>\<^sub>u y. L y \<^emph> (\<forall>\<^sub>u x. (U y x) -\<^emph> (G x)))"
shows "\<Delta> \<^emph> H \<turnstile> ViewShift.fancy_upd put_inv E1 E2 (\<exists>\<^sub>u x. G x \<^emph> A x)"
proof -
  from biabd_hint_apply_aux[OF assms(1)]
  have aux: "(ViewShift.fancy_upd put_inv E1 E3(\<exists>\<^sub>u y. L y \<^emph> (\<forall>\<^sub>u x. (U y x) -\<^emph> (G x)))) \<^emph> H
    \<turnstile> (ViewShift.fancy_upd put_inv E1 E2(\<exists>\<^sub>ux. G x \<^emph> A x))"
    apply (subst (2) upred_sep_comm) by simp
  show ?thesis
    apply (rule upred_entails_trans[OF upred_sep_mono[OF assms(2) upred_entails_refl[of H]]])
    by (rule aux)
qed

lemma biabd_hint_apply':
assumes "diaframe_hint H L (ViewShift.fancy_upd put_inv E3 E2) (\<lambda>_. A) (\<lambda>y _. U y)"
  "\<Delta> \<turnstile> ViewShift.fancy_upd put_inv E1 E3 (\<exists>\<^sub>u y. L y \<^emph> ((U y) -\<^emph> G))"
shows "\<Delta> \<^emph> H \<turnstile> ViewShift.fancy_upd put_inv E1 E2 (G \<^emph> A)"
proof -
  from assms(2) have "\<Delta> \<turnstile> fancy_upd'' put_inv E1 E3 (\<exists>\<^sub>u y. L y \<^emph> (\<forall>\<^sub>u x. ((\<lambda>y _. U y) y x) -\<^emph> G))"
    by (simp add: drop_forall)
  from biabd_hint_apply[OF assms(1) this, unfolded drop_exists] show ?thesis .
qed

lemma wp_store_hint:
  "diaframe_hint upred_emp (\<lambda>_. ViewShift.fancy_upd put_inv UNIV E (\<exists>\<^sub>u v'. (\<triangleright>(AuthHeap.points_to_full put_heap l v')) \<^emph>
  (\<triangleright>((ViewShift.wand_fupd put_inv (AuthHeap.points_to_full put_heap l v) E UNIV (\<Phi> #[()]))))))
  (ViewShift.linear_fupd put_inv UNIV) (\<lambda>_. WeakestPrecondition.WP put_inv put_heap put_proph (Store #[l] (Val v)) \<Phi>) (\<lambda>_ _. upred_emp)"
  unfolding diaframe_hint_def
  apply (simp add: drop_exists emp_rule)
  apply (entails_substR rule: fupd_intro[OF inv_inG])
  apply (rule elim_modal_entails[OF elim_modal_fupd_wp_atomic[OF wp_inG atomic_store]])
  apply iExistsL
  apply (move_sepL "\<triangleright>(AuthHeap.points_to_full put_heap ?l ?v)")
  apply later_elim
  apply (rule wp_store'[OF wp_inG, unfolded to_val_simp])
  apply (rule upred_later_mono_extL)
  apply (rule upred_entails_trans[OF _ wp_value[OF wp_inG]])
  by iApply_wand

lemmas store_hint = biabd_hint_apply'[OF wp_store_hint]

declare upred_entails_trans[OF store_hint[where ?G = upred_emp, unfolded emp_rule to_val_simp] fupd_wp, wp_symbolic_execution_steps]
end
declare upred_later_exists[iris_simp]
declare frame_baseL[frame_rule]
abbreviation "emp \<equiv> upred_emp"
end


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

theory MarkObject
imports
  Global_Invariants_Lemmas
  Local_Invariants_Lemmas
  Tactics
begin

(*>*)
section\<open> Mark Object \<close>

text\<open>

These are the most intricate proofs in this development.

\<close>

context mut_m
begin

lemma mark_object_invL[intro]:
  "\<lbrace> handshake_invL \<^bold>\<and> mark_object_invL
      \<^bold>\<and> mut_get_roots.mark_object_invL m
      \<^bold>\<and> mut_store_del.mark_object_invL m
      \<^bold>\<and> mut_store_ins.mark_object_invL m
      \<^bold>\<and> LSTP (phase_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> tso_store_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     mutator m
   \<lbrace> mark_object_invL \<rbrace>"
proof (vcg_jackhammer, vcg_name_cases)
  case (store_ins_mo_ptest s s' obj) then show ?case
    apply -
    apply (drule handshake_phase_invD)
    apply (drule phase_rel_invD)
    apply (clarsimp simp: phase_rel_def)
    apply (cases "sys_ghost_hs_phase s\<down>"; simp add: hp_step_rel_def; elim disjE; simp; force)
    done
next case (store_ins_mo_phase s s') then show ?case
    apply -
    apply (drule handshake_phase_invD)
    apply (drule phase_rel_invD)
    apply (clarsimp simp: phase_rel_def)
    apply (case_tac "sys_ghost_hs_phase s\<down>"; simp add: hp_step_rel_def; elim disjE; simp; force)
    done
next case (store_del_mo_phase s s' y) then show ?case
    apply -
    apply (drule handshake_phase_invD)
    apply (drule phase_rel_invD)
    apply (clarsimp simp: phase_rel_def)
    apply (case_tac "sys_ghost_hs_phase s\<down>"; simp add: hp_step_rel_def; elim disjE; simp; force)
    done
next case (deref_del s s' opt_r') then show ?case
    apply -
    apply (rule obj_at_field_on_heapE[OF obj_at_field_on_heap_no_pending_stores[where m=m]])
    apply auto
    done
next case (hs_get_roots_loop_mo_phase s s' y) then show ?case
    apply -
    apply (drule handshake_phase_invD)
    apply (drule phase_rel_invD)
    apply (clarsimp simp: phase_rel_def hp_step_rel_def)
    done
qed fastforce+

lemma mut_store_ins_mark_object_invL[intro]:
  "\<lbrace> mut_store_ins.mark_object_invL m \<^bold>\<and> mark_object_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL
       \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     mutator m
   \<lbrace> mut_store_ins.mark_object_invL m \<rbrace>"
proof(vcg_jackhammer, vcg_name_cases)
     case store_ins_mo_null then show ?case by (metis reachableI(1) valid_refs_invD(8))
next case store_ins_mo_mark then show ?case by (clarsimp split: obj_at_splits)
next case (store_ins_mo_ptest s s' obj) then show ?case by (simp add: valid_W_inv_no_mark_stores_invD filter_empty_conv) metis
next case store_ins_mo_co_won then show ?case by metis
next case store_ins_mo_mtest then show ?case by metis
next case store_ins_mo_co_ctest0 then show ?case by (metis whiteI)
next case (store_ins_mo_co_ctest s s' obj) then show ?case
      apply (elim disjE; clarsimp split: obj_at_splits)
      apply metis
      done
qed

lemma mut_store_del_mark_object_invL[intro]:
  "\<lbrace> mut_store_del.mark_object_invL m \<^bold>\<and> mark_object_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL
       \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     mutator m
   \<lbrace> mut_store_del.mark_object_invL m \<rbrace>"
proof(vcg_jackhammer, vcg_name_cases)
     case store_del_mo_co_ctest0 then show ?case by blast
next case store_del_mo_co_ctest  then show ?case by (clarsimp split: obj_at_splits)
next case store_del_mo_ptest     then show ?case by (auto dest: valid_W_inv_no_mark_stores_invD)
next case store_del_mo_mark      then show ?case by (clarsimp split: obj_at_splits)
next case store_del_mo_null      then show ?case by (auto dest: valid_refs_invD)
qed

lemma mut_get_roots_mark_object_invL[intro]:
  "\<lbrace> mut_get_roots.mark_object_invL m \<^bold>\<and> mark_object_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL
       \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     mutator m
   \<lbrace> mut_get_roots.mark_object_invL m \<rbrace>"
proof(vcg_jackhammer, vcg_name_cases)
     case hs_get_roots_loop_mo_co_ctest0 then show ?case by blast
next case hs_get_roots_loop_mo_co_ctest  then show ?case by (clarsimp split: obj_at_splits)
next case hs_get_roots_loop_mo_ptest     then show ?case by (auto dest: valid_W_inv_no_mark_stores_invD split: obj_at_splits)
next case hs_get_roots_loop_mo_mark      then show ?case by (clarsimp split: obj_at_splits)
next case hs_get_roots_loop_mo_null      then show ?case by (auto dest: valid_W_inv_no_mark_stores_invD split: obj_at_splits)
qed

end

lemma (in mut_m') mut_mark_object_invL[intro]:
  notes obj_at_field_on_heap_splits[split]
  notes fun_upd_apply[simp]
  shows
  "\<lbrace> mark_object_invL \<rbrace> mutator m'"
by (vcg_chainsaw mark_object_invL_def)

subsection\<open> @{term "obj_fields_marked_inv"} \<close>

context gc
begin

lemma gc_mark_mark_object_invL[intro]:
  "\<lbrace> fM_fA_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> tso_lock_invL
        \<^bold>\<and> LSTP valid_W_inv \<rbrace>
     gc
   \<lbrace> gc_mark.mark_object_invL \<rbrace>"
by vcg_jackhammer (auto dest: valid_W_inv_no_mark_stores_invD split: obj_at_splits)

lemma obj_fields_marked_invL[intro]:
  "\<lbrace> fM_fA_invL \<^bold>\<and> phase_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> gc_mark.mark_object_invL
       \<^bold>\<and> LSTP (tso_store_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     gc
   \<lbrace> obj_fields_marked_invL \<rbrace>"
proof(vcg_jackhammer, vcg_name_cases)
     case (mark_loop_mark_field_done s s') then show ?case by - (rule obj_fields_marked_mark_field_done, auto)
next case (mark_loop_mark_deref s s')
  then have "grey (gc_tmp_ref s\<down>) s\<down>" by blast
  with mark_loop_mark_deref show ?case
apply (clarsimp split: obj_at_field_on_heap_splits)
apply (rule conjI)
    apply (metis (no_types) case_optionE obj_at_def valid_W_invE(3))
apply clarsimp
apply (erule valid_refs_invD; auto simp: obj_at_def ranI reaches_step(2))
done
qed

end

context sys
begin

lemma mut_store_ins_mark_object_invL[intro]:
  notes mut_m_not_idle_no_fM_writeD[where m=m, dest!]
  notes not_blocked_def[simp]
  notes fun_upd_apply[simp]
  notes if_split_asm[split del]
  shows
  "\<lbrace> mut_m.tso_lock_invL m \<^bold>\<and> mut_m.mark_object_invL m \<^bold>\<and> mut_store_ins.mark_object_invL m
       \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv) \<rbrace>
     sys
   \<lbrace> mut_store_ins.mark_object_invL m \<rbrace>"
proof(vcg_chainsaw mut_m.mark_object_invL_def mut_m.tso_lock_invL_def mut_m.mut_store_ins_mark_object_invL_def2, vcg_name_cases "mutator m")
     case (store_ins_mo_fM s s' p w ws ref fl) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits if_splits)
      apply (metis (no_types, lifting) valid_W_invD(1))
      done
next case (store_ins_mo_mtest s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits if_splits)
      done
next case (store_ins_mo_phase s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits if_splits)
      done
next case (store_ins_mo_ptest s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (store_ins_mo_co_lock s s' p w ws y) then show ?case
      apply (intro conjI impI notI; clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write split: mem_store_action.splits obj_at_splits)
      apply metis
      done
next case (store_ins_mo_co_cmark s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write split: mem_store_action.splits obj_at_splits)
      done
next case (store_ins_mo_co_ctest s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write split: mem_store_action.splits obj_at_splits)
      done
next case (store_ins_mo_co_mark s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write split: mem_store_action.splits obj_at_splits)
      done
next case (store_ins_mo_co_unlock s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write split: mem_store_action.splits obj_at_splits)
      done
next case (store_ins_mo_co_won s s' p w ws y) then show ?case
      apply (intro conjI impI notI; clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD(1) split: mem_store_action.splits obj_at_splits)
      done
next case (store_ins_mo_co_W s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD(1) split: mem_store_action.splits obj_at_splits)
      apply auto
      done
qed

lemma mut_store_del_mark_object_invL[intro]:
  notes mut_m_not_idle_no_fM_writeD[where m=m, dest!]
  notes not_blocked_def[simp]
  notes fun_upd_apply[simp]
  notes if_split_asm[split del]
  shows
  "\<lbrace> mut_m.tso_lock_invL m \<^bold>\<and> mut_m.mark_object_invL m \<^bold>\<and> mut_store_del.mark_object_invL m
       \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv) \<rbrace>
     sys
   \<lbrace> mut_store_del.mark_object_invL m \<rbrace>"
proof(vcg_chainsaw mut_m.mark_object_invL_def mut_m.tso_lock_invL_def mut_m.mut_store_del_mark_object_invL_def2, vcg_name_cases "mutator m")
     case (store_del_mo_fM s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits if_splits)
      apply (metis (no_types, lifting) valid_W_invD(1))
      done
next case (store_del_mo_mtest s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits if_splits)
      done
next case (store_del_mo_phase s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (store_del_mo_ptest s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (store_del_mo_co_lock s s' p w ws y) then show ?case
      apply (intro conjI impI notI; clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write split: mem_store_action.splits obj_at_splits)
      apply metis
      done
next case (store_del_mo_co_cmark s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (store_del_mo_co_ctest s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (store_del_mo_co_mark s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (store_del_mo_co_unlock s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (metis (mono_tags, lifting) filter_empty_conv valid_W_invD(1))
      done
next case (store_del_mo_co_won s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply auto
      done
next case (store_del_mo_co_W s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def filter_empty_conv mut_m_not_idle_no_fM_write valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply auto
      done
qed

lemma mut_get_roots_mark_object_invL[intro]:
  notes not_blocked_def[simp]
  notes p_not_sys[simp]
  notes mut_m.handshake_phase_invD[where m=m, dest!]
  notes fun_upd_apply[simp]
  notes if_split_asm[split del]
  shows
  "\<lbrace> mut_m.tso_lock_invL m \<^bold>\<and> mut_m.handshake_invL m \<^bold>\<and> mut_get_roots.mark_object_invL m
       \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv) \<rbrace>
     sys
   \<lbrace> mut_get_roots.mark_object_invL m \<rbrace>"
proof(vcg_chainsaw mut_m.tso_lock_invL_def mut_m.handshake_invL_def mut_m.mut_get_roots_mark_object_invL_def2, vcg_name_cases "mutator m")
     case (hs_get_roots_loop_mo_fM s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits if_splits)
       apply (metis (no_types, lifting) valid_W_invD(1))
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
next case (hs_get_roots_loop_mo_mtest s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
next case (hs_get_roots_loop_mo_phase s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
next case (hs_get_roots_loop_mo_ptest s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
next case (hs_get_roots_loop_mo_co_lock s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
next case (hs_get_roots_loop_mo_co_cmark s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (hs_get_roots_loop_mo_co_ctest s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (hs_get_roots_loop_mo_co_mark s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (hs_get_roots_loop_mo_co_unlock s s' w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      done
next case (hs_get_roots_loop_mo_co_won s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
next case (hs_get_roots_loop_mo_co_W s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def valid_W_invD split: mem_store_action.splits obj_at_splits)
      apply (force simp: fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv valid_W_invD)+
      done
qed

lemma gc_mark_mark_object_invL[intro]:
  notes fun_upd_apply[simp]
  notes if_split_asm[split del]
  shows
  "\<lbrace> gc.fM_fA_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.phase_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> gc.tso_lock_invL
       \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_store_inv) \<rbrace>
     sys
   \<lbrace> gc_mark.mark_object_invL \<rbrace>"
proof(vcg_chainsaw gc.gc_mark_mark_object_invL_def2 gc.tso_lock_invL_def gc.phase_invL_def gc.fM_fA_invL_def gc.handshake_invL_def, vcg_name_cases "gc")
     case (mark_loop_mo_fM s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits if_splits)
      apply (auto split: obj_at_splits)
      done
next case (mark_loop_mo_mtest s s' p w ws y ya) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      apply (auto split: obj_at_splits)
      done
next case (mark_loop_mo_phase s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      apply (auto split: obj_at_splits)
      done
next case (mark_loop_mo_ptest s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      apply (auto split: obj_at_splits)
      done
next case (mark_loop_mo_co_lock s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      apply (auto split: obj_at_splits)
      done
next case (mark_loop_mo_co_cmark s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      done
next case (mark_loop_mo_co_ctest s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      done
next case (mark_loop_mo_co_mark s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      done
next case (mark_loop_mo_co_unlock s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                     split: mem_store_action.splits)
      apply auto
      done
next case (mark_loop_mo_co_won s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      apply (auto split: obj_at_splits)
      done
next case (mark_loop_mo_co_W s s' p w ws y) then show ?case
      apply (clarsimp simp: do_store_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys valid_W_invD
                     split: mem_store_action.splits)
      apply (auto split: obj_at_splits)
      done
qed

end

lemma (in mut_m') mut_get_roots_mark_object_invL[intro]:
  "\<lbrace> mut_get_roots.mark_object_invL m \<rbrace> mutator m'"
by vcg_chainsaw

lemma (in mut_m') mut_store_ins_mark_object_invL[intro]:
  "\<lbrace> mut_store_ins.mark_object_invL m \<rbrace> mutator m'"
by vcg_chainsaw

lemma (in mut_m') mut_store_del_mark_object_invL[intro]:
  "\<lbrace> mut_store_del.mark_object_invL m \<rbrace> mutator m'"
by vcg_chainsaw

lemma (in gc) mut_get_roots_mark_object_invL[intro]:
  "\<lbrace> handshake_invL \<^bold>\<and> mut_m.handshake_invL m \<^bold>\<and> mut_get_roots.mark_object_invL m \<rbrace> gc \<lbrace> mut_get_roots.mark_object_invL m \<rbrace>"
by (vcg_chainsaw mut_m.handshake_invL_def mut_m.mut_get_roots_mark_object_invL_def2)

lemma (in mut_m) gc_obj_fields_marked_invL[intro]:
  "\<lbrace> handshake_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.obj_fields_marked_invL
     \<^bold>\<and> LSTP (tso_store_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
     mutator m
   \<lbrace> gc.obj_fields_marked_invL \<rbrace>"
apply (vcg_chainsaw gc.obj_fields_marked_invL_def gc.handshake_invL_def)
(* FIXME rules *)
  apply (clarsimp simp: gc.obj_fields_marked_def fun_upd_apply)
  apply (rename_tac s s' ra x)
  apply (drule_tac x=x in spec)
  apply clarsimp
  apply (erule obj_at_field_on_heapE)
   apply (subgoal_tac "grey (gc_tmp_ref s\<down>) s\<down>")
    apply (drule_tac y="gc_tmp_ref s\<down>" in valid_refs_invD(7), simp+)
    apply (clarsimp simp: fun_upd_apply split: obj_at_splits; fail)
   apply (erule greyI)
  apply (clarsimp simp: fun_upd_apply split: obj_at_splits; fail)
 apply (clarsimp simp: fun_upd_apply split: obj_at_field_on_heap_splits; fail)
apply (clarsimp simp: fun_upd_apply)
done

lemma (in mut_m) gc_mark_mark_object_invL[intro]:
  "\<lbrace> gc_mark.mark_object_invL \<rbrace> mutator m"
by (vcg_chainsaw gc.gc_mark_mark_object_invL_def2)

(*<*)

end
(*>*)


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

text \<open>
  This file provide the main confidentiality unwinding condition:
  the reads_respects family.
  In order to do that it provides subjectReads, the set of labels a label can observe from
  and subjectAffects, the set of labels a label can affect.
  Then we can build read_equiv and affects_equiv which are parts of the unwinding relation.
  reads_respects then states that reads_equiv and affects_equiv are preserved
  through a specific function
\<close>

theory InfoFlow
imports ArchInfoFlow
begin

section \<open>Scheduler domain constraint\<close>

text \<open>
  For the information flow theorem, we assume that every domain
  contains threads of exactly one label, so that labels cannot leak
  information through the scheduler.

  Morally, domains that have no labels ought to be allowed as well,
  but this definition is easier to reason about. In practice, we can
  just put all empty domains into some dummy label to satisfy the
  exactly-one requirement. See e.g. the mapping in Example_Valid_State.
\<close>

definition pas_domains_distinct :: "('a, 'b) PAS_scheme \<Rightarrow> bool"
  where
    "pas_domains_distinct aag \<equiv> \<forall>d. \<exists>l. pasDomainAbs aag d = {l}"

section \<open>Reading: subjectReads and associated equivalence properties\<close>

subsection \<open>subjectReads\<close>

text\<open>We take the authority graph from the access proofs. We identify each
   label in that graph with an information flow domain. Our goal is to
   construct an equivalence relation (R l) on states, for each label l of
   the authority graph, that tells us when those two states are equal for
   all state readable by label l -- i.e. all state that falls within l's
   information flow domain. The set of all such state, we denote
   subjectReads g l, where g is the authority graph.\<close>

(* TODO: consider putting the current subject as a parameter and restricting
         the inductive rules to require that 'a' is the current subject *)
inductive_set subjectReads :: "'a auth_graph \<Rightarrow> 'a \<Rightarrow> 'a set"
  for g :: "'a auth_graph" and l :: "'a" where
  (* clearly, l can read from anything it has Read authority to *)
  reads_read: "(l,Read,l') \<in> g \<Longrightarrow>  l' \<in> subjectReads g l"
  (* l can read from itself *)
| reads_lrefl[simp,intro!]: "l \<in> subjectReads g l"
  (* if l has SyncSend or Receive authority to an endpoint, l can read it *)
|  reads_ep:
  "\<lbrakk> (l,auth,ep) \<in> g; auth \<in> {SyncSend,Receive} \<rbrakk>
     \<Longrightarrow> ep \<in> subjectReads g l"
|  reads_read_queued_thread_read_ep:
  (* if someone can send on or reset an endpoint, and l can read from a thread t
     that can receive or send synchronously on that endpoint, then l needs to
     be able to read from the endpoint too. This is because the thread t might
     be blocked waiting to send or receive an that endpoint. When the other
     party completes the rendezvous,
     the affects caused to t depend of course on the state of the endpoint.
     Since t is in l's domain, the ep better be too. *)
  "\<lbrakk> (a, auth', ep) \<in> g; auth' \<in> {Notify,SyncSend,Reset};
     (t, auth, ep) \<in> g; auth \<in> {SyncSend, Receive}; t \<in> subjectReads g l \<rbrakk>
     \<Longrightarrow> ep \<in> subjectReads g l"
  (* if someone, t, can write to a page, and the page is in l's domain, that the
     writer better be too. This is needed for when the page is t's ipc buffer,
     and t is blocked on an IPC and the other party completes the operation.
     The affects caused to the page in question naturally depend on t's state,
     so if the page is part of l's domain, t better be too. *)
| reads_read_page_read_thread:
  "\<lbrakk> b \<in> subjectReads g l; (t,Write,b) \<in> g \<rbrakk>
     \<Longrightarrow> t \<in> subjectReads g l"
  (* This is the symmetric case for the rule reads_read_page_read_thread.
     Here now suppose t is a sender of an IPC and p is its IPC buffer, to which
     it necessarily has Read authority. Suppose t is blocked waiting to complete
     the send, and the receiver completes the rendezvous.
     IF t is in l's domain, then the IPC buffer  had better be too, since it
     will clearly be read during the operation to send the IPC *)
| reads_read_thread_read_pages:
  "\<lbrakk> t \<in> subjectReads g l; (t,Read,p) \<in> g \<rbrakk>
     \<Longrightarrow> p \<in> subjectReads g l"
  (* This rule allows domain l to read from all senders to synchronous endpoints
     for all such endpoints in its domain. This is needed for when someone
     does a receive (for which a sender is already blocked) or reset on the ep.
     The affects on the ep here will depend on the state of any blocked
     senders. So if the ep is in l's domain, the senders better be too. *)
| read_sync_ep_read_senders:
  "\<lbrakk> ep \<in> subjectReads g l; (b,SyncSend,ep) \<in> g \<rbrakk>
     \<Longrightarrow> b \<in> subjectReads g l"
| read_sync_ep_call_senders:
  "\<lbrakk> ep \<in> subjectReads g l; (b,Call,ep) \<in> g \<rbrakk>
     \<Longrightarrow> b \<in> subjectReads g l"
  (* This rule allows anyone who can read a synchronous endpoint, to also be
     able to read from its receivers. The intuition is that the state of the
     receivers can affect how the endpoint is affected. *)
  (* I'm not convinced that this rule is strictly necessary. I think that
     the specific state of the receiver doesn't affect the ep too much and
     that we could probably do away with this rule at the cost of some way more
     complex confidentiality proofs for send_ipc. We would have to prove that
     the affect on the ep is the same regardless of /who/ the reciever is
     (and which page their IPC buffer is etc.). This would involve some quite
     tedious equiv_valid_2 proofs for send_ipc and the functions it calls,
     which don't really seem worth it at the moment. *)
  (* If we removed this rule, all it would gain us I think would be the absence
     of direct edges from receiver \<rightarrow> sender in the infoflow policy, but we
     would still have edges from receiver \<rightarrow> ep \<rightarrow> sender in either case. I
     cannot imagine a useful intransitive noninterference policy that permits
     the latter case but not the former, so the extra cost of doing away with
     this rule does not seem worth it IMO. *)
| read_sync_ep_read_receivers:
  "\<lbrakk> ep \<in> subjectReads g l; (b,Receive,ep) \<in> g \<rbrakk>
     \<Longrightarrow> b \<in> subjectReads g l"
  (* if t can reply to t', then t can send directly information to t' *)
| read_reply_thread_read_thread:
  "\<lbrakk> t' \<in> subjectReads g l; (t,Reply,t') \<in> g \<rbrakk>
     \<Longrightarrow> t \<in> subjectReads g l"
  (* This rule is only there for convinience if Reply authorities corresponds to Call authorities*)
| read_reply_thread_read_thread_rev:
  "\<lbrakk> t' \<in> subjectReads g l; (t',Reply,t) \<in> g \<rbrakk>
     \<Longrightarrow> t \<in> subjectReads g l"
  (* if t can reply to t', then t can send directly information to t' *)
| read_delder_thread_read_thread:
  "\<lbrakk> t' \<in> subjectReads g l; (t,DeleteDerived,t') \<in> g \<rbrakk>
     \<Longrightarrow> t \<in> subjectReads g l"
  (* This rule is only there for convinience if Reply authorities corresponds to Call authorities*)
| read_delder_thread_read_thread_rev:
  "\<lbrakk> t' \<in> subjectReads g l; (t',DeleteDerived,t) \<in> g \<rbrakk>
     \<Longrightarrow> t \<in> subjectReads g l"

abbreviation aag_can_read :: "'a PAS \<Rightarrow> obj_ref \<Rightarrow> bool" where
  "aag_can_read aag x \<equiv> (pasObjectAbs aag x) \<in> subjectReads (pasPolicy aag) (pasSubject aag)"

abbreviation aag_can_read_irq :: "'a PAS \<Rightarrow> irq \<Rightarrow> bool" where
  "aag_can_read_irq aag x \<equiv> (pasIRQAbs aag x) \<in> subjectReads (pasPolicy aag) (pasSubject aag)"

abbreviation aag_can_read_asid :: "'a PAS \<Rightarrow> asid \<Rightarrow> bool" where
  "aag_can_read_asid aag x \<equiv> (pasASIDAbs aag x) \<in> subjectReads (pasPolicy aag) (pasSubject aag)"

(* FIXME: having an op\<noteq> in the definition causes clarsimp to spuriously
   apply classical rules. Using @{term disjnt} may avoid this issue *)
abbreviation aag_can_read_domain :: "'a PAS \<Rightarrow> domain \<Rightarrow> bool" where
  "aag_can_read_domain aag x \<equiv>
     pasDomainAbs aag x \<inter> subjectReads (pasPolicy aag) (pasSubject aag) \<noteq> {}"

subsection \<open>Generic equivalence\<close>

definition equiv_for where
  "equiv_for P f c c' \<equiv>  \<forall>x. P x \<longrightarrow> f c x = f c' x"

subsection \<open>Machine state equivalence\<close>

abbreviation equiv_machine_state :: "(obj_ref \<Rightarrow> bool) \<Rightarrow> machine_state \<Rightarrow> machine_state \<Rightarrow> bool"
where
  "equiv_machine_state P s s' \<equiv> equiv_for (\<lambda>x. P x) underlying_memory s s'
                              \<and> equiv_for (\<lambda>x. P x) device_state s s'"

subsection \<open>ASID equivalence\<close>

definition equiv_asids :: "(asid \<Rightarrow> bool) \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "equiv_asids R s s' \<equiv> \<forall>asid. asid \<noteq> 0 \<and> R asid \<longrightarrow> equiv_asid asid s s'"

definition identical_updates where
  "identical_updates k k' kh kh' \<equiv> \<forall>x. (kh x \<noteq> kh' x \<longrightarrow> (k x = kh x \<and> k' x = kh' x))"

abbreviation identical_kheap_updates where
  "identical_kheap_updates s s' kh kh' \<equiv> identical_updates (kheap s) (kheap s') kh kh'"

abbreviation identical_ekheap_updates where
  "identical_ekheap_updates s s' kh kh' \<equiv> identical_updates (ekheap s) (ekheap s') kh kh'"

lemmas identical_kheap_updates_def = identical_updates_def
lemmas identical_ekheap_updates_def = identical_updates_def

subsection \<open>Generic state equivalence\<close>

text\<open>Define state equivalence for a given set of object references, irqs, asids and domains

The first four parameters are just predicate for those four sets:
  - P : object reference predicate
  - Q : irq predicate
  - R : asid predicate
  - S : domain predicate
\<close>

(*FIXME: We're not ancient Romans and don't need to condense the meaning of
         the universe into S P Q R *)
definition states_equiv_for ::
  "(obj_ref \<Rightarrow> bool) \<Rightarrow> (irq \<Rightarrow> bool) \<Rightarrow> (asid \<Rightarrow> bool) \<Rightarrow>
   (domain \<Rightarrow> bool) \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "states_equiv_for P Q R S s s' \<equiv>
     equiv_for P kheap s s' \<and>
     equiv_machine_state P (machine_state s) (machine_state s') \<and>
     equiv_for (P \<circ> fst) cdt s s' \<and>
     equiv_for P ekheap s s' \<and>
     equiv_for (P \<circ> fst) cdt_list s s' \<and>
     equiv_for (P \<circ> fst) is_original_cap s s' \<and>
     equiv_for Q interrupt_states s s' \<and>
     equiv_for Q interrupt_irq_node s s' \<and>
     equiv_for S  ready_queues s s' \<and>
     equiv_asids R s s'"

(* This the main use of states_equiv_for : P is use to restrict the labels we want to consider *)
abbreviation states_equiv_for_labels ::
  "'a PAS \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "states_equiv_for_labels aag P \<equiv>
      states_equiv_for (\<lambda>x. P (pasObjectAbs aag x)) (\<lambda>x. P (pasIRQAbs aag x))
                       (\<lambda>x. P (pasASIDAbs aag x)) (\<lambda>x. \<exists>l\<in>pasDomainAbs aag x. P l)"

(* We need this to correctly complement the domain mapping, i.e. it's not true that
     states_equiv_but_for_labels aag P = states_equiv_for_labels aag (not P) *)
abbreviation states_equiv_but_for_labels ::
  "'a PAS \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "states_equiv_but_for_labels aag P \<equiv>
     states_equiv_for (\<lambda>x. \<not> P (pasObjectAbs aag x)) (\<lambda> x. \<not> P (pasIRQAbs aag x))
                      (\<lambda>x. \<not> P (pasASIDAbs aag x)) (\<lambda> x. \<forall>l\<in>pasDomainAbs aag x. \<not> P l)"

subsection \<open>Idle thread equivalence\<close>

definition idle_equiv :: "('z :: state_ext) state \<Rightarrow> ('z :: state_ext) state \<Rightarrow> bool" where
  "idle_equiv s s' \<equiv> idle_thread s = idle_thread s' \<and>
                     (\<forall>tcb tcb'. kheap s (idle_thread s) = Some (TCB tcb)
                                 \<longrightarrow> kheap s' (idle_thread s) = Some (TCB tcb')
                                 \<longrightarrow> arch_tcb_context_get (tcb_arch tcb) =
                                     arch_tcb_context_get (tcb_arch tcb')) \<and>
                     (tcb_at (idle_thread s) s \<longleftrightarrow> tcb_at (idle_thread s) s')"

subsection \<open>Global (Kernel) VSpace equivalence\<close>

(* cur_thread is included here also to enforce this being an equivalence relation *)
definition globals_equiv :: "det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "globals_equiv s s' \<equiv>
     arch_globals_equiv (cur_thread s) (idle_thread s) (kheap s) (kheap s')
                        (arch_state s) (arch_state s') (machine_state s) (machine_state s') \<and>
     idle_equiv s s' \<and> cur_thread s = cur_thread s' \<and>
     dom (device_state (machine_state s)) = dom (device_state (machine_state s'))"

subsection \<open>read_equiv\<close>

(* Basically defines the domain of the current thread, excluding globals.
   This also includes the things that are in the scheduler's domain, which
   the current domain is always allowed to read. *)
definition reads_equiv :: "'a PAS \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "reads_equiv aag s s' \<equiv>
     (\<forall>d\<in>subjectReads (pasPolicy aag) (pasSubject aag).
        states_equiv_for_labels aag ((=) d) s s') \<and>
        cur_thread s = cur_thread s' \<and>
        cur_domain s = cur_domain s' \<and>
        scheduler_action s = scheduler_action s' \<and>
        work_units_completed s = work_units_completed s' \<and>
        irq_state (machine_state s) = irq_state (machine_state s')"

(* this is the main equivalence we want to be maintained, since it defines
   everything the current thread can read from; however, we'll deal with
   reads_equiv in the reads_respects proofs, since globals_equiv is always preserved *)
definition reads_equiv_g :: "'a PAS \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "reads_equiv_g aag s s' \<equiv> reads_equiv aag s s' \<and> globals_equiv s s'"

section \<open>Writing: subjectsAffects and affects_equiv\<close>

text \<open>
  This defines the other labels of the authority graph that subject l can
  affect, i.e. if there is some part of the state that carries a label l', and
  through the actions of l, this state can be modified, then we say that the
  label l' can be affected by l. This is, of course, just a more coarse
  statement of the integrity property from the access proofs.
\<close>
(* FIXME: theorem no longer exists
  The case in which @{thm tro_asidpool_clear} is covered when the graph is wellformed
  since, in this case, the subject has Control rights to the asid.
*)
inductive_set subjectAffects :: "'a auth_graph \<Rightarrow> 'a \<Rightarrow> 'a set"
  for g :: "'a auth_graph" and l :: "'a" where
  affects_lrefl:
    "l \<in> subjectAffects g l"
| affects_write:
    "\<lbrakk> (l,auth,l') \<in> g; auth \<in> {Control, Write} \<rbrakk>
       \<Longrightarrow> l' \<in> subjectAffects g l"
| affects_ep:
    "\<lbrakk> (l,auth,l') \<in> g; auth \<in> {Receive, Notify, SyncSend, Call, Reset} \<rbrakk>
       \<Longrightarrow> l' \<in> subjectAffects g l"
  (* ipc buffer is not necessarily owned by thread *)
| affects_send:
    "\<lbrakk> (l,auth,ep) \<in> g; auth \<in> {SyncSend, Notify, Call}; (l',Receive,ep) \<in> g; (l',Write,l'') \<in> g \<rbrakk>
       \<Longrightarrow> l'' \<in> subjectAffects g l"
  (* synchronous sends provide a back-channel from receiver to sender *)
| affects_recv:
    "\<lbrakk> (l,Receive,ep) \<in> g; (l',SyncSend,ep) \<in> g \<rbrakk>
       \<Longrightarrow> l' \<in> subjectAffects g l"
  (* a reply right can only exist if l has a call right to l',
   * so including this case saves us from having to re-derive it *)
| affects_reply_back:
    "(l',Reply,l) \<in> g \<Longrightarrow> l' \<in> subjectAffects g l"
  (* reply direct ipc buffer writing *)
| affects_reply:
    "\<lbrakk> (l,Reply,l') \<in> g; (l',Write,l'') \<in> g \<rbrakk>
       \<Longrightarrow> l'' \<in> subjectAffects g l"
  (* deletion direct channel *)
| affects_delete_derived:
    "(l,DeleteDerived,l') \<in> g \<Longrightarrow> l' \<in> subjectAffects g l"
  (* If two agents can delete the same caps, they can affect each other *)
| affects_delete_derived2:
    "\<lbrakk> (l,DeleteDerived,l') \<in> g; (l'',DeleteDerived,l') \<in> g \<rbrakk>
       \<Longrightarrow> l'' \<in> subjectAffects g l"
  (* integrity definitions allow resets to modify ipc buffer *)
| affects_reset:
    "\<lbrakk> (l,Reset,ep) \<in> g; (l',auth,ep) \<in> g; auth \<in> {SyncSend, Receive}; (l',Write,l'') \<in> g \<rbrakk>
       \<Longrightarrow> l'' \<in> subjectAffects g l"
  (* if you alter an asid mapping, you affect the domain who owns that asid *)
| affects_asidpool_map:
    "(l,AAuth ASIDPoolMapsASID,l') \<in> g \<Longrightarrow> l' \<in> subjectAffects g l"
  (* if you are sending to an ntfn, which is bound to a tcb that i
     receive blocked on an ep, then you can affect that ep *)
| affects_ep_bound_trans:
    "(\<exists>tcb ntfn. (tcb, Receive, ntfn) \<in> g \<and> (tcb, Receive, ep) \<in> g \<and> (l, Notify, ntfn) \<in> g)
     \<Longrightarrow> ep \<in> subjectAffects g l"

(* We define when the current subject can affect another domain whose label is
   l. This occurs when the current subject can affect some label d that is
   considered to be part of what domain l can read. *)
definition aag_can_affect_label where
  "aag_can_affect_label aag l \<equiv> \<exists>d. d \<in> subjectAffects (pasPolicy aag) (pasSubject aag)
                                  \<and> d \<in> subjectReads (pasPolicy aag) l"

(* Defines when two states are equivalent for some domain l that can be affected
   by the current subject. When the current subject cannot affect domain l,
   we relate all states. *)
definition affects_equiv :: "'a PAS \<Rightarrow> 'a \<Rightarrow> det_state \<Rightarrow> det_state \<Rightarrow> bool" where
  "affects_equiv aag l s s' \<equiv>
     if aag_can_affect_label aag l
     then states_equiv_for_labels aag (\<lambda>l'. l' \<in> subjectReads (pasPolicy aag) l) s s'
     else True"

abbreviation aag_can_affect where
  "aag_can_affect aag l \<equiv> \<lambda>x. aag_can_affect_label aag l
                            \<and> pasObjectAbs aag x \<in> subjectReads (pasPolicy aag) l"

abbreviation aag_can_affect_irq where
  "aag_can_affect_irq aag l \<equiv> \<lambda>x. aag_can_affect_label aag l
                                \<and> pasIRQAbs aag x \<in> subjectReads (pasPolicy aag) l"

abbreviation aag_can_affect_asid where
  "aag_can_affect_asid aag l \<equiv> \<lambda>x. aag_can_affect_label aag l
                                 \<and> pasASIDAbs aag x \<in> subjectReads (pasPolicy aag) l"

abbreviation aag_can_affect_domain where
  "aag_can_affect_domain aag l \<equiv> \<lambda>x. aag_can_affect_label aag l
                                   \<and> pasDomainAbs aag x \<inter> subjectReads (pasPolicy aag) l \<noteq> {}"

section \<open>reads_respects\<close>

abbreviation reads_equiv_valid ::
  "(det_state \<Rightarrow> det_state \<Rightarrow> bool) \<Rightarrow> (det_state \<Rightarrow> det_state \<Rightarrow> bool) \<Rightarrow>
   'a PAS \<Rightarrow> (det_state \<Rightarrow> bool) \<Rightarrow> (det_state,'b) nondet_monad \<Rightarrow> bool" where
  "reads_equiv_valid A B aag P f \<equiv> equiv_valid (reads_equiv aag) A B P f"

abbreviation reads_equiv_valid_inv where
  "reads_equiv_valid_inv A aag P f \<equiv> reads_equiv_valid A A aag P f"

abbreviation reads_spec_equiv_valid ::
  "det_state \<Rightarrow> (det_state \<Rightarrow> det_state \<Rightarrow> bool) \<Rightarrow> (det_state \<Rightarrow> det_state \<Rightarrow> bool) \<Rightarrow>
   'a PAS \<Rightarrow> (det_state \<Rightarrow> bool) \<Rightarrow> (det_state,'b) nondet_monad \<Rightarrow> bool" where
  "reads_spec_equiv_valid s A B aag P f \<equiv> spec_equiv_valid s (reads_equiv aag) A B P f"

abbreviation reads_spec_equiv_valid_inv where
  "reads_spec_equiv_valid_inv s A aag P f \<equiv> reads_spec_equiv_valid s A A aag P f"

(* This property is essentially the confidentiality unwinding condition for
   noninterference. *)
abbreviation reads_respects ::
  "'a PAS \<Rightarrow> 'a \<Rightarrow> (det_state \<Rightarrow> bool) \<Rightarrow> (det_state,'b) nondet_monad \<Rightarrow> bool" where
  "reads_respects aag l P f \<equiv> reads_equiv_valid_inv (affects_equiv aag l) aag P f"

abbreviation spec_reads_respects ::
  "det_state \<Rightarrow> 'a PAS \<Rightarrow> 'a \<Rightarrow> (det_state \<Rightarrow> bool) \<Rightarrow> (det_state,'b) nondet_monad \<Rightarrow> bool" where
  "spec_reads_respects s aag l P f \<equiv> reads_spec_equiv_valid_inv s (affects_equiv aag l) aag P f"

abbreviation reads_respects_g ::
  "'a PAS \<Rightarrow> 'a \<Rightarrow> (det_state \<Rightarrow> bool) \<Rightarrow> (det_state,'b) nondet_monad \<Rightarrow> bool" where
  "reads_respects_g aag l P f \<equiv> equiv_valid_inv (reads_equiv_g aag) (affects_equiv aag l) P f"

definition doesnt_touch_globals where
  "doesnt_touch_globals P f \<equiv> \<forall>(s :: det_state). P s \<longrightarrow> (\<forall>(rv,s')\<in>fst (f s). globals_equiv s s')"

abbreviation reads_equiv_valid_rv where
  "reads_equiv_valid_rv A B aag R P f \<equiv> equiv_valid_2 (reads_equiv aag) A B R P P f f"

abbreviation reads_equiv_valid_rv_inv where
  "reads_equiv_valid_rv_inv A aag R P f \<equiv> reads_equiv_valid_rv A A aag R P f"

section \<open>Constraining modifications to a set of label\<close>
(*
   We define here some machinery for reasoning about updates that occur
   outside of what the current subject can read, and the domain l in
   reads_respects. Such updates cannot be "observed" by reads_respects, which
   allows the two code paths to potentially diverge from each other. This is
   important when, e.g. we look at notifications/signals. The actions taken
   during send_signal cannot depend on the state of the notification, so we
   could have the situation in which in one execution the ntfn has someone
   queued on it but in the other it doesn't. This will occur only if the party
   queued on the ntfn is not in the domains the current subject is allowed to
   read from plus domain l (otherwise being reads_equiv aag and affects_equiv
   aag l would (with the invariants) cause him to be on the queue in both
   scenarios). The update that happens to this party's threadstate in one
   execution but not the other, and the different effects that occur to the
   ntfn in each case, therefore, should not break reads_respects because they
   cannot be observed. We need to be able to reason about this, hence this
   machinery.
*)

abbreviation equiv_irq_state where
  "equiv_irq_state ms ms' \<equiv> irq_state ms = irq_state ms'"

definition equiv_but_for_labels where
  "equiv_but_for_labels aag L s s' \<equiv>
     states_equiv_but_for_labels aag (\<lambda>l. l \<in> L) s s' \<and>
     cur_thread s = cur_thread s' \<and> cur_domain s = cur_domain s' \<and>
     scheduler_action s = scheduler_action s' \<and> work_units_completed s = work_units_completed s' \<and>
     equiv_irq_state (machine_state s) (machine_state s')"

definition equiv_but_for_domain where
  "equiv_but_for_domain aag l s s' \<equiv> equiv_but_for_labels aag (subjectReads (pasPolicy aag) l) s s'"

definition modifies_at_most where
  "modifies_at_most aag L P f \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(rv,s')\<in>fst(f s). equiv_but_for_labels aag L s s')"

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 ArrayT

imports "../lib/TypBucket"
        "../adt/BilbyT"
        "../adt/WordArrayT"
        "../lib/Loops"

begin

consts \<alpha>a :: "'a Array \<Rightarrow> 'a Option\<^sub>T list"
consts make :: "'a Option\<^sub>T list \<Rightarrow> 'a Array"
(* I believe we could simplify this by converting the 'a Option\<^sub>T list to a
 'a list first using trimNone  *)
fun trimNone :: "'a Option\<^sub>T list \<Rightarrow> 'a list"
where
  "trimNone [] = []" |
  "trimNone (Option.None ()#xs) = trimNone xs" |
  "trimNone (Option.Some v#xs) = v#(trimNone xs)"

definition
 map_acc_obs_existing :: "('a \<times> 'acc \<times> 'obsv \<Rightarrow> ('a \<times> 'b, 'a \<times> 'acc) LoopResult)
   \<Rightarrow> 'a Option\<^sub>T list
    \<Rightarrow> 'acc \<Rightarrow> 'obsv \<Rightarrow> 'a Option\<^sub>T list \<times>
                     ('b, 'acc) LoopResult"
where
  "map_acc_obs_existing fx xs xacc obs =
     fold (\<lambda>val (ys,lr).
      (case val of Option.None _ \<Rightarrow>
        (ys@[Option.None ()], lr)
       | Option.Some tval \<Rightarrow>
       (case lr of Break xrbrk \<Rightarrow> (ys@[Option.Some tval],Break xrbrk)
         | Iterate accx \<Rightarrow>
          (case fx (tval,accx,obs) of  \<comment> \<open>This is wrong break returns a truncated array\<close>
           Break (tval,xrbrk) \<Rightarrow> (ys@[Option.Some tval], Break xrbrk)
           | Iterate (tval,accx) \<Rightarrow> (ys@[Option.Some tval], Iterate accx)))))
       xs ([],Iterate xacc)"

definition
 arr_iterate_ex_no_break_body :: "(('a, 'acc, 'obsv) ElemAO \<Rightarrow> ('acc \<times> (unit, 'a) R\<^sub>T))
   \<Rightarrow> 'a Option\<^sub>T \<Rightarrow> 'a Option\<^sub>T list \<times> 'acc \<Rightarrow> 'obsv \<Rightarrow> 'a Option\<^sub>T list \<times> 'acc" where
 "arr_iterate_ex_no_break_body \<equiv> \<lambda> body el (ys, acc) obs.
     case el of
        Option.None _ \<Rightarrow> (ys@[Option.None ()], acc)
      | Option.Some tval \<Rightarrow>
        (let (acc, r) = body (ElemAO.make  tval acc obs)
          in case r of
               Result.Success _ \<Rightarrow> (ys @ [ Option.None () :: 'a Option\<^sub>T], acc)
             | Result.Error   a \<Rightarrow> (ys @ [ Option.Some a ], acc))"

definition
 "array_iterate_ex_no_break body xs accx obs \<equiv>
   arr_iteratei (length xs) xs (\<lambda>_. True) (arr_iterate_ex_no_break_body body) ([],accx) obs"

definition
  mapAccumObsOpt :: "nat \<Rightarrow> nat \<Rightarrow>
    (('a Option\<^sub>T, 'acc, 'obsv) OptElemAO
      \<Rightarrow> ('a Option\<^sub>T \<times> 'd, 'a Option\<^sub>T \<times> 'acc) LoopResult)
   \<Rightarrow> 'a Option\<^sub>T list \<Rightarrow> 'acc \<Rightarrow> 'obsv \<Rightarrow> ('a Option\<^sub>T list \<times> 'd, 'a Option\<^sub>T list \<times> 'acc) LoopResult"
where
  "mapAccumObsOpt frm to fn xs vacc obs =
   (case (fold (\<lambda>elem iter.
                (case iter
                  of Iterate (ys, acc)  \<Rightarrow>
                     (case fn (OptElemAO.make elem acc obs)
                       of Iterate (oelem, acc) \<Rightarrow> Iterate (ys @ [oelem], acc)
                        | Break (oelem, d) \<Rightarrow> Break (ys @ [oelem], d))
                   | Break (ys, d) \<Rightarrow> Break (ys @ [elem], d)))
               (slice frm to xs) (Iterate ([],vacc)))
     of Iterate (ys, acc) \<Rightarrow> Iterate (take frm xs @ ys @ drop (max frm to) xs, acc)
      | Break  (ys, d) \<Rightarrow> Break (take frm xs @ ys @ drop (max frm to) xs, d))"

axiomatization where
  array_make: "\<alpha>a (ArrayT.make xs) = xs"
  and
  array_make': "ArrayT.make (\<alpha>a a) = a"
  and
  array_create_ret:
   "\<lbrakk>  \<And>ex'. (ex',Option.None ()) = malloc ex \<Longrightarrow> P (Error ex');
       \<And>ex' arr a. \<lbrakk> sz > 0 ; (ex', Option.Some arr) = malloc ex;
             \<alpha>a a = replicate (unat sz) (Option.None ()) \<rbrakk> \<Longrightarrow>
           P (Success (ex', a))
     \<rbrakk> \<Longrightarrow>
      P (array_create (ex, sz))"
  and
  array_length_ret:
   "unat (array_length arr) = length (\<alpha>a arr)"
  and
  array_nb_elem_ret:
   "unat (array_nb_elem arrx) = \<alpha>_array_nb_elem (\<alpha>a arrx)"
  and
  array_modify_ret:
   "\<And>P r arr'. \<lbrakk> unat index < length (\<alpha>a arr);
       r = modifier (OptElemA.make ((\<alpha>a arr)!unat index)  acc);
       arr' = ArrayT.make ((\<alpha>a arr)[unat index:= OptElemA.oelem\<^sub>f r]);
       P (\<lparr> ArrA.arr\<^sub>f = arr', acc\<^sub>f = (OptElemA.acc\<^sub>f r) \<rparr>) \<rbrakk> \<Longrightarrow>
        P (array_modify (ArrayModifyP.make arr index modifier acc))"
      (* arr' = snd (select (arr,{v. \<alpha>a v = (\<alpha>a arr)[unat index:=Some (OptElemA.oelem\<^sub>f r)]})); *)
(*
axiomatization where array_iterate_existing_ret:
   "\<And>P. P (map_acc_obs_existing body (\<alpha>a arrx) accx obs)
   \<Longrightarrow> case array_iterate_existing (arrx, body, accx, obs) of
        Break (arrx,rbrkx) \<Rightarrow> P ((\<alpha>a arrx), Break rbrkx)
       | Iterate (arrx, accx) \<Rightarrow> P ((\<alpha>a arrx), Iterate accx)"
*)
  and
  array_iterate_enb_ret:
   "\<And>P. let (arr, acc) = array_iterate_ex_no_break body (\<alpha>a arr) acc obs
        in P (ArrA.make (ArrayT.make arr) acc)
   \<Longrightarrow> P (array_filter (ArrayFoldP.make arr body acc obs))"
 and array_map_ret:
  "array_map am =
   (case (mapAccumObsOpt
      (unat (ArrayMapP.frm\<^sub>f am)) (unat (ArrayMapP.to\<^sub>f am)) (ArrayMapP.f\<^sub>f am)
      (\<alpha>a (ArrayMapP.arr\<^sub>f am)) (ArrayMapP.acc\<^sub>f am) (ArrayMapP.obsv\<^sub>f am))
    of Iterate (ys, acc) \<Rightarrow>  Iterate (ArrayT.make ys, acc)
     | Break  (ys, d) \<Rightarrow> Break(ArrayT.make ys, d))"

lemma array_\<alpha>a_eq:
  "(xs = ys) \<longleftrightarrow> \<alpha>a xs = \<alpha>a ys"
  apply (rule iffI)
   apply (erule arg_cong[where f=\<alpha>a])
  apply (drule_tac x="\<alpha>a xs" and y="\<alpha>a ys" in arg_cong[where f=ArrayT.make])
  apply (simp add: array_make')
  done

lemma array_make_eq:
  "(xs = ys) \<longleftrightarrow> ArrayT.make xs = ArrayT.make ys"
  apply (rule iffI)
   apply (erule arg_cong[where f=ArrayT.make])
  apply (drule_tac x="ArrayT.make xs" and y="ArrayT.make ys" in arg_cong[where f=\<alpha>a])
  apply (simp add: array_make)
  done

end