section \<open>Executable compilation chain\<close>

theory Compiler
imports Composition
begin

definition term_to_exp :: "C_info \<Rightarrow> rule fset \<Rightarrow> term \<Rightarrow> exp" where
"term_to_exp C_info rs t =
  cakeml.mk_con C_info (heads_of rs |\<union>| constructors.C C_info)
    (pterm_to_sterm (nterm_to_pterm (fresh_frun (term_to_nterm [] t) (heads_of rs |\<union>| constructors.C C_info))))"

lemma (in rules) "Compiler.term_to_exp C_info rs = term_to_cake"
  unfolding term_to_exp_def by (simp add: all_consts_def)

primrec compress_pterm :: "pterm \<Rightarrow> pterm" where
"compress_pterm (Pabs cs) = Pabs (fcompress (map_prod id compress_pterm |`| cs))" |
"compress_pterm (Pconst name) = Pconst name" |
"compress_pterm (Pvar name) = Pvar name" |
"compress_pterm (t $\<^sub>p u) = compress_pterm t $\<^sub>p compress_pterm u"

lemma compress_pterm_eq[simp]: "compress_pterm t = t"
by (induction t) (auto simp: subst_pabs_id fset_map_snd_id map_prod_def fmember.rep_eq)

definition compress_crule_set :: "crule_set \<Rightarrow> crule_set" where
"compress_crule_set = fcompress \<circ> fimage (map_prod id fcompress)"

definition compress_irule_set :: "irule_set \<Rightarrow> irule_set" where
"compress_irule_set = fcompress \<circ> fimage (map_prod id (fcompress \<circ> fimage (map_prod id compress_pterm)))"

definition compress_prule_set :: "prule fset \<Rightarrow> prule fset" where
"compress_prule_set = fcompress \<circ> fimage (map_prod id compress_pterm)"

lemma compress_crule_set_eq[simp]: "compress_crule_set rs = rs"
unfolding compress_crule_set_def by force

lemma compress_irule_set_eq[simp]: "compress_irule_set rs = rs"
unfolding compress_irule_set_def map_prod_def by simp

lemma compress_prule_set[simp]: "compress_prule_set rs = rs"
unfolding compress_prule_set_def by force

definition transform_irule_set_iter :: "irule_set \<Rightarrow> irule_set" where
"transform_irule_set_iter rs = ((transform_irule_set \<circ> compress_irule_set) ^^ max_arity rs) rs"

definition as_sem_env :: "C_info \<Rightarrow> srule list \<Rightarrow> v sem_env \<Rightarrow> v sem_env" where
"as_sem_env C_info rs env =
  \<lparr> sem_env.v =
      build_rec_env (cakeml.mk_letrec_body C_info (fset_of_list (map fst rs) |\<union>| constructors.C C_info) rs) env nsEmpty,
    sem_env.c =
      nsEmpty \<rparr>"

definition empty_sem_env :: "C_info \<Rightarrow> v sem_env" where
"empty_sem_env C_info = \<lparr> sem_env.v = nsEmpty, sem_env.c = constructors.as_static_cenv C_info \<rparr>"

definition sem_env :: "C_info \<Rightarrow> srule list \<Rightarrow> v sem_env" where
"sem_env C_info rs = extend_dec_env (as_sem_env C_info rs (empty_sem_env C_info)) (empty_sem_env C_info)"

definition compile :: "C_info \<Rightarrow> rule fset \<Rightarrow> Ast.prog" where
"compile C_info =
  CakeML_Backend.compile' C_info \<circ>
  Rewriting_Sterm.compile \<circ>
  compress_prule_set \<circ>
  Rewriting_Pterm.compile \<circ>
  transform_irule_set_iter \<circ>
  compress_irule_set \<circ>
  Rewriting_Pterm_Elim.compile \<circ>
  compress_crule_set \<circ>
  Rewriting_Nterm.consts_of \<circ>
  fcompress \<circ>
  Rewriting_Nterm.compile' C_info \<circ>
  fcompress"

definition compile_to_env :: "C_info \<Rightarrow> rule fset \<Rightarrow> v sem_env" where
"compile_to_env C_info =
  sem_env C_info \<circ>
  Rewriting_Sterm.compile \<circ>
  compress_prule_set \<circ>
  Rewriting_Pterm.compile \<circ>
  transform_irule_set_iter \<circ>
  compress_irule_set \<circ>
  Rewriting_Pterm_Elim.compile \<circ>
  compress_crule_set \<circ>
  Rewriting_Nterm.consts_of \<circ>
  fcompress \<circ>
  Rewriting_Nterm.compile' C_info \<circ>
  fcompress"

lemma (in rules) "Compiler.compile_to_env C_info rs = rules.cake_sem_env C_info rs"
unfolding Compiler.compile_to_env_def Compiler.sem_env_def Compiler.as_sem_env_def Compiler.empty_sem_env_def
unfolding rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.sem_env_def
unfolding rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_sem_env_def
unfolding empty_sem_env_def
by (auto simp:
        Compiler.compress_irule_set_eq[abs_def]
        Composition.transform_irule_set_iter_def[abs_def]
        Compiler.transform_irule_set_iter_def[abs_def] comp_def pre_constants.all_consts_def)

export_code
  term_to_exp compile compile_to_env
  checking Scala

end


(*  Title:      JinjaDCI/Compiler/Compiler.thy

    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   TUM 2003, UIUC 2019-20

    Based on the Jinja theory Compiler/Compiler.thy by Tobias Nipkow
*)

section \<open> Combining Stages 1 and 2 \<close>

theory Compiler
imports Correctness1 Correctness2
begin

definition J2JVM :: "J_prog \<Rightarrow> jvm_prog"
where
  "J2JVM  \<equiv>  compP\<^sub>2 \<circ> compP\<^sub>1"

theorem comp_correct_NonStatic:
assumes wf: "wf_J_prog P"
and "method": "P \<turnstile> C sees M,NonStatic:Ts\<rightarrow>T = (pns,body) in C"
and eval: "P \<turnstile> \<langle>body,(h,[this#pns [\<mapsto>] vs],sh)\<rangle> \<Rightarrow> \<langle>e',(h',l',sh')\<rangle>"
and sizes: "size vs = size pns + 1"    "size rest = max_vars body"
shows "J2JVM P \<turnstile> (None,h,[([],vs@rest,C,M,0,No_ics)],sh) -jvm\<rightarrow> (exception e',h',[],sh')"
(*<*)
proof -
  let ?P\<^sub>1 = "compP\<^sub>1 P"
  have nclinit: "M \<noteq> clinit" using wf_sees_clinit1[OF wf] visible_method_exists[OF "method"]
    sees_method_idemp[OF "method"] by fastforce
  have wf\<^sub>1: "wf_J\<^sub>1_prog ?P\<^sub>1" by(rule compP\<^sub>1_pres_wf[OF wf])
  have fv: "fv body \<subseteq> set (this#pns)"
    using wf_prog_wwf_prog[OF wf] "method" by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have init: "[this#pns [\<mapsto>] vs] \<subseteq>\<^sub>m [this#pns [\<mapsto>] vs@rest]"
    using sizes by simp
  have "?P\<^sub>1 \<turnstile> C sees M,NonStatic: Ts\<rightarrow>T = (compE\<^sub>1 (this#pns) body) in C"
    using sees_method_compP[OF "method", of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  moreover obtain ls' where
    "?P\<^sub>1 \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 (this#pns) body, (h, vs@rest, sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e', (h',ls', sh')\<rangle>"
    using eval\<^sub>1_eval[OF wf_prog_wwf_prog[OF wf] eval fv init] sizes by auto
  ultimately show ?thesis using comp\<^sub>2_correct[OF wf\<^sub>1] eval_final[OF eval] nclinit
    by(fastforce simp add:J2JVM_def final_def)
qed
(*>*)

theorem comp_correct_Static:
assumes wf: "wf_J_prog P"
and "method": "P \<turnstile> C sees M,Static:Ts\<rightarrow>T = (pns,body) in C"
and eval: "P \<turnstile> \<langle>body,(h,[pns [\<mapsto>] vs],sh)\<rangle> \<Rightarrow> \<langle>e',(h',l',sh')\<rangle>"
and sizes: "size vs = size pns"    "size rest = max_vars body"
and nclinit: "M \<noteq> clinit"
shows "J2JVM P \<turnstile> (None,h,[([],vs@rest,C,M,0,No_ics)],sh) -jvm\<rightarrow> (exception e',h',[],sh')"
(*<*)
proof -
  let ?P\<^sub>1 = "compP\<^sub>1 P"
  have wf\<^sub>1: "wf_J\<^sub>1_prog ?P\<^sub>1" by(rule compP\<^sub>1_pres_wf[OF wf])
  have fv: "fv body \<subseteq> set pns"
    using wf_prog_wwf_prog[OF wf] "method" by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have init: "[pns [\<mapsto>] vs] \<subseteq>\<^sub>m [pns [\<mapsto>] vs@rest]"
    using sizes by simp
  have "?P\<^sub>1 \<turnstile> C sees M,Static: Ts\<rightarrow>T = (compE\<^sub>1 pns body) in C"
    using sees_method_compP[OF "method", of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  moreover obtain ls' where
    "?P\<^sub>1 \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 pns body, (h, vs@rest, sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e', (h',ls', sh')\<rangle>"
    using eval\<^sub>1_eval[OF wf_prog_wwf_prog[OF wf] eval fv init] sizes by auto
  ultimately show ?thesis using comp\<^sub>2_correct[OF wf\<^sub>1] eval_final[OF eval] nclinit
    by(fastforce simp add:J2JVM_def final_def)
qed
(*>*)

end


(*  Title:      HOL/MicroJava/JVM/JVMState.thy
    Author:     Cornelia Pusch, Gerwin Klein, Technische Universitaet Muenchen
*)

chapter \<open>Java Virtual Machine \label{cha:jvm}\<close>

section \<open>State of the JVM\<close>

theory JVMState
imports "../J/Conform"
begin

subsection \<open>Frame Stack\<close>
type_synonym opstack = "val list"
type_synonym locvars = "val list"
type_synonym p_count = nat

type_synonym
 frame = "opstack \<times>
          locvars \<times>
          cname \<times>
          sig \<times>
          p_count"

  \<comment> "operand stack"
  \<comment> "local variables (including this pointer and method parameters)"
  \<comment> "name of class where current method is defined"
  \<comment> "method name + parameter types"
  \<comment> "program counter within frame"

subsection \<open>Exceptions\<close>
definition raise_system_xcpt :: "bool \<Rightarrow> xcpt \<Rightarrow> val option" where
  "raise_system_xcpt b x \<equiv> raise_if b x None"

subsection \<open>Runtime State\<close>
type_synonym
  jvm_state = "val option \<times> aheap \<times> frame list"  \<comment> "exception flag, heap, frames"

subsection \<open>Lemmas\<close>

lemma new_Addr_OutOfMemory:
  "snd (new_Addr hp) = Some xcp \<Longrightarrow> xcp = Addr (XcptRef OutOfMemory)"
proof -
  obtain ref xp where "new_Addr hp = (ref, xp)" by (cases "new_Addr hp")
  moreover
  assume "snd (new_Addr hp) = Some xcp"
  ultimately
  show ?thesis by (auto dest: new_AddrD)
qed

end


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

(*header{*The n_german Protocol Case Study*}*)

theory n_german_lemma_inv__26_on_rules imports n_german_lemma_on_inv__26
begin
section{*All lemmas on causal relation between inv__26*}
lemma lemma_inv__26_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__26  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__26) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


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

header{*The n_german Protocol Case Study*}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


(*
 * Copyright 2014, 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 InfoFlow
imports
  "../access-control/Syscall_AC"
  "../../lib/EquivValid"
begin

context begin interpretation Arch . (*FIXME: arch_split*)

(* 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. *)

(* 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: "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_strong:
  "\<lbrakk>ep \<in> subjectReads g l; (b,SyncSend,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_strong:
  "\<lbrakk>ep \<in> subjectReads g l; (b,Receive,ep) \<in> g\<rbrakk> \<Longrightarrow>
   b \<in> subjectReads g l"

lemma read_sync_ep_read_senders:
  "\<lbrakk>(a,auth,ep) \<in> g; auth \<in> {Reset,Receive};
    ep \<in> subjectReads g l; (b,SyncSend,ep) \<in> g\<rbrakk> \<Longrightarrow>
   b \<in> subjectReads g l"
   by (rule read_sync_ep_read_senders_strong)

lemma read_sync_ep_read_receivers:
  "\<lbrakk>(a,auth,ep) \<in> g; auth \<in> {SyncSend};
    ep \<in> subjectReads g l; (b,Receive,ep) \<in> g\<rbrakk> \<Longrightarrow>
   b \<in> subjectReads g l"
   by (rule read_sync_ep_read_receivers_strong)

abbreviation aag_can_read :: "'a PAS \<Rightarrow> word32 \<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> 10 word \<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)"

abbreviation aag_can_read_domain :: "'a PAS \<Rightarrow> domain \<Rightarrow> bool"
where
"aag_can_read_domain aag x \<equiv> (pasDomainAbs aag x) \<in> subjectReads (pasPolicy aag) (pasSubject aag)"

lemma aag_can_read_self:
  "is_subject aag x \<Longrightarrow> aag_can_read aag x"
  apply(fastforce intro: reads_lrefl)
  done

lemma aag_can_read_read:
  "aag_has_auth_to aag Read x \<Longrightarrow> aag_can_read aag x"
  apply(fastforce intro: reads_read)
  done

lemma aag_can_read_irq_self:
  "is_subject_irq aag x \<Longrightarrow> aag_can_read_irq aag x"
  apply(fastforce intro: reads_lrefl)
  done

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

lemma equiv_forE:
  assumes e: "equiv_for P f c c'"
  assumes r: "(\<And> x. P x \<Longrightarrow> f c x = f c' x) \<Longrightarrow> R"
  shows "R"
  apply(rule r)
  apply(erule e[simplified equiv_for_def, rule_format])
  done

lemma equiv_forI:
  "(\<And> x. P x \<Longrightarrow> f c x = f c' x) \<Longrightarrow> equiv_for P f c c'"
  by(simp add: equiv_for_def)

lemma equiv_forD:
  "equiv_for P f c c' \<Longrightarrow> P x \<Longrightarrow> f c x = f c' x"
  apply(blast elim: equiv_forE)
  done

abbreviation equiv_machine_state :: "(word32 \<Rightarrow> bool)  \<Rightarrow> 'a machine_state_scheme \<Rightarrow> 'a machine_state_scheme \<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'"

definition equiv_asid :: "asid \<Rightarrow> det_ext state \<Rightarrow> det_ext state \<Rightarrow> bool"
where
  "equiv_asid asid s s' \<equiv>
    ((arm_asid_table (arch_state s) (asid_high_bits_of asid)) =
     (arm_asid_table (arch_state s') (asid_high_bits_of asid))) \<and>
    (\<forall> pool_ptr.
         arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some pool_ptr \<longrightarrow>
          asid_pool_at pool_ptr s = asid_pool_at pool_ptr s' \<and>
          (\<forall> asid_pool asid_pool'.
             kheap s pool_ptr = Some (ArchObj (ASIDPool asid_pool)) \<and>
             kheap s' pool_ptr = Some (ArchObj (ASIDPool asid_pool')) \<longrightarrow> asid_pool (ucast asid) = asid_pool' (ucast asid)))"

definition equiv_asid' where
  "equiv_asid' asid pool_ptr_opt pool_ptr_opt' kh kh' \<equiv>
    (case pool_ptr_opt of None \<Rightarrow> pool_ptr_opt' = None
                        | Some pool_ptr \<Rightarrow>
       (case pool_ptr_opt' of None \<Rightarrow> False
                            | Some pool_ptr' \<Rightarrow>
          (pool_ptr' = pool_ptr \<and>
           ((\<exists> asid_pool. kh pool_ptr = Some (ArchObj (ASIDPool asid_pool))) =
            (\<exists> asid_pool'. kh' pool_ptr' = Some (ArchObj (ASIDPool asid_pool')))) \<and>
           (\<forall> asid_pool asid_pool'.
             kh pool_ptr = Some (ArchObj (ASIDPool asid_pool)) \<and>
             kh' pool_ptr' = Some (ArchObj (ASIDPool asid_pool')) \<longrightarrow> asid_pool (ucast asid) = asid_pool' (ucast asid)))
       )
    )"

lemma asid_pool_at_kheap:
  "asid_pool_at ptr s = (\<exists> asid_pool. kheap s ptr = Some (ArchObj (ASIDPool asid_pool)))"
  apply(clarsimp simp:  obj_at_def)
  apply(rule iffI)
   apply(erule exE, rename_tac ko, clarsimp)
  apply (clarsimp simp: a_type_simps)
  done

lemma equiv_asid:
  "equiv_asid asid s s' = equiv_asid' asid (arm_asid_table (arch_state s) (asid_high_bits_of asid)) (arm_asid_table (arch_state s') (asid_high_bits_of asid)) (kheap s) (kheap s')"
  apply(auto simp: equiv_asid_def equiv_asid'_def split: option.splits simp: asid_pool_at_kheap)
  done

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

lemma equiv_asids_refl:
  "equiv_asids R s s"
  apply(auto simp: equiv_asids_def equiv_asid_def)
  done

lemma equiv_asids_sym:
  "equiv_asids R s t \<Longrightarrow> equiv_asids R t s"
  apply(auto simp: equiv_asids_def equiv_asid_def)
  done

lemma equiv_asids_trans:
  "\<lbrakk>equiv_asids R s t; equiv_asids R t u\<rbrakk> \<Longrightarrow> equiv_asids R s u"
  apply(fastforce simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap)
  done

definition non_asid_pool_kheap_update where
  "non_asid_pool_kheap_update s kh \<equiv>
    \<forall> x. (\<exists> asid_pool. kheap s x = Some (ArchObj (ASIDPool asid_pool)) \<or> kh x = Some (ArchObj (ASIDPool asid_pool))) \<longrightarrow>  kheap s x = kh x"

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

lemma equiv_asids_non_asid_pool_kheap_update:
  "\<lbrakk>equiv_asids R s s';
    non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh'\<rbrakk> \<Longrightarrow>
  equiv_asids R (s\<lparr>kheap := kh\<rparr>) (s'\<lparr>kheap := kh'\<rparr>)"
  apply(clarsimp simp: equiv_asids_def equiv_asid non_asid_pool_kheap_update_def)
  apply(fastforce simp: equiv_asid'_def split: option.splits)
  done

lemma equiv_asids_identical_kheap_updates:
  "\<lbrakk>equiv_asids R s s';
    identical_kheap_updates s s' kh kh'\<rbrakk> \<Longrightarrow>
  equiv_asids R (s\<lparr>kheap := kh\<rparr>) (s'\<lparr>kheap := kh'\<rparr>)"
  apply(clarsimp simp: equiv_asids_def identical_kheap_updates_def)
  apply(clarsimp simp: equiv_asid_def asid_pool_at_kheap)
  apply(case_tac "kh pool_ptr = kh' pool_ptr")
   apply fastforce
  apply fastforce
  done

lemma equiv_asids_triv:
  "\<lbrakk>equiv_asids R s s';
    kheap t = kheap s; arm_asid_table (arch_state t) = arm_asid_table (arch_state s);
    kheap t' = kheap s'; arm_asid_table (arch_state t') = arm_asid_table (arch_state s')\<rbrakk> \<Longrightarrow>
   equiv_asids R t t'"
  apply(fastforce simp: equiv_asids_def equiv_asid equiv_asid'_def)
  done

(* The parameter X here allows us to exclude a (state-dependant) portion of the
   underlying_memory from the equivalence realtions. This is used to exclude
   the contents of the globals_frame, which we include later in the overall
   equivalence relation only for the domain of the current thread. We want to
   easily exclude it for everyone else though, which is why this X parameter
   is included here. *)

definition states_equiv_for :: "(word32 \<Rightarrow> bool) \<Rightarrow> (10 word \<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'"

lemma equiv_for_comp:
  "equiv_for P (f \<circ> g) s s' = equiv_for P f (g s) (g s')"
  apply(simp add: equiv_for_def)
  done

lemma states_equiv_forI:
  "\<lbrakk>equiv_for P kheap s s';
   equiv_machine_state P (machine_state s) (machine_state s');
   equiv_for (P \<circ> fst) cdt s s';
   equiv_for P ekheap s s';
   equiv_for (P \<circ> fst) cdt_list s s';
   equiv_for (P \<circ> fst) is_original_cap s s';
   equiv_for Q interrupt_states s s';
   equiv_for Q interrupt_irq_node s s';
   equiv_asids R s s';
   equiv_for S ready_queues s s'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S s s'"
  by(auto simp: states_equiv_for_def)

lemma states_equiv_for_machine_state_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_machine_state P kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> machine_state := kh \<rparr>) (s'\<lparr> machine_state := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI
                 elim!: equiv_asids_triv)
  done

lemma states_equiv_for_non_asid_pool_kheap_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for P id kh kh';
    non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> kheap := kh \<rparr>) (s'\<lparr> kheap := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_non_asid_pool_kheap_update)
  done

lemma states_equiv_for_identical_kheap_updates:
  "\<lbrakk>states_equiv_for P Q R S s s';
    identical_kheap_updates s s' kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> kheap := kh \<rparr>) (s'\<lparr> kheap := kh' \<rparr>)"
  apply(clarsimp simp: states_equiv_for_def)
  apply(auto elim!: equiv_forE intro!: equiv_forI elim!: equiv_asids_identical_kheap_updates simp: identical_kheap_updates_def)
  done

lemma states_equiv_for_cdt_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for (P \<circ> fst) id kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> cdt := kh \<rparr>) (s'\<lparr> cdt := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def  elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_for_cdt_list_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for (P \<circ> fst) id (kh (cdt_list s)) (kh' (cdt_list s'))\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (cdt_list_update kh s) (cdt_list_update kh' s')"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_for_identical_ekheap_updates:
  "\<lbrakk>states_equiv_for P Q R S s s';
    identical_ekheap_updates s s' (kh (ekheap s)) (kh' (ekheap s'))\<rbrakk> \<Longrightarrow>
    states_equiv_for P Q R S (ekheap_update kh s) (ekheap_update kh' s')"
  apply (clarsimp simp add: identical_ekheap_updates_def equiv_for_def states_equiv_for_def equiv_asids_def equiv_asid_def)
  apply fastforce
  done

lemma states_equiv_for_ekheap_update:
  "\<lbrakk>states_equiv_for P Q R S s s';
    equiv_for P id (kh (ekheap s)) (kh' (ekheap s'))\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (ekheap_update kh s) (ekheap_update kh' s')"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_for_is_original_cap_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for (P \<circ> fst) id kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> is_original_cap := kh \<rparr>) (s'\<lparr> is_original_cap := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_for_interrupt_states_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for Q id kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> interrupt_states := kh \<rparr>) (s'\<lparr> interrupt_states := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_for_interrupt_irq_node_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for Q id kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> interrupt_irq_node := kh \<rparr>) (s'\<lparr> interrupt_irq_node := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_for_ready_queues_update:
  "\<lbrakk>states_equiv_for P Q R S s s'; equiv_for S id kh kh'\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S (s\<lparr> ready_queues := kh \<rparr>) (s'\<lparr> ready_queues := kh' \<rparr>)"
  apply(fastforce simp: states_equiv_for_def elim: equiv_forE intro: equiv_forI elim!: equiv_asids_triv)
  done

lemma states_equiv_forE:
  assumes sef: "states_equiv_for P Q R S s s'"
  assumes e: "\<lbrakk>equiv_machine_state P (machine_state s) (machine_state s');
     equiv_for P kheap s s';
     equiv_for (P \<circ> fst) cdt s s';
     equiv_for (P \<circ> fst) cdt_list s s';
     equiv_for P ekheap s s';
     equiv_for (P \<circ> fst) is_original_cap s s';
     equiv_for Q interrupt_states s s'; equiv_for Q interrupt_irq_node s s';
     equiv_asids R s s';
     equiv_for S ready_queues s s'\<rbrakk> \<Longrightarrow> Z"
  shows "Z"
  apply(rule e)
  using sef[simplified states_equiv_for_def] by auto

lemma equiv_for_apply: "equiv_for P g (f s) (f s') = equiv_for P (g o f) s s'"
  apply (simp add: equiv_for_def)
  done

lemma states_equiv_forE_kheap:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. P x \<Longrightarrow> kheap s x = kheap s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_mem:
  "\<lbrakk>states_equiv_for P Q R S s s';
  (\<And> x. \<lbrakk>P x\<rbrakk>
  \<Longrightarrow> (underlying_memory (machine_state s)) x = (underlying_memory (machine_state s')) x
  \<and> (device_state (machine_state s)) x = (device_state (machine_state s')) x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  apply (clarsimp simp: states_equiv_for_def elim: equiv_forE)
  apply (elim equiv_forE)
  apply fastforce
  done

lemma states_equiv_forE_cdt:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. P (fst x) \<Longrightarrow> cdt s x = cdt s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_cdt_list:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. P (fst x) \<Longrightarrow> cdt_list s x = cdt_list s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_ekheap:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. P x \<Longrightarrow> ekheap s x = ekheap s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_is_original_cap:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. P (fst x) \<Longrightarrow> is_original_cap s x = is_original_cap s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_interrupt_states:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. Q x \<Longrightarrow> interrupt_states s x = interrupt_states s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_interrupt_irq_node:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. Q x \<Longrightarrow> interrupt_irq_node s x = interrupt_irq_node s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma states_equiv_forE_ready_queues:
  "\<lbrakk>states_equiv_for P Q R S s s'; (\<And> x. S x \<Longrightarrow> ready_queues s x = ready_queues s' x) \<Longrightarrow> Z\<rbrakk> \<Longrightarrow> Z"
  by(auto simp: states_equiv_for_def elim: equiv_forE)

lemma equiv_for_refl:
  "equiv_for P f s s"
  by(auto simp: equiv_for_def)

lemma equiv_for_sym:
  "equiv_for P f s t \<Longrightarrow> equiv_for P f t s"
  by(auto simp: equiv_for_def)

lemma equiv_for_trans:
  "\<lbrakk>equiv_for P f s t; equiv_for P f t u\<rbrakk> \<Longrightarrow>
   equiv_for P f s u"
  by(auto simp: equiv_for_def)

lemma states_equiv_for_refl:
  "states_equiv_for P Q R S s s"
  by(auto simp: states_equiv_for_def  intro: equiv_for_refl equiv_asids_refl)

lemma states_equiv_for_sym:
  "states_equiv_for P Q R S s t \<Longrightarrow> states_equiv_for P Q R S t s"
  apply(auto simp: states_equiv_for_def intro: equiv_for_sym equiv_asids_sym simp: equiv_for_def)
  done

lemma states_equiv_for_trans:
  "\<lbrakk>states_equiv_for P Q R S s t; states_equiv_for P Q R S t u\<rbrakk> \<Longrightarrow>
   states_equiv_for P Q R S s u"
  apply(auto simp: states_equiv_for_def intro: equiv_for_trans equiv_asids_trans intro: equiv_forI elim: equiv_forE)
  done

lemma or_comp_dist:
  "(A or B) \<circ> f = (A \<circ> f or B \<circ> f)"
  apply(simp add: pred_disj_def comp_def)
  done

lemma equiv_for_or:
  "equiv_for (A or B) f c c' = (equiv_for A f c c' \<and> equiv_for B f c c')"
  apply(fastforce simp: equiv_for_def)
  done

lemma equiv_for_id_update:
  "equiv_for P id c c' \<Longrightarrow>
   equiv_for P id (c(x := v)) (c'(x := v))"
  apply(simp add: equiv_for_def)
  done

(* globals_equiv should be maintained by everything except the scheduler, since
   nothing else touches the globals frame *)

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')"

lemma idle_equiv_refl: "idle_equiv s s"
  apply (simp add: idle_equiv_def)
  done

lemma idle_equiv_sym: "idle_equiv s s' \<Longrightarrow> idle_equiv s' s"
  apply (clarsimp simp add: idle_equiv_def)
  done

lemma idle_equiv_trans: "idle_equiv s s' \<Longrightarrow> idle_equiv s' s'' \<Longrightarrow> idle_equiv s s''"
  apply (clarsimp simp add: idle_equiv_def tcb_at_def get_tcb_def split: option.splits
                  kernel_object.splits)
  done

abbreviation exclusive_state_equiv where
  "exclusive_state_equiv s s' \<equiv>
     exclusive_state (machine_state s) = exclusive_state (machine_state s')"

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

(* 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 (\<lambda>x. pasObjectAbs aag x = d) (\<lambda>x. pasIRQAbs aag x = d) (\<lambda>x. pasASIDAbs aag x = d) (\<lambda>x. pasDomainAbs aag x = 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'"

lemma reads_equiv_def2:
  "reads_equiv aag s s' =
  (states_equiv_for (aag_can_read aag) (aag_can_read_irq aag) (aag_can_read_asid aag) (aag_can_read_domain aag)  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'))"
  apply(rule iffI)
   apply(auto simp: reads_equiv_def equiv_for_def states_equiv_for_def intro: reads_lrefl simp: equiv_asids_def)
  done

lemma reads_equivE:
  assumes sef: "reads_equiv aag s s'"
  assumes e: "\<lbrakk>equiv_for (aag_can_read aag) kheap s s';
               equiv_machine_state (aag_can_read aag) (machine_state s) (machine_state s');
     equiv_for ((aag_can_read aag) \<circ> fst) cdt s s';
     equiv_for ((aag_can_read aag) \<circ> fst) cdt_list s s';
     equiv_for (aag_can_read aag) ekheap s s';
     equiv_for ((aag_can_read aag) \<circ> fst) is_original_cap s s'; equiv_for (aag_can_read_irq aag) interrupt_states s s';
     equiv_for (aag_can_read_irq aag) interrupt_irq_node s s';
     equiv_asids (aag_can_read_asid aag) s s';
     equiv_for (aag_can_read_domain aag) ready_queues s s'; cur_thread s = cur_thread s'; cur_domain s = cur_domain s'; scheduler_action s = scheduler_action s'; work_units_completed s = work_units_completed s'; irq_state (machine_state s) = irq_state (machine_state s')\<rbrakk> \<Longrightarrow> R"
  shows "R"
  apply(rule e)
  apply(insert sef)
  apply(auto simp: reads_equiv_def2 elim: states_equiv_forE)
  done

lemma reads_equiv_machine_state_update:
 "\<lbrakk>reads_equiv aag s s'; equiv_machine_state (aag_can_read aag)  kh kh'; irq_state kh = irq_state kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> machine_state := kh \<rparr>) (s'\<lparr> machine_state := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_machine_state_update)
  done

lemma reads_equiv_non_asid_pool_kheap_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for (aag_can_read aag) id kh kh';
    non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> kheap := kh \<rparr>) (s'\<lparr> kheap := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_non_asid_pool_kheap_update)
  done

lemma reads_equiv_identical_kheap_updates:
  "\<lbrakk>reads_equiv aag s s';
    identical_kheap_updates s s' kh kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> kheap := kh \<rparr>) (s'\<lparr> kheap := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_identical_kheap_updates)
  done

lemma reads_equiv_cdt_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for ((aag_can_read aag) \<circ> fst) id kh kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> cdt := kh \<rparr>) (s'\<lparr> cdt := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_cdt_update)
  done

lemma reads_equiv_cdt_list_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for ((aag_can_read aag) \<circ> fst) id (kh (cdt_list s)) (kh' (cdt_list s'))\<rbrakk> \<Longrightarrow>
   reads_equiv aag (cdt_list_update kh s) (cdt_list_update kh' s')"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_cdt_list_update)
  done

lemma reads_equiv_identical_ekheap_updates:
  "\<lbrakk>reads_equiv aag s s'; identical_ekheap_updates s s' (kh (ekheap s)) (kh' (ekheap s'))\<rbrakk> \<Longrightarrow>
   reads_equiv aag (ekheap_update kh s) (ekheap_update kh' s')"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_identical_ekheap_updates)
  done

lemma reads_equiv_ekheap_updates:
  "\<lbrakk>reads_equiv aag s s'; equiv_for (aag_can_read aag) id (kh (ekheap s)) (kh' (ekheap s')) \<rbrakk> \<Longrightarrow>
   reads_equiv aag (ekheap_update kh s) (ekheap_update kh' s')"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_ekheap_update)
  done

lemma reads_equiv_is_original_cap_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for ((aag_can_read aag) \<circ> fst) id kh kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> is_original_cap := kh \<rparr>) (s'\<lparr> is_original_cap := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_is_original_cap_update)
  done

lemma reads_equiv_interrupt_states_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for (aag_can_read_irq aag) id kh kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> interrupt_states := kh \<rparr>) (s'\<lparr> interrupt_states := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_interrupt_states_update)
  done

lemma reads_equiv_interrupt_irq_node_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for (aag_can_read_irq aag) id kh kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> interrupt_irq_node := kh \<rparr>) (s'\<lparr> interrupt_irq_node := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_interrupt_irq_node_update)
  done

lemma reads_equiv_ready_queues_update:
  "\<lbrakk>reads_equiv aag s s'; equiv_for (aag_can_read_domain aag) id kh kh'\<rbrakk> \<Longrightarrow>
   reads_equiv aag (s\<lparr> ready_queues := kh \<rparr>) (s'\<lparr> ready_queues := kh' \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 intro: states_equiv_for_ready_queues_update)
  done

lemma reads_equiv_scheduler_action_update:
  "reads_equiv aag s s' \<Longrightarrow>
   reads_equiv aag (s\<lparr> scheduler_action := kh \<rparr>) (s'\<lparr> scheduler_action := kh \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv)
  done

lemma reads_equiv_work_units_completed_update:
  "reads_equiv aag s s' \<Longrightarrow>
   reads_equiv aag (s\<lparr> work_units_completed := kh \<rparr>) (s'\<lparr> work_units_completed := kh \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv)
  done

lemma reads_equiv_work_units_completed_update':
  "reads_equiv aag s s' \<Longrightarrow>
   reads_equiv aag (s\<lparr> work_units_completed := (f (work_units_completed s)) \<rparr>) (s'\<lparr> work_units_completed := (f (work_units_completed s')) \<rparr>)"
  apply(fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv)
  done

text {*
  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.

  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, Reset}\<rbrakk> \<Longrightarrow>
     l' \<in> subjectAffects g l" |
  (* ipc buffer is not necessary owned by thread *)
  affects_send:
    "\<lbrakk>(l,auth,ep) \<in> g; auth \<in> {SyncSend, Notify}; (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" |
  (* 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,ASIDPoolMapsASID,l') \<in> g \<Longrightarrow> l' \<in> subjectAffects g l" |
  (* if you are sending to an ntfn, which is bound to a tcb that is
     receive blocked on an ep, then you can affect that ep *)
  affects_ep_bound_trans:
    "\<lbrakk>\<exists>tcb ntfn. (tcb, Receive, ntfn) \<in> g \<and> (tcb, Receive, ep) \<in> g \<and>
                (l, Notify, ntfn) \<in> g\<rbrakk> \<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"

lemma aag_can_affect_labelI[intro!]:
  "\<lbrakk>d \<in> subjectAffects (pasPolicy aag) (pasSubject aag); d \<in> subjectReads (pasPolicy aag) l\<rbrakk> \<Longrightarrow> aag_can_affect_label aag l"
  apply(auto simp: aag_can_affect_label_def)
  done

(* 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 (\<lambda> x. pasObjectAbs aag x \<in> subjectReads (pasPolicy aag) l) (\<lambda>x. pasIRQAbs aag x \<in> subjectReads (pasPolicy aag) l) (\<lambda> x. pasASIDAbs aag x \<in> subjectReads (pasPolicy aag) l) (\<lambda>x. pasDomainAbs aag x \<in> subjectReads (pasPolicy aag) l) s s') else True)"

lemma equiv_for_trivial:
  "(\<And> x. P x \<Longrightarrow> False) \<Longrightarrow> equiv_for P f c c'"
  apply(auto simp: equiv_for_def)
  done

lemma equiv_asids_trivial:
  "(\<And> x. P x \<Longrightarrow> False) \<Longrightarrow> equiv_asids P x y"
  apply(auto simp: equiv_asids_def)
  done

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 \<in> subjectReads (pasPolicy aag) l"

lemma affects_equiv_def2:
  "affects_equiv aag l s s' = states_equiv_for (aag_can_affect aag l) (aag_can_affect_irq aag l) (aag_can_affect_asid aag l) (aag_can_affect_domain aag l) s s'"
  apply(clarsimp simp: affects_equiv_def)
  apply(auto intro!: states_equiv_forI equiv_for_trivial equiv_asids_trivial elim: states_equiv_forE)
  done

lemma affects_equivE:
  assumes sef: "affects_equiv aag l s s'"
  assumes e: "\<lbrakk>equiv_for (aag_can_affect aag l) kheap s s';
               equiv_machine_state (aag_can_affect aag l) (machine_state s) (machine_state s');
     equiv_for ((aag_can_affect aag l) \<circ> fst) cdt s s';
     equiv_for ((aag_can_affect aag l) \<circ> fst) cdt_list s s';
     equiv_for (aag_can_affect aag l) ekheap s s';
 equiv_for ((aag_can_affect aag l) \<circ> fst) is_original_cap s s'; equiv_for (aag_can_affect_irq aag l) interrupt_states s s'; equiv_for (aag_can_affect_irq aag l) interrupt_irq_node s s'; equiv_asids (aag_can_affect_asid aag l) s s'; equiv_for (aag_can_affect_domain aag l) ready_queues s s'\<rbrakk> \<Longrightarrow> Z"
  shows "Z"
  apply(rule e)
  apply(insert sef)
  apply(auto simp: affects_equiv_def2 elim: states_equiv_forE)
  done

lemma affects_equiv_machine_state_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_machine_state (aag_can_affect aag l) kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> machine_state := kh \<rparr>) (s'\<lparr> machine_state := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_machine_state_update)
  done

lemma affects_equiv_non_asid_pool_kheap_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for (aag_can_affect aag l) id kh kh';
    non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> kheap := kh \<rparr>) (s'\<lparr> kheap := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_non_asid_pool_kheap_update)
  done

lemma affects_equiv_identical_kheap_updates:
  "\<lbrakk>affects_equiv aag l s s';
    identical_kheap_updates s s' kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> kheap := kh \<rparr>) (s'\<lparr> kheap := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_identical_kheap_updates)
  done

lemma affects_equiv_cdt_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for ((aag_can_affect aag l) \<circ> fst) id kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> cdt := kh \<rparr>) (s'\<lparr> cdt := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_cdt_update)
  done

lemma affects_equiv_cdt_list_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for ((aag_can_affect aag l) \<circ> fst) id (kh (cdt_list s)) (kh' (cdt_list s'))\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (cdt_list_update kh s) (cdt_list_update kh' s')"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_cdt_list_update)
  done

lemma affects_equiv_identical_ekheap_updates:
  "\<lbrakk>affects_equiv aag l s s'; identical_ekheap_updates s s' (kh (ekheap s)) (kh' (ekheap s'))\<rbrakk> \<Longrightarrow>
    affects_equiv aag l (ekheap_update kh s) (ekheap_update kh' s')"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_identical_ekheap_updates)
  done

lemma affects_equiv_ekheap_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for (aag_can_affect aag l) id (kh (ekheap s)) (kh' (ekheap s')) \<rbrakk> \<Longrightarrow>
    affects_equiv aag l (ekheap_update kh s) (ekheap_update kh' s')"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_ekheap_update)
  done

lemma affects_equiv_is_original_cap_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for ((aag_can_affect aag l) \<circ> fst) id kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> is_original_cap := kh \<rparr>) (s'\<lparr> is_original_cap := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_is_original_cap_update)
  done

lemma affects_equiv_interrupt_states_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for (aag_can_affect_irq aag l) id kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> interrupt_states := kh \<rparr>) (s'\<lparr> interrupt_states := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_interrupt_states_update)
  done

lemma affects_equiv_interrupt_irq_node_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for (aag_can_affect_irq aag l) id kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> interrupt_irq_node := kh \<rparr>) (s'\<lparr> interrupt_irq_node := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_interrupt_irq_node_update)
  done

lemma affects_equiv_ready_queues_update:
  "\<lbrakk>affects_equiv aag l s s'; equiv_for (aag_can_affect_domain aag l) id kh kh'\<rbrakk> \<Longrightarrow>
   affects_equiv aag l (s\<lparr> ready_queues := kh \<rparr>) (s'\<lparr> ready_queues := kh' \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 intro: states_equiv_for_ready_queues_update)
  done

lemma affects_equiv_scheduler_action_update:
  "affects_equiv aag l s s' \<Longrightarrow>
   affects_equiv aag l (s\<lparr> scheduler_action := kh \<rparr>) (s'\<lparr> scheduler_action := kh \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv)
  done

lemma affects_equiv_work_units_completed_update:
  "affects_equiv aag l s s' \<Longrightarrow>
   affects_equiv aag l (s\<lparr> work_units_completed := kh \<rparr>) (s'\<lparr> work_units_completed := kh \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv)
  done

lemma affects_equiv_work_units_completed_update':
  "affects_equiv aag l s s' \<Longrightarrow>
   affects_equiv aag l (s\<lparr> work_units_completed := (f (work_units_completed s)) \<rparr>) (s'\<lparr> work_units_completed := (f (work_units_completed s')) \<rparr>)"
  apply(fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv)
  done

(* reads_equiv and affects_equiv want to be equivalence relations *)
lemma reads_equiv_refl:
  "reads_equiv aag s s"
  by(auto simp: reads_equiv_def2 intro: states_equiv_for_refl equiv_asids_refl)

lemma reads_equiv_sym:
  "reads_equiv aag s t \<Longrightarrow> reads_equiv aag t s"
  by(auto simp: reads_equiv_def2 intro: states_equiv_for_sym equiv_asids_sym)

lemma reads_equiv_trans:
  "\<lbrakk>reads_equiv aag s t; reads_equiv aag t u\<rbrakk> \<Longrightarrow>
   reads_equiv aag s u"
  by(auto simp: reads_equiv_def2 intro: states_equiv_for_trans equiv_asids_trans)

lemma affects_equiv_refl:
  "affects_equiv aag l s s"
  by(auto simp: affects_equiv_def intro: states_equiv_for_refl equiv_asids_refl)

lemma affects_equiv_sym:
  "affects_equiv aag l s t \<Longrightarrow> affects_equiv aag l t s"
  by(auto simp: affects_equiv_def2 intro: states_equiv_for_sym equiv_asids_sym)

lemma affects_equiv_trans:
  "\<lbrakk>affects_equiv aag l s t; affects_equiv aag l t u\<rbrakk> \<Longrightarrow>
   affects_equiv aag l s u"
  by(auto simp: affects_equiv_def2 intro: states_equiv_for_trans equiv_asids_trans)

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. P s \<longrightarrow> (\<forall>(rv,s')\<in>fst (f s). globals_equiv s s')"

lemma globals_equivI:
  "\<lbrakk>doesnt_touch_globals P f; P s; (rv,s')\<in>fst(f s)\<rbrakk> \<Longrightarrow> globals_equiv s s'"
  by(fastforce simp: doesnt_touch_globals_def)

lemma reads_equiv_gD:
  "reads_equiv_g aag s s' \<Longrightarrow> reads_equiv aag s s' \<and> globals_equiv s s'"
  by(simp add: reads_equiv_g_def)

lemma reads_equiv_gI:
  "\<lbrakk>reads_equiv aag s s'; globals_equiv s s'\<rbrakk> \<Longrightarrow> reads_equiv_g aag s s'"
  by(simp add: reads_equiv_g_def)

lemma globals_equiv_refl:
  "globals_equiv s s"
  by(simp add: globals_equiv_def idle_equiv_refl)

lemma globals_equiv_sym:
  "globals_equiv s t \<Longrightarrow> globals_equiv t s"
  by(auto simp: globals_equiv_def idle_equiv_def)

lemma globals_equiv_trans:
  "\<lbrakk>globals_equiv s t; globals_equiv t u\<rbrakk> \<Longrightarrow> globals_equiv s u"
  apply (auto simp: globals_equiv_def)
  apply (metis idle_equiv_trans idle_equiv_def)+
  done

(* since doesnt_touch_globals is true for all of the kernel except the scheduler,
   the following lemma shows that we can just prove reads_respects for it, and
   from there get the stronger reads_respects_g result that we need for the
   noninterference theorem *)
lemma reads_respects_g:
  "\<lbrakk>reads_respects aag l P f; doesnt_touch_globals Q f\<rbrakk> \<Longrightarrow>
   reads_respects_g aag l (P and Q) f"
  apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def)
  apply(drule reads_equiv_gD)
  apply(subgoal_tac "globals_equiv b ba", fastforce intro: reads_equiv_gI)
  apply(rule globals_equiv_trans)
   apply(rule globals_equiv_sym)
   apply(fastforce intro: globals_equivI)
  apply(rule globals_equiv_trans)
   apply(elim conjE, assumption)
  apply(fastforce intro: globals_equivI)
  done

(* prove doesnt_touch_globals as an invariant *)
lemma globals_equiv_invD:
  "\<lbrace> globals_equiv st and P \<rbrace> f \<lbrace> \<lambda>_. globals_equiv st \<rbrace> \<Longrightarrow>
  \<lbrace> P and op = st \<rbrace> f \<lbrace> \<lambda>_. globals_equiv st \<rbrace>"
  apply(fastforce simp: valid_def intro: globals_equiv_refl)
  done

lemma doesnt_touch_globalsI:
  assumes globals_equiv_inv:
    "\<And> st. \<lbrace> globals_equiv st and P \<rbrace> f \<lbrace> \<lambda>_. globals_equiv st \<rbrace>"
  shows "doesnt_touch_globals P f"
  apply(clarsimp simp: doesnt_touch_globals_def)
  apply(cut_tac st=s in globals_equiv_inv)
  apply(drule globals_equiv_invD)
  by(fastforce simp: valid_def)

(* Slightly nicer to use version to lift up trivial cases*)
lemma reads_respects_g_from_inv:
  "\<lbrakk>reads_respects aag l P f; \<And>st. invariant f (globals_equiv st)\<rbrakk> \<Longrightarrow>
  reads_respects_g aag l P f"
  apply (rule equiv_valid_guard_imp)
   apply (erule reads_respects_g[where Q="\<lambda>s. True"])
   apply (rule doesnt_touch_globalsI)
   apply simp+
  done

(*Useful for chaining OFs so we don't have to re-state rules*)
lemma reads_respects_g':
  assumes rev: "reads_respects aag l P f"
  assumes gev: "\<And>st. \<lbrace>\<lambda> s. R (globals_equiv st s) s\<rbrace> f \<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
  assumes and_imp: "\<And> st s. Q st s \<Longrightarrow> P s \<and> R (globals_equiv st s) s"
  assumes gev_imp: "\<And> st s. R (globals_equiv st s) s \<Longrightarrow> globals_equiv st s"
  shows
   "reads_respects_g aag l (Q st) f"
  apply (rule equiv_valid_guard_imp)
   apply (rule reads_respects_g[OF rev, where Q="\<lambda>s. R (globals_equiv st s) s"])
   apply (rule doesnt_touch_globalsI)
   apply (rule hoare_pre)
    apply (rule gev)
   apply clarsimp
   apply (frule gev_imp)
   apply (simp add: and_imp)+
  done

lemma equiv_for_guard_imp:
  "\<lbrakk>equiv_for P f s s'; \<And> x. Q x \<Longrightarrow> P x\<rbrakk> \<Longrightarrow> equiv_for Q f s s'"
  by(auto simp: equiv_for_def)

lemma equiv_asids_guard_imp:
  "\<lbrakk>equiv_asids R s s'; \<And> x. Q x \<Longrightarrow> R x\<rbrakk> \<Longrightarrow>  equiv_asids Q s s'"
  by(auto simp: equiv_asids_def)

lemma states_equiv_for_guard_imp:
  "\<lbrakk>states_equiv_for P Q R S s s'; \<And> x. P' x \<Longrightarrow> P x; \<And> x. Q' x \<Longrightarrow> Q x; \<And> x. R' x \<Longrightarrow> R x; \<And> x. S' x \<Longrightarrow> S x\<rbrakk> \<Longrightarrow> states_equiv_for P' Q' R' S' s s'"
  by(auto simp: states_equiv_for_def intro: equiv_for_guard_imp equiv_asids_guard_imp)

lemma cur_subject_reads_equiv_affects_equiv:
  "pasSubject aag = l \<Longrightarrow>
   reads_equiv aag s s' \<Longrightarrow> affects_equiv aag l s s'"
  apply(clarsimp simp: reads_equiv_def2 affects_equiv_def simp: states_equiv_for_def)
  done

(* This lemma says that, if we prove reads_respects above for all l, we will
   prove that information can flow into the domain only from what it is allowed
   to read. *)
lemma reads_equiv_self_reads_respects:
  "pasSubject aag = l \<Longrightarrow>
   reads_equiv_valid_inv \<top>\<top> aag P f = reads_respects aag l P f"
  unfolding equiv_valid_def2 equiv_valid_2_def
  apply(fastforce intro: cur_subject_reads_equiv_affects_equiv)
  done

lemma requiv_get_tcb_eq[intro]:
  "\<lbrakk>reads_equiv aag s t; is_subject aag thread\<rbrakk> \<Longrightarrow> get_tcb thread s = get_tcb thread t"
  apply(auto simp: reads_equiv_def2 elim: states_equiv_forE_kheap dest!: aag_can_read_self simp: get_tcb_def split: option.split kernel_object.split)
  done

lemma requiv_cur_thread_eq[intro]:
  "reads_equiv aag s t \<Longrightarrow> cur_thread s = cur_thread t"
  apply (simp add: reads_equiv_def2)
  done

lemma requiv_cur_domain_eq[intro]:
  "reads_equiv aag s t \<Longrightarrow> cur_domain s = cur_domain t"
  apply (simp add: reads_equiv_def2)
  done

lemma requiv_sched_act_eq[intro]:
  "reads_equiv aag s t \<Longrightarrow> scheduler_action s = scheduler_action t"
  apply (simp add: reads_equiv_def2)
  done

lemma requiv_wuc_eq[intro]:
  "reads_equiv aag s t \<Longrightarrow> work_units_completed s = work_units_completed t"
  apply (simp add: reads_equiv_def2)
  done

lemma set_object_reads_respects:
  "reads_respects aag l \<top> (set_object ptr obj)"
  unfolding equiv_valid_def2 equiv_valid_2_def
  apply(clarsimp simp: set_object_def bind_def get_def put_def return_def)
  apply(fastforce intro: reads_equiv_identical_kheap_updates affects_equiv_identical_kheap_updates simp: identical_kheap_updates_def)
  done

lemma update_object_noop:
  "kheap s ptr = Some obj \<Longrightarrow> s\<lparr>kheap := kheap s(ptr \<mapsto> obj)\<rparr> = s"
  apply(subgoal_tac "kheap s(ptr \<mapsto> obj) = kheap s")
   apply(simp)
  apply(blast intro: map_upd_triv)
  done

lemma set_object_rev:
  "reads_equiv_valid_inv A aag (\<lambda> s. kheap s ptr = Some obj \<and> is_subject aag ptr) (set_object ptr obj)"
  unfolding equiv_valid_def2 equiv_valid_2_def
  apply(clarsimp simp: set_object_def bind_def get_def put_def return_def)
  apply(fastforce dest: update_object_noop)
  done

lemma lookup_error_on_failure_rev:
  "reads_equiv_valid_inv A aag P m \<Longrightarrow>
   reads_equiv_valid_inv A aag P (lookup_error_on_failure s m)"
  unfolding lookup_error_on_failure_def
  apply(unfold handleE'_def)
  apply (wp | wpc | simp)+
  done

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"

lemma gets_kheap_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for (aag_can_read aag or aag_can_affect aag l) id) \<top> (gets kheap)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE affects_equivE)
  done

lemma gets_kheap_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_for (aag_can_read aag) id) \<top> (gets kheap)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE)
  done

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

lemma gets_machine_state_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_machine_state (aag_can_read aag or aag_can_affect aag l) And equiv_irq_state) \<top> (gets machine_state)"
  apply(simp add: gets_def get_def return_def bind_def)
  apply(clarsimp simp: equiv_valid_2_def)
  apply(fastforce intro: equiv_forI elim: reads_equivE affects_equivE equiv_forE)
  done

lemma gets_machine_state_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_machine_state (aag_can_read aag) And equiv_irq_state) \<top> (gets machine_state)"
  apply(simp add: gets_def get_def return_def bind_def)
  apply(clarsimp simp: equiv_valid_2_def)
  apply(fastforce intro: equiv_forI elim: reads_equivE affects_equivE equiv_forE)
  done

lemma gets_cdt_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for ((aag_can_read aag or aag_can_affect aag l) \<circ> fst) id) \<top> (gets cdt)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE affects_equivE)
  done

lemma gets_cdt_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_for (aag_can_read aag \<circ> fst) id) \<top> (gets cdt)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE)
  done

lemma internal_exst[simp]:"cdt_list_internal o exst = cdt_list"
                           "ekheap_internal o exst = ekheap"
  apply (simp add: o_def)+
  done

lemma gets_cdt_list_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for ((aag_can_read aag or aag_can_affect aag l) \<circ> fst) id) \<top> (gets cdt_list)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE affects_equivE)
  done

lemma gets_cdt_list_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_for (aag_can_read aag \<circ> fst) id) \<top> (gets cdt_list)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE)
  done

lemma gets_ekheap_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for (aag_can_read aag or aag_can_affect aag l) id) \<top> (gets ekheap)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE affects_equivE)
  done

lemma gets_ekheap_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_for (aag_can_read aag) id) \<top> (gets kheap)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE)
  done

lemma gets_is_original_cap_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for ((aag_can_read aag or aag_can_affect aag l) \<circ> fst) id) \<top> (gets is_original_cap)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE affects_equivE)
  done

lemma gets_is_original_cap_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_for (aag_can_read aag \<circ> fst) id) \<top> (gets is_original_cap)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist elim: reads_equivE)
  done

lemma gets_ready_queues_revrv:
  "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for (aag_can_read_domain aag or aag_can_affect_domain aag l) id) \<top> (gets ready_queues)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist equiv_for_def elim: reads_equivE affects_equivE)
  done

lemma gets_ready_queues_revrv':
  "reads_equiv_valid_rv_inv A aag (equiv_for (aag_can_read_domain aag) id) \<top> (gets ready_queues)"
  apply(rule equiv_valid_rv_guard_imp)
   apply(rule gets_evrv)
  apply(fastforce simp: equiv_for_comp[symmetric] equiv_for_or or_comp_dist equiv_for_def elim: reads_equivE)
  done

(* We want to prove this kind of thing for functions that don't modify the
   state *)
lemma gets_cur_thread_ev:
  "reads_equiv_valid_inv A aag \<top> (gets cur_thread)"
  apply (rule equiv_valid_guard_imp)
  apply wp
  apply (simp add: reads_equiv_def)
  done

lemma as_user_rev:
  "reads_equiv_valid_inv A aag (K (det f \<and> (\<forall>P. invariant f P) \<and> is_subject aag thread)) (as_user thread f)"
  unfolding as_user_def fun_app_def split_def
  apply (wp set_object_rev select_f_ev)
  apply (rule conjI, fastforce)
  apply (clarsimp split: option.split_asm kernel_object.split_asm simp: get_tcb_def)
  apply (drule state_unchanged[rotated,symmetric])
   apply simp_all
  done

lemma as_user_reads_respects:
  "reads_respects aag l (K (det f \<and> is_subject aag thread)) (as_user thread f)"
  apply (simp add: as_user_def split_def)
  apply (rule gen_asm_ev)
  apply (wp set_object_reads_respects select_f_ev gets_the_ev)
  apply fastforce
  done

lemma get_message_info_rev:
  "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_message_info ptr)"
  apply (simp add: get_message_info_def)
  apply (wp as_user_rev | clarsimp simp: get_register_def)+
  done

lemma syscall_rev:
  assumes reads_res_m_fault:
    "reads_equiv_valid_inv A aag P m_fault"
  assumes reads_res_m_error:
    "\<And> v. reads_equiv_valid_inv A aag (Q (Inr v)) (m_error v)"
  assumes reads_res_h_fault:
    "\<And> v. reads_equiv_valid_inv A aag (Q (Inl v)) (h_fault v)"
  assumes reads_res_m_finalise:
    "\<And> v. reads_equiv_valid_inv A aag (R (Inr v)) (m_finalise v)"
  assumes reads_res_h_error:
    "\<And> v. reads_equiv_valid_inv A aag (R (Inl v)) (h_error v)"
  assumes m_fault_hoare:
    "\<lbrace> P \<rbrace> m_fault \<lbrace> Q \<rbrace>"
  assumes m_error_hoare:
    "\<And> v. \<lbrace> Q (Inr v) \<rbrace> m_error v \<lbrace> R \<rbrace>"
  shows "reads_equiv_valid_inv A aag P (Syscall_A.syscall m_fault h_fault m_error h_error m_finalise)"
  unfolding Syscall_A.syscall_def without_preemption_def fun_app_def
  apply (wp assms equiv_valid_guard_imp[OF liftE_bindE_ev]
       | rule hoare_strengthen_post[OF m_error_hoare]
       | rule hoare_strengthen_post[OF m_fault_hoare]
       | wpc
       | fastforce)+
  done

lemma syscall_reads_respects_g:
  assumes reads_res_m_fault:
    "reads_respects_g aag l P m_fault"
  assumes reads_res_m_error:
    "\<And> v. reads_respects_g aag l (Q'' v) (m_error v)"
  assumes reads_res_h_fault:
    "\<And> v. reads_respects_g aag l (Q' v) (h_fault v)"
  assumes reads_res_m_finalise:
    "\<And> v. reads_respects_g aag l (R'' v) (m_finalise v)"
  assumes reads_res_h_error:
    "\<And> v. reads_respects_g aag l (R' v) (h_error v)"
  assumes m_fault_hoare:
    "\<lbrace> P \<rbrace> m_fault \<lbrace> case_sum Q' Q'' \<rbrace>"
  assumes m_error_hoare:
    "\<And> v. \<lbrace> Q'' v \<rbrace> m_error v \<lbrace> case_sum R' R'' \<rbrace>"
  shows "reads_respects_g aag l P (Syscall_A.syscall m_fault h_fault m_error h_error m_finalise)"
  unfolding Syscall_A.syscall_def without_preemption_def fun_app_def
  apply (wp assms equiv_valid_guard_imp[OF liftE_bindE_ev]
       | rule hoare_strengthen_post[OF m_error_hoare]
       | rule hoare_strengthen_post[OF m_fault_hoare]
       | wpc
       | fastforce)+
  done

lemma do_machine_op_spec_reads_respects':
  assumes equiv_dmo:
   "equiv_valid_inv (equiv_machine_state (aag_can_read aag) And equiv_irq_state)  (equiv_machine_state (aag_can_affect aag l) ) \<top> f"
  shows
  "spec_reads_respects st aag l \<top> (do_machine_op f)"
  unfolding do_machine_op_def spec_equiv_valid_def
  apply(rule equiv_valid_2_guard_imp)
   apply(rule_tac  R'="\<lambda> rv rv'.
     equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv'
     \<and> equiv_irq_state rv rv'" and Q="\<lambda> r s. st = s" and Q'="\<top>\<top>" and P="op = st" and P'="\<top>" in equiv_valid_2_bind)
       apply(rule_tac R'="\<lambda> (r, ms') (r', ms'').  r = r'
         \<and> equiv_machine_state (aag_can_read aag)  ms' ms''
         \<and> equiv_machine_state (aag_can_affect aag l)  ms' ms''
         \<and> equiv_irq_state ms' ms''" and Q="\<lambda> r s. st = s" and Q'="\<top>\<top>" and P="\<top>" and P'="\<top>" in equiv_valid_2_bind_pre)
            apply(clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def)
            apply(fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update)
            apply(insert equiv_dmo)[1]
           apply(clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or simp: split_def split: prod.splits simp: equiv_for_def)[1]
           apply(drule_tac x=rv in spec, drule_tac x=rv' in spec)
           apply(fastforce)
          apply(rule select_f_inv)
         apply(rule wp_post_taut)
        apply simp+
      apply(clarsimp simp: equiv_valid_2_def in_monad)
      apply(fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI)
     apply(wp | simp)+
  done

(* most of the time (i.e. always except for getActiveIRQ) you'll want this rule *)
lemma do_machine_op_spec_reads_respects:
  assumes equiv_dmo:
   "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) (equiv_machine_state (aag_can_affect aag l)) \<top> f"
  assumes irq_state_inv:
    "\<And>P. \<lbrace>\<lambda>ms. P (irq_state ms)\<rbrace> f \<lbrace>\<lambda>_ ms. P (irq_state ms)\<rbrace>"
  shows
  "spec_reads_respects st aag l \<top> (do_machine_op f)"
  apply(rule do_machine_op_spec_reads_respects')
  apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def)
  apply(subgoal_tac "equiv_irq_state b ba", simp)
   apply(insert equiv_dmo, fastforce simp: equiv_valid_def2 equiv_valid_2_def)
  apply(insert irq_state_inv)
  apply(drule_tac x="\<lambda>ms. ms = irq_state s" in meta_spec)
  apply(clarsimp simp: valid_def)
  apply(frule_tac x=s in spec)
  apply(erule (1) impE)
  apply(drule bspec, assumption, simp)
  apply(drule_tac x=t in spec, simp)
  apply(drule bspec, assumption)
  apply simp
  done

lemma do_machine_op_spec_rev:
  assumes equiv_dmo:
   "spec_equiv_valid_inv (machine_state st) (equiv_machine_state (aag_can_read aag)) \<top>\<top> \<top> f"
  assumes mo_inv: "\<And> P. invariant f P"
  shows
  "reads_spec_equiv_valid_inv st A aag P (do_machine_op f)"
  unfolding do_machine_op_def spec_equiv_valid_def
  apply(rule equiv_valid_2_guard_imp)
   apply(rule_tac  R'="\<lambda> rv rv'. equiv_machine_state (aag_can_read aag) rv rv' \<and> equiv_irq_state rv rv'" and Q="\<lambda> r s. st = s \<and> r = machine_state s" and Q'="\<lambda>r s. r = machine_state s" and P="op = st" and P'="\<top>" in equiv_valid_2_bind)
       apply(rule_tac R'="\<lambda> (r, ms') (r', ms'').  r = r' \<and> equiv_machine_state (aag_can_read aag) ms' ms''"
                  and Q="\<lambda> (r,ms') s. ms' = rv \<and> rv = machine_state s \<and> st = s"
                  and Q'="\<lambda> (r,ms') s. ms' = rv' \<and> rv' = machine_state s"
                  and P="\<lambda> s. st = s \<and> rv = machine_state s" and P'="\<lambda> s. rv' = machine_state s"
                  and S="\<lambda> s. st = s \<and> rv = machine_state s" and S'="\<lambda>s. rv' = machine_state s" in equiv_valid_2_bind_pre)

            apply(clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def)
           apply(clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or simp: split_def split: prod.splits simp: equiv_for_def)[1]
           apply(insert equiv_dmo)[1]
           apply(clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
           apply(drule_tac x="machine_state t" in spec)
           apply(clarsimp simp: equiv_for_def)
           apply blast
          apply(wp select_f_inv)
          apply clarsimp
          apply(drule state_unchanged[OF mo_inv], simp)
         apply(wp select_f_inv)
         apply clarsimp
         apply(drule state_unchanged[OF mo_inv], simp)
        apply simp+
      apply(clarsimp simp: equiv_valid_2_def in_monad)
      apply(fastforce intro: elim: equiv_forE reads_equivE)
     apply(wp | simp)+
  done

lemma do_machine_op_rev:
  assumes equiv_dmo: "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) \<top>\<top> \<top> f"
  assumes mo_inv: "\<And> P. invariant f P"
  shows "reads_equiv_valid_inv A aag \<top> (do_machine_op f)"
  unfolding do_machine_op_def equiv_valid_def2
  apply(rule_tac W="\<lambda> rv rv'. equiv_machine_state (aag_can_read aag) rv rv' \<and> equiv_irq_state rv rv'" and Q="\<lambda> rv s. rv = machine_state s " in equiv_valid_rv_bind)
    apply(blast intro: equiv_valid_rv_guard_imp[OF gets_machine_state_revrv'[simplified bipred_conj_def]])
   apply(rule_tac R'="\<lambda> (r, ms') (r', ms'').  r = r' \<and> equiv_machine_state (aag_can_read aag) ms' ms''" and Q="\<lambda> (r,ms') s. ms' = rv \<and> rv = machine_state s " and Q'="\<lambda> (r',ms'') s. ms'' = rv' \<and> rv' = machine_state s" and P="\<top>" and P'="\<top>" in equiv_valid_2_bind_pre)
        apply(clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def)
       apply(clarsimp simp: select_f_def equiv_valid_2_def)
       apply(insert equiv_dmo, clarsimp simp: equiv_valid_def2 equiv_valid_2_def)[1]
       apply(blast)
    apply(wp select_f_inv)+
    apply(fastforce simp: select_f_def dest: state_unchanged[OF mo_inv])+
  done

definition
  for_each_byte_of_word :: "(word32 \<Rightarrow> bool) \<Rightarrow> word32 \<Rightarrow> bool"
where
  "for_each_byte_of_word P w \<equiv> \<forall> y\<in>{w..w + 3}. P y"

lemma spec_equiv_valid_hoist_guard:
  "((P st) \<Longrightarrow> spec_equiv_valid_inv st I A \<top> f) \<Longrightarrow> spec_equiv_valid_inv st I A P f"
  apply(clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
  done

lemma dmo_loadWord_rev:
  "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p))
     (do_machine_op (loadWord p))"
  apply(rule gen_asm_ev)
  apply(rule use_spec_ev)
  apply(rule spec_equiv_valid_hoist_guard)
  apply(rule do_machine_op_spec_rev)
  apply(simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def)
  apply(rule_tac R'="\<lambda> rv rv'. for_each_byte_of_word (\<lambda> y. rv y = rv' y) p" and Q="\<top>\<top>" and Q'="\<top>\<top>" and P="\<top>" and P'="\<top>" in equiv_valid_2_bind_pre)
       apply(rule_tac R'="op =" and Q="\<lambda> r s. p && mask 2 = 0" and Q'="\<lambda> r s. p && mask 2 = 0" and P="\<top>" and P'="\<top>" in equiv_valid_2_bind_pre)
            apply(rule return_ev2)
            apply(rule_tac f="word_rcat" in arg_cong)
            apply(fastforce intro: is_aligned_no_wrap' word_plus_mono_right simp: is_aligned_mask for_each_byte_of_word_def) (* slow *)
           apply(rule assert_ev2[OF refl])
          apply(rule assert_wp)+
        apply simp+
       apply(clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def)
       apply(erule equiv_forD)
       apply fastforce
      apply(clarsimp simp: ptr_range_def add.commute)
     apply (wp wp_post_taut loadWord_inv | simp)+
  done

lemma for_each_byte_of_word_imp:
  "(\<And> x. P x \<Longrightarrow> Q x) \<Longrightarrow>
   for_each_byte_of_word P p \<Longrightarrow> for_each_byte_of_word Q p"
  apply(fastforce simp: for_each_byte_of_word_def)
  done

lemma load_word_offs_rev:
  "\<lbrakk>for_each_byte_of_word (aag_can_read aag) (a + of_nat x * of_nat word_size)\<rbrakk> \<Longrightarrow>
  reads_equiv_valid_inv A aag \<top> (load_word_offs a x)"
  unfolding load_word_offs_def fun_app_def
  apply(rule equiv_valid_guard_imp[OF dmo_loadWord_rev])
  apply(clarsimp)
  done

(* FIXME: move *)
lemma msg_max_length_less_msg_align_bits:
  "msg_max_length < 2 ^ (msg_align_bits - 2)"
  apply(rule nat_power_less_diff)
  apply(simp add: msg_align_bits_def)
  apply(simp add: cap_transfer_data_size_def msg_max_extra_caps_def)
  apply(rule_tac a=7 in LeastI2)
   apply(clarsimp simp: msg_max_length_def)
  apply simp
  done

(* FIXME: move *)
lemma less_2_pow_msg_align_bits_sub_2:
  "x = msg_max_length \<or> x < msg_max_length \<Longrightarrow>
       x < 2 ^ (msg_align_bits - 2)"
  apply(erule disjE)
   apply(erule ssubst)
   apply(rule msg_max_length_less_msg_align_bits)
  apply(erule less_trans[OF _ msg_max_length_less_msg_align_bits])
  done

(* generalises auth_ipc_buffers_mem_Write *)
lemma auth_ipc_buffers_mem_Write':
  "\<lbrakk> x \<in> auth_ipc_buffers s thread; pas_refined aag s; valid_objs s\<rbrakk>
  \<Longrightarrow> (pasObjectAbs aag thread, Write, pasObjectAbs aag x) \<in> pasPolicy aag"
  apply (clarsimp simp add: auth_ipc_buffers_member_def)
  apply (drule (1) cap_auth_caps_of_state)
    apply simp
  apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def
                        vspace_cap_rights_to_auth_def vm_read_write_def
                        is_page_cap_def
                 split: if_split_asm)
   apply (auto dest: ipcframe_subset_page)
  done

(*
   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.
*)
definition equiv_but_for_labels where
  "equiv_but_for_labels aag L s s' \<equiv> states_equiv_for (\<lambda> x. pasObjectAbs aag x \<notin> L) (\<lambda> x. pasIRQAbs aag x \<notin> L) (\<lambda> x. pasASIDAbs aag x \<notin> L) (\<lambda> x. pasDomainAbs aag x \<notin> 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 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')"

lemma modifies_at_mostD:
  "\<lbrakk>modifies_at_most aag L P f; P s; (rv,s') \<in> fst(f s)\<rbrakk> \<Longrightarrow>
   equiv_but_for_labels aag L s s'"
  by(auto simp: modifies_at_most_def)

lemma modifies_at_mostI:
  assumes hoare: "\<And> st. \<lbrace> P and equiv_but_for_labels aag L st \<rbrace> f \<lbrace> \<lambda>_. equiv_but_for_labels aag L st \<rbrace>"
  shows "modifies_at_most aag L P f"
  apply(clarsimp simp: modifies_at_most_def)
  apply(erule use_valid)
   apply(rule hoare)
  apply(fastforce simp: equiv_but_for_labels_def states_equiv_for_refl)
  done

(*FIXME: Move*)
lemma invs_kernel_mappings:
  "invs s \<Longrightarrow> valid_kernel_mappings s"
  by (auto simp: invs_def valid_state_def)

end

end