(* This work was done by Denis Lohner (denis.lohner@kit.edu). *)

chapter \<open>A Control Flow Graph for Jinja Byte Code\<close>

section \<open>Formalizing the CFG\<close>

theory JVMCFG imports "../Basic/BasicDefs" Jinja.BVExample begin

declare lesub_list_impl_same_size [simp del]
declare listE_length [simp del]

subsection \<open>Type definitions\<close>

subsubsection \<open>Wellformed Programs\<close>

definition "wf_jvmprog = {(P, Phi). wf_jvm_prog\<^bsub>Phi\<^esub> P}"

typedef wf_jvmprog = wf_jvmprog
proof
  show "(E, Phi) \<in> wf_jvmprog"
    unfolding wf_jvmprog_def by (auto intro: wf_prog)
qed

hide_const Phi E

abbreviation rep_jvmprog_jvm_prog :: "wf_jvmprog \<Rightarrow> jvm_prog"
("_\<^bsub>wf\<^esub>")
  where "P\<^bsub>wf\<^esub> \<equiv> fst(Rep_wf_jvmprog(P))"

abbreviation rep_jvmprog_phi :: "wf_jvmprog \<Rightarrow> ty\<^sub>P"
("_\<^bsub>\<Phi>\<^esub>")
  where "P\<^bsub>\<Phi>\<^esub> \<equiv> snd(Rep_wf_jvmprog(P))"

lemma wf_jvmprog_is_wf: "wf_jvm_prog\<^bsub>P\<^bsub>\<Phi>\<^esub>\<^esub> (P\<^bsub>wf\<^esub>)"
using Rep_wf_jvmprog [of P]
  by (auto simp: wf_jvmprog_def split_beta)

subsubsection \<open>Basic Types\<close>

text \<open>
We consider a program to be a well-formed Jinja program,
together with a given base class and a main method
\<close>

type_synonym jvmprog = "wf_jvmprog \<times> cname \<times> mname"
type_synonym callstack = "(cname \<times> mname \<times> pc) list"

text \<open>
The state is modeled as $\textrm{heap} \times \textrm{stack-variables} \times \textrm{local-variables}$

stack and local variables are modeled as pairs of natural numbers. The first number
gives the position in the call stack (i.e. the method in which the variable is used),
the second the position in the method's stack or array of local variables resp.

The stack variables are numbered from bottom up (which is the reverse order of the
array for the stack in Jinja's state representation), whereas local variables are identified
by their position in the array of local variables of Jinja's state representation.
\<close>

type_synonym state = "heap \<times> ((nat \<times> nat) \<Rightarrow> val) \<times> ((nat \<times> nat) \<Rightarrow> val)"

abbreviation heap_of :: "state \<Rightarrow> heap"
where
  "heap_of s \<equiv> fst(s)"

abbreviation stk_of :: "state \<Rightarrow> ((nat \<times> nat) \<Rightarrow> val)"
where
  "stk_of s \<equiv> fst(snd(s))"

abbreviation loc_of :: "state \<Rightarrow> ((nat \<times> nat) \<Rightarrow> val)"
where
  "loc_of s \<equiv> snd(snd(s))"

subsection \<open>Basic Definitions\<close>

subsubsection \<open>State update (instruction execution)\<close>

text \<open>
This function models instruction execution for our state representation.

Additional parameters are the call depth of the current program point,
the stack length of the current program point,
the length of the stack in the underlying call frame (needed for {\sc Return}),
and (for {\sc Invoke}) the length of the array of local variables of the invoked method.

Exception handling is not covered by this function.
\<close>

fun exec_instr :: "instr \<Rightarrow> wf_jvmprog \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state"
where
  exec_instr_Load:
  "exec_instr (Load n) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s
   in (h, stk((calldepth,stk_length):=loc(calldepth,n)), loc))"

| exec_instr_Store:
  "exec_instr (Store n) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s
   in (h, stk, loc((calldepth,n):=stk(calldepth,stk_length - 1))))"

| exec_instr_Push:
  "exec_instr (Push v) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s
   in (h, stk((calldepth,stk_length):=v), loc))"

| exec_instr_New:
  "exec_instr (New C) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s;
    a = the(new_Addr h)
   in (h(a \<mapsto> (blank (P\<^bsub>wf\<^esub>) C)), stk((calldepth,stk_length):=Addr a), loc))"

| exec_instr_Getfield:
  "exec_instr (Getfield F C) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s;
    a = the_Addr (stk (calldepth,stk_length - 1));
    (D,fs) = the(h a)
   in (h, stk((calldepth,stk_length - 1) := the(fs(F,C))), loc))"

| exec_instr_Putfield:
  "exec_instr (Putfield F C) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s;
    v = stk (calldepth,stk_length - 1);
    a = the_Addr (stk (calldepth,stk_length - 2));
    (D,fs) = the(h a)
   in (h(a \<mapsto> (D,fs((F,C) \<mapsto> v))), stk, loc))"

| exec_instr_Checkcast:
  "exec_instr (Checkcast C) P s calldepth stk_length rs ill = s"

| exec_instr_Pop:
  "exec_instr (Pop) P s calldepth stk_length rs ill = s"

| exec_instr_IAdd:
  "exec_instr (IAdd) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s;
    i\<^sub>1 = the_Intg (stk (calldepth, stk_length - 1));
    i\<^sub>2 = the_Intg (stk (calldepth, stk_length - 2))
   in (h, stk((calldepth, stk_length - 2) := Intg (i\<^sub>1 + i\<^sub>2)), loc))"

| exec_instr_IfFalse:
  "exec_instr (IfFalse b) P s calldepth stk_length rs ill = s"

| exec_instr_CmpEq:
  "exec_instr (CmpEq) P s calldepth stk_length rs ill =
  (let (h,stk,loc) = s;
    v\<^sub>1 = stk (calldepth, stk_length - 1);
    v\<^sub>2 = stk (calldepth, stk_length - 2)
   in (h, stk((calldepth, stk_length - 2) := Bool (v\<^sub>1 = v\<^sub>2)), loc))"

| exec_instr_Goto:
  "exec_instr (Goto i) P s calldepth stk_length rs ill = s"

| exec_instr_Throw:
  "exec_instr (Throw) P s calldepth stk_length rs ill = s"

| exec_instr_Invoke:
  "exec_instr (Invoke M n) P s calldepth stk_length rs invoke_loc_length =
  (let (h,stk,loc) = s;
    loc' = (\<lambda>(a,b). if (a \<noteq> Suc calldepth \<or> b \<ge> invoke_loc_length) then loc(a,b) else
                      (if (b \<le> n) then stk(calldepth, stk_length - (Suc n - b)) else arbitrary))
   in (h,stk,loc'))"

| exec_instr_Return:
  "exec_instr (Return) P s calldepth stk_length ret_stk_length ill =
  (if (calldepth = 0)
    then s
    else
    (let (h,stk,loc) = s;
      v = stk(calldepth, stk_length - 1)
     in (h,stk((calldepth - 1, ret_stk_length - 1) := v),loc))
  )"

subsubsection \<open>length of stack and local variables\<close>

text \<open>The following terms extract the stack length at a given program point
from the well-typing of the given program\<close>

abbreviation stkLength :: "wf_jvmprog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> pc \<Rightarrow> nat"
  where
  "stkLength P C M pc \<equiv> length (fst(the(((P\<^bsub>\<Phi>\<^esub>) C M)!pc)))"

abbreviation locLength :: "wf_jvmprog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> pc \<Rightarrow> nat"
  where
  "locLength P C M pc \<equiv> length (snd(the(((P\<^bsub>\<Phi>\<^esub>) C M)!pc)))"

subsubsection \<open>Conversion functions\<close>

text \<open>
This function takes a natural number n and a function f with domain \<open>nat\<close>
and creates the array [f 0, f 1, f 2, ..., f (n - 1)].

This is used for extracting the array of local variables
\<close>

(*
fun locs :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
where
  "locs 0 loc = []"
| "locs (Suc n) loc = (locs n loc)@[loc n]"
*)

abbreviation locs :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
where "locs n loc \<equiv> map loc [0..<n]"

text \<open>
This function takes a natural number n and a function f with domain \<open>nat\<close>
and creates the array [f (n - 1), ..., f 1, f 0].

This is used for extracting the stack as a list
\<close>

(*
fun stks :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
where
  "stks 0 stk = []"
| "stks (Suc n) stk = (stk n)#(stks n stk)"
*)

abbreviation stks :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
where "stks n stk \<equiv> map stk (rev [0..<n])"

text \<open>
This function creates a list of the arrays for local variables from the given state
corresponding to the given callstack
\<close>

fun locss :: "wf_jvmprog \<Rightarrow> callstack \<Rightarrow> ((nat \<times> nat) \<Rightarrow> 'a) \<Rightarrow> 'a list list"
where
  "locss P [] loc = []"
| "locss P ((C,M,pc)#cs) loc =
    (locs (locLength P C M pc) (\<lambda>a. loc (length cs, a)))#(locss P cs loc)"

text \<open>
This function creates a list of the (methods') stacks from the given state
corresponding to the given callstack
\<close>

fun stkss :: "wf_jvmprog \<Rightarrow> callstack \<Rightarrow> ((nat \<times> nat) \<Rightarrow> 'a) \<Rightarrow> 'a list list"
where
  "stkss P [] stk = []"
| "stkss P ((C,M,pc)#cs) stk =
  (stks (stkLength P C M pc) (\<lambda>a. stk (length cs, a)))#(stkss P cs stk)"

text \<open>Given a callstack and a state, this abbreviation converts the state
to Jinja's state representation
\<close>

abbreviation state_to_jvm_state :: "wf_jvmprog \<Rightarrow> callstack \<Rightarrow> state \<Rightarrow> jvm_state"
where "state_to_jvm_state P cs s \<equiv>
  (None, heap_of s, zip (stkss P cs (stk_of s)) (zip (locss P cs (loc_of s)) cs))"

text \<open>This function extracts the call stack from a given frame stack (as it is given
by Jinja's state representation)
\<close>

definition framestack_to_callstack :: "frame list \<Rightarrow> callstack"
where "framestack_to_callstack frs \<equiv> map snd (map snd frs)"

subsubsection \<open>State Conformance\<close>

text \<open>Now we lift byte code verifier conformance to our state representation\<close>

definition bv_conform :: "wf_jvmprog \<Rightarrow> callstack \<Rightarrow> state \<Rightarrow> bool"
  ("_,_ \<turnstile>\<^bsub>BV\<^esub> _ \<surd>")
where "P,cs \<turnstile>\<^bsub>BV\<^esub> s \<surd> \<equiv> correct_state (P\<^bsub>wf\<^esub>) (P\<^bsub>\<Phi>\<^esub>) (state_to_jvm_state P cs s)"

subsubsection \<open>Statically determine catch-block\<close>

text \<open>This function is equivalent to Jinja's \<open>find_handler\<close> function\<close>
fun find_handler_for :: "wf_jvmprog \<Rightarrow> cname \<Rightarrow> callstack \<Rightarrow> callstack"
where
  "find_handler_for P C [] = []"
| "find_handler_for P C (c#cs) = (let (C',M',pc') = c in
     (case match_ex_table (P\<^bsub>wf\<^esub>) C pc' (ex_table_of (P\<^bsub>wf\<^esub>) C' M') of
          None \<Rightarrow> find_handler_for P C cs
        | Some pc_d \<Rightarrow> (C', M', fst pc_d)#cs))"

subsection \<open>Simplification lemmas\<close>

lemma find_handler_decr [simp]: "find_handler_for P Exc cs \<noteq> c#cs"
proof
  assume "find_handler_for P Exc cs = c#cs"
  hence "length cs < length (find_handler_for P Exc cs)" by simp
  thus False by (induct cs, auto)
qed

(*
lemma locs_length [simp]: "length (locs n loc) = n"
  by (induct n) auto

lemma stks_length [simp]: "length (stks n stk) = n"
  by (induct n) auto
*)

lemma stkss_length [simp]: "length (stkss P cs stk) = length cs"
  by (induct cs) auto

lemma locss_length [simp]: "length (locss P cs loc) = length cs"
  by (induct cs) auto

(*
lemma nth_stks: "b < n \<Longrightarrow> stks n stk ! b = stk(n - Suc b)"
  by (auto simp: rev_nth)
proof (induct n arbitrary: b)
  case (0 b)
  thus ?case by simp
next
  case (Suc n b)
  thus ?case
    by (auto simp: nth_Cons' less_Suc_eq)
qed
*)

lemma nth_stkss:
  "\<lbrakk> a < length cs; b < length (stkss P cs stk ! (length cs - Suc a)) \<rbrakk>
  \<Longrightarrow> stkss P cs stk ! (length cs - Suc a) !
    (length (stkss P cs stk ! (length cs - Suc a)) - Suc b) = stk (a,b)"
proof (induct cs)
  case Nil
  thus ?case by (simp add: nth_Cons')
next
  case (Cons aa cs)
  thus ?case
    by (cases aa, auto simp add: nth_Cons' rev_nth less_Suc_eq)
qed

(*
lemma nth_locs: "b < n \<Longrightarrow> locs n loc ! b = loc b"
proof (induct n)
  case 0
  thus ?case by simp
next
  case (Suc n)
  thus ?case
    by (auto simp: nth_append less_Suc_eq)
qed
*)

lemma nth_locss:
  "\<lbrakk> a < length cs; b < length (locss P cs loc ! (length cs - Suc a)) \<rbrakk>
  \<Longrightarrow> locss P cs loc ! (length cs - Suc a) ! b = loc (a,b)"
proof (induct cs)
  case Nil
  thus ?case by (simp add: nth_Cons')
next
  case (Cons aa cs)
  thus ?case
    by (cases aa, auto simp: nth_Cons' (* nth_locs *) less_Suc_eq)
qed

lemma hd_stks [simp]: "n \<noteq> 0 \<Longrightarrow> hd (stks n stk) = stk(n - 1)"
  by (cases n, simp_all)

lemma hd_tl_stks: "n > 1 \<Longrightarrow> hd (tl (stks n stk)) = stk(n - 2)"
  by (cases n, auto)

(*
lemma stks_purge:
  "d \<ge> b \<Longrightarrow> stks b (stk(d := e)) = stks b stk"
  by (induct b, auto)

lemma stks_purge':
  "d \<ge> b \<Longrightarrow> stks b (\<lambda>x. if x = d then e else stk x) = stks b stk"
  by (fold fun_upd_def, simp only: stks_purge)
*)

lemma stkss_purge:
  "length cs \<le> a \<Longrightarrow> stkss P cs (stk((a,b) := c)) = stkss P cs stk"
  by (induct cs, auto (* simp: stks_purge *))

lemma stkss_purge':
  "length cs \<le> a \<Longrightarrow> stkss P cs (\<lambda>s. if s = (a, b) then c else stk s) = stkss P cs stk"
  by (fold fun_upd_def, simp only: stkss_purge)

(*
lemma locs_purge:
  "d \<ge> b \<Longrightarrow> locs b (loc(d := e)) = locs b loc"
  by (induct b, auto)

lemma locs_purge':
  "d \<ge> b \<Longrightarrow> locs b (\<lambda>b. if b = d then e else loc b) = locs b loc"
  by (fold fun_upd_def, simp only: locs_purge)
*)

lemma locss_purge:
  "length cs \<le> a \<Longrightarrow> locss P cs (loc((a,b) := c)) = locss P cs loc"
  by (induct cs, auto (*simp: locs_purge *))

lemma locss_purge':
  "length cs \<le> a \<Longrightarrow> locss P cs (\<lambda>s. if s = (a, b) then c else loc s) = locss P cs loc"
  by (fold fun_upd_def, simp only: locss_purge)

lemma locs_pullout [simp]:
  "locs b (loc(n := e)) = (locs b loc) [n := e]"
proof (induct b)
  case 0
  thus ?case by simp
next
  case (Suc b)
  thus ?case
    by (cases "n - b", auto simp: list_update_append not_less_eq less_Suc_eq)
qed

lemma locs_pullout' [simp]:
  "locs b (\<lambda>a. if a = n then e else loc (c, a)) = (locs b (\<lambda>a. loc (c, a))) [n := e]"
  by (fold fun_upd_def) simp

lemma stks_pullout:
  "n < b \<Longrightarrow> stks b (stk(n := e)) = (stks b stk) [b - Suc n := e]"
proof (induct b)
  case 0
  thus ?case by simp
next
  case (Suc b)
  thus ?case
  proof (cases "b = n")
    case True
    with Suc show ?thesis
      by auto
(*      by (auto simp: stks_purge') *)
  next
    case False
    with Suc show ?thesis
      by (cases "b - n") (auto intro!: nth_equalityI simp: nth_list_update)
 qed
qed

lemma nth_tl : "xs \<noteq> [] \<Longrightarrow> tl xs ! n = xs ! (Suc n)"
  by (cases xs, simp_all)

lemma f2c_Nil [simp]: "framestack_to_callstack [] = []"
  by (simp add: framestack_to_callstack_def)

lemma f2c_Cons [simp]:
  "framestack_to_callstack ((stk,loc,C,M,pc)#frs) = (C,M,pc)#(framestack_to_callstack frs)"
  by (simp add: framestack_to_callstack_def)

lemma f2c_length [simp]:
  "length (framestack_to_callstack frs) = length frs"
  by (simp add: framestack_to_callstack_def)

lemma f2c_s2jvm_id [simp]:
  "framestack_to_callstack
    (snd(snd(state_to_jvm_state P cs s))) =
  cs"
  by (cases s, simp add: framestack_to_callstack_def)

lemma f2c_s2jvm_id' [simp]:
  "framestack_to_callstack
  (zip (stkss P cs stk) (zip (locss P cs loc) cs)) = cs"
  by (simp add: framestack_to_callstack_def)

lemma f2c_append [simp]:
  "framestack_to_callstack (frs @ frs') =
  (framestack_to_callstack frs) @ (framestack_to_callstack frs')"
  by (simp add: framestack_to_callstack_def)

subsection \<open>CFG construction\<close>

subsection \<open>Datatypes\<close>

text \<open>Nodes are labeled with a callstack and an optional tuple (consisting of
a callstack and a flag).

The first callstack determines the current program point (i.e. the next statement
to execute). If the second parameter is not None, we are at an intermediate state,
where the target of the instruction is determined (the second callstack)
and the flag is set to whether an exception is thrown or not.
\<close>
datatype j_node =
   Entry  ("'('_Entry'_')")
 | Node "callstack" "(callstack \<times> bool) option" ("'('_ _,_ '_')")

text \<open>The empty callstack indicates the exit node\<close>

abbreviation j_node_Exit :: "j_node" ("'('_Exit'_')")
where "j_node_Exit \<equiv> (_ [],None _)"

text \<open>An edge is a triple, consisting of two nodes and the edge kind\<close>

type_synonym j_edge = "(j_node \<times> state edge_kind \<times> j_node)"

subsection \<open>CFG\<close>

text \<open>
The CFG is constructed by a case analysis on the instructions and
their different behavior in different states. E.g. the exceptional behavior of
{\sc New}, if there is no more space in the heap, vs. the normal behavior.

Note: The set of edges defined by this predicate is a first approximation to the
real set of edges in the CFG. We later (theory JVMInterpretation) add some well-formedness
requirements to the nodes.
\<close>

inductive JVM_CFG :: "jvmprog \<Rightarrow> j_node \<Rightarrow> state edge_kind \<Rightarrow> j_node \<Rightarrow> bool"
  ("_ \<turnstile> _ -_\<rightarrow> _")
where
  JCFG_EntryExit:
  "prog \<turnstile> (_Entry_) -(\<lambda>s. False)\<^sub>\<surd>\<rightarrow> (_Exit_)"

| JCFG_EntryStart:
  "prog = (P, C0, Main) \<Longrightarrow> prog \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_ [(C0, Main, 0)],None _)"

| JCFG_ReturnExit:
  "\<lbrakk> prog = (P,C0,Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = Return \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ [(C, M, pc)],None _) -\<Up>id\<rightarrow> (_Exit_)"

| JCFG_Straight_NoExc:
  "\<lbrakk> prog = (P, C0, Main);
    instrs_of (P\<^bsub>wf\<^esub>) C M ! pc \<in> {Load idx, Store idx, Push val, Pop, IAdd, CmpEq};
    ek = \<Up>(\<lambda>s. exec_instr ((instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc) P s
                          (length cs) (stkLength P C M pc) arbitrary arbitrary) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, Suc pc)#cs,None _)"

| JCFG_New_Normal_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (New Cl);
    ek = (\<lambda>(h,stk,loc). new_Addr h \<noteq> None)\<^sub>\<surd>\<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>((C, M, Suc pc)#cs,False)\<rfloor> _)"

| JCFG_New_Normal_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (New Cl);
    ek = \<Up>(\<lambda>s. exec_instr (New Cl) P s (length cs) (stkLength P C M pc) arbitrary arbitrary) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C, M, Suc pc)#cs, False)\<rfloor> _) -ek\<rightarrow> (_ (C, M, Suc pc)#cs,None _)"

| JCFG_New_Exc_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (New Cl);
    find_handler_for P OutOfMemory ((C, M, pc)#cs) = cs';
    ek = (\<lambda>(h,stk,loc). new_Addr h = None)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>(cs',True)\<rfloor> _)"

| JCFG_New_Exc_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (New Cl);
    find_handler_for P OutOfMemory ((C, M, pc)#cs) = (C', M', pc')#cs';
    ek = \<Up>(\<lambda>(h,stk,loc).
     (h,
      stk((length cs',(stkLength P C' M' pc') - 1) := Addr (addr_of_sys_xcpt OutOfMemory)),
      loc)
     ) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C', M', pc')#cs', True)\<rfloor> _) -ek\<rightarrow> (_ (C', M', pc')#cs',None _)"

| JCFG_New_Exc_Exit:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (New Cl);
    find_handler_for P OutOfMemory ((C, M, pc)#cs) = [] \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>([], True)\<rfloor> _) -\<Up>id\<rightarrow> (_Exit_)"

| JCFG_Getfield_Normal_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Getfield Fd Cl);
    ek = (\<lambda>(h,stk,loc).  stk(length cs, stkLength P C M pc - 1) \<noteq> Null)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>((C, M, Suc pc)#cs, False)\<rfloor> _)"

| JCFG_Getfield_Normal_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Getfield Fd Cl);
    ek = \<Up>(\<lambda>s. exec_instr (Getfield Fd Cl) P s (length cs) (stkLength P C M pc)
                          arbitrary arbitrary) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C, M, Suc pc)#cs, False)\<rfloor> _) -ek\<rightarrow> (_ (C, M, Suc pc)#cs,None _)"

| JCFG_Getfield_Exc_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Getfield Fd Cl);
    find_handler_for P NullPointer ((C, M, pc)#cs) = cs';
    ek = (\<lambda>(h,stk,loc). stk(length cs, stkLength P C M pc - 1) = Null)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>(cs', True)\<rfloor> _)"

| JCFG_Getfield_Exc_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Getfield Fd Cl);
    find_handler_for P NullPointer ((C, M, pc)#cs) = (C', M', pc')#cs';
    ek =  \<Up>(\<lambda>(h,stk,loc).
     (h,
      stk((length cs',(stkLength P C' M' pc') - 1) := Addr (addr_of_sys_xcpt NullPointer)),
      loc)
     ) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C', M', pc')#cs', True)\<rfloor> _) -ek\<rightarrow> (_ (C', M', pc')#cs',None _)"

| JCFG_Getfield_Exc_Exit:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Getfield Fd Cl);
    find_handler_for P NullPointer ((C, M, pc)#cs) = [] \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>([], True)\<rfloor> _) -\<Up>id\<rightarrow> (_Exit_)"

| JCFG_Putfield_Normal_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Putfield Fd Cl);
    ek = (\<lambda>(h,stk,loc).  stk(length cs, stkLength P C M pc - 2) \<noteq> Null)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>((C, M, Suc pc)#cs, False)\<rfloor> _)"

| JCFG_Putfield_Normal_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Putfield Fd Cl);
    ek = \<Up>(\<lambda>s. exec_instr (Putfield Fd Cl) P s (length cs) (stkLength P C M pc)
                          arbitrary arbitrary) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C, M, Suc pc)#cs, False)\<rfloor> _) -ek\<rightarrow> (_ (C, M, Suc pc)#cs,None _)"

| JCFG_Putfield_Exc_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Putfield Fd Cl);
    find_handler_for P NullPointer ((C, M, pc)#cs) = cs';
    ek = (\<lambda>(h,stk,loc). stk(length cs, stkLength P C M pc - 2) = Null)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>(cs', True)\<rfloor> _)"

| JCFG_Putfield_Exc_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Putfield Fd Cl);
    find_handler_for P NullPointer ((C, M, pc)#cs) = (C', M', pc')#cs';
    ek = \<Up>(\<lambda>(h,stk,loc).
     (h,
      stk((length cs',(stkLength P C' M' pc') - 1) := Addr (addr_of_sys_xcpt NullPointer)),
      loc)
     ) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C', M', pc')#cs', True)\<rfloor> _) -ek\<rightarrow> (_ (C', M', pc')#cs',None _)"

| JCFG_Putfield_Exc_Exit:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Putfield Fd Cl);
    find_handler_for P NullPointer ((C, M, pc)#cs) = [] \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>([], True)\<rfloor> _) -\<Up>id\<rightarrow> (_Exit_)"

| JCFG_Checkcast_Normal_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Checkcast Cl);
    ek = (\<lambda>(h,stk,loc). cast_ok (P\<^bsub>wf\<^esub>) Cl h (stk(length cs, stkLength P C M pc - Suc 0)))\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, Suc pc)#cs,None _)"

| JCFG_Checkcast_Exc_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Checkcast Cl);
    find_handler_for P ClassCast ((C, M, pc)#cs) = cs';
    ek = (\<lambda>(h,stk,loc). \<not> cast_ok (P\<^bsub>wf\<^esub>) Cl h (stk(length cs, stkLength P C M pc - Suc 0)))\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>(cs', True)\<rfloor> _)"

| JCFG_Checkcast_Exc_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Checkcast Cl);
    find_handler_for P ClassCast ((C, M, pc)#cs) = (C', M', pc')#cs';
    ek = \<Up>(\<lambda>(h,stk,loc).
     (h,
      stk((length cs',(stkLength P C' M' pc') - 1) := Addr (addr_of_sys_xcpt ClassCast)),
      loc)
     ) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C', M', pc')#cs', True)\<rfloor> _) -ek\<rightarrow> (_ (C', M', pc')#cs',None _)"

| JCFG_Checkcast_Exc_Exit:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Checkcast Cl);
    find_handler_for P ClassCast ((C, M, pc)#cs) = [] \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>([], True)\<rfloor> _) -\<Up>id\<rightarrow> (_Exit_)"

| JCFG_Invoke_Normal_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Invoke M2 n);
    cd = length cs;
    stk_length = stkLength P C M pc;
    ek = (\<lambda>(h,stk,loc).
     stk(cd, stk_length - Suc n) \<noteq> Null \<and>
     fst(method (P\<^bsub>wf\<^esub>) (cname_of h (the_Addr(stk(cd, stk_length - Suc n)))) M2) = D
    )\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow>
      prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>((D, M2, 0)#(C, M, pc)#cs, False)\<rfloor> _)"

| JCFG_Invoke_Normal_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Invoke M2 n);
    stk_length = stkLength P C M pc;
    loc_length = locLength P D M2 0;
    ek = \<Up>(\<lambda>s. exec_instr (Invoke M2 n) P s (length cs) stk_length arbitrary loc_length)
   \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((D, M2, 0)#(C, M, pc)#cs, False)\<rfloor> _) -ek\<rightarrow>
               (_ (D, M2, 0)#(C, M, pc)#cs,None _)"

| JCFG_Invoke_Exc_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Invoke m2 n);
    find_handler_for P NullPointer ((C, M, pc)#cs) = cs';
    ek = (\<lambda>(h,stk,loc). stk(length cs, stkLength P C M pc - Suc n) = Null)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>(cs', True)\<rfloor> _)"

| JCFG_Invoke_Exc_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Invoke M2 n);
    find_handler_for P NullPointer ((C, M, pc)#cs) = (C', M', pc')#cs';
    ek = \<Up>(\<lambda>(h,stk,loc).
     (h,
      stk((length cs',(stkLength P C' M' pc') - 1) := Addr (addr_of_sys_xcpt NullPointer)),
      loc)
     )
   \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C', M', pc')#cs', True)\<rfloor> _) -ek\<rightarrow> (_ (C', M', pc')#cs',None _)"

| JCFG_Invoke_Exc_Exit:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (Invoke M2 n);
    find_handler_for P NullPointer ((C, M, pc)#cs) = [] \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>([], True)\<rfloor> _) -\<Up>id\<rightarrow> (_Exit_)"

| JCFG_Return_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = Return;
    stk_length = stkLength P C M pc;
    r_stk_length = stkLength P C' M' (Suc pc');
    ek = \<Up>(\<lambda>s. exec_instr Return P s (Suc (length cs)) stk_length r_stk_length arbitrary) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#(C', M', pc')#cs,None _) -ek\<rightarrow> (_ (C', M', Suc pc')#cs,None _)"

| JCFG_Goto_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = Goto idx \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -\<Up>id\<rightarrow> (_ (C, M, nat (int pc + idx))#cs,None _)"

| JCFG_IfFalse_False:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (IfFalse b);
    b \<noteq> 1;
    ek = (\<lambda>(h,stk,loc). stk(length cs, stkLength P C M pc - 1) = Bool False)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, nat (int pc + b))#cs,None _)"

| JCFG_IfFalse_Next:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = (IfFalse b);
    ek = (\<lambda>(h,stk,loc). stk(length cs, stkLength P C M pc - 1) \<noteq> Bool False \<or> b = 1)\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, Suc pc)#cs,None _)"

| JCFG_Throw_Pred:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = Throw;
    cd = length cs;
    stk_length = stkLength P C M pc;
    \<exists>Exc. find_handler_for P Exc ((C, M, pc)#cs) = cs';
    ek = (\<lambda>(h,stk,loc).
      (stk(length cs, stkLength P C M pc - 1) = Null \<and>
        find_handler_for P NullPointer ((C, M, pc)#cs) = cs') \<or>
      (stk(length cs, stkLength P C M pc - 1) \<noteq> Null \<and>
        find_handler_for P (cname_of h (the_Addr(stk(cd, stk_length - 1)))) ((C, M, pc)#cs) = cs')
    )\<^sub>\<surd> \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,None _) -ek\<rightarrow> (_ (C, M, pc)#cs,\<lfloor>(cs', True)\<rfloor> _)"

| JCFG_Throw_Update:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = Throw;
    ek = \<Up>(\<lambda>(h,stk,loc).
      (h,
       stk((length cs',(stkLength P C' M' pc') - 1) :=
         if (stk(length cs, stkLength P C M pc - 1) = Null) then
           Addr (addr_of_sys_xcpt NullPointer)
         else (stk(length cs, stkLength P C M pc - 1))),
       loc)
    ) \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>((C', M', pc')#cs', True)\<rfloor> _) -ek\<rightarrow> (_ (C', M', pc')#cs',None _)"

| JCFG_Throw_Exit:
  "\<lbrakk> prog = (P, C0, Main);
    (instrs_of (P\<^bsub>wf\<^esub>) C M) ! pc = Throw \<rbrakk>
    \<Longrightarrow> prog \<turnstile> (_ (C, M, pc)#cs,\<lfloor>([],True)\<rfloor> _) -\<Up>id\<rightarrow> (_Exit_)"

subsection \<open>CFG properties\<close>

lemma JVMCFG_Entry_no_targetnode [dest]:
  assumes edge:"prog \<turnstile> n -et\<rightarrow> (_Entry_)"
  shows "False"
proof -
  { fix n' have "\<lbrakk>prog \<turnstile> n -et\<rightarrow> n'; n' = (_Entry_)\<rbrakk> \<Longrightarrow> False"
      by (auto elim!: JVM_CFG.cases)
  }
  with edge show ?thesis by fastforce
qed

lemma JVMCFG_EntryD:
  "\<lbrakk>(P,C,M) \<turnstile> n -et\<rightarrow> n'; n = (_Entry_)\<rbrakk>
  \<Longrightarrow> (n' = (_Exit_) \<and> et = (\<lambda>s. False)\<^sub>\<surd>) \<or> (n' = (_ [(C,M,0)],None _) \<and> et = (\<lambda>s. True)\<^sub>\<surd>)"
by (erule JVM_CFG.cases) simp_all

declare split_def [simp add]
declare find_handler_for.simps [simp del]

(* The following lemma explores many cases, it takes a little to prove *)
lemma JVMCFG_edge_det:
  "\<lbrakk>prog \<turnstile> n -et\<rightarrow> n'; prog \<turnstile> n -et'\<rightarrow> n'\<rbrakk> \<Longrightarrow> et = et'"
  by (erule JVM_CFG.cases, (erule JVM_CFG.cases, fastforce+)+)

declare split_def [simp del]
declare find_handler_for.simps [simp add]

end


(*  Title:      HOL/Auth/n_g2kAbsAfter_lemma_inv__3_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_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__3_on_rules imports n_g2kAbsAfter_lemma_on_inv__3
begin
section{*All lemmas on causal relation between inv__3*}
lemma lemma_inv__3_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__3  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__3) done
    }

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

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__3) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__3) done
    }

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__55_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__55_on_rules imports n_german_lemma_on_inv__55
begin
section{*All lemmas on causal relation between inv__55*}
lemma lemma_inv__55_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__55  p__Inv0 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) 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__55) done
    }

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

end


(*  Title:      HOL/Auth/n_g2kAbsAfter_lemma_inv__34_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_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__34_on_rules imports n_g2kAbsAfter_lemma_on_inv__34
begin
section{*All lemmas on causal relation between inv__34*}
lemma lemma_inv__34_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__34  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__34) done
    }

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

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__34) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__34) done
    }

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

end


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

theory Schedule_DR
imports Finalise_DR
begin

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

(* getActiveTCBs returns a subset of CapDL's all_active_tcbs. *)
lemma getActiveTCBs_subset:
  "\<lbrakk> getActiveTCB x s' = Some y; invs s'; valid_etcbs s' \<rbrakk> \<Longrightarrow>
   x \<in> all_active_tcbs (transform s')"
  apply (clarsimp simp: all_active_tcbs_def getActiveTCB_def)
  apply (clarsimp simp: transform_def transform_objects_def map_add_def domIff)
  apply (clarsimp dest!: get_tcb_SomeD split: option.splits if_split_asm)
  apply (rule context_conjI)
   apply (clarsimp simp: restrict_map_def)
   apply (frule invs_valid_idle)
   apply (clarsimp simp: valid_idle_def pred_tcb_def2 get_tcb_def)
  apply (clarsimp simp: restrict_map_def split: if_split_asm)
  apply (clarsimp simp: transform_object_def transform_tcb_def)
  apply (clarsimp simp: infer_tcb_pending_op_def)
  apply (frule(1) valid_etcbs_tcb_etcb)
  apply (case_tac "tcb_state y", auto simp: tcb_pending_op_slot_def tcb_boundntfn_slot_def)
  done

(* allActiveTCBs should be a subset of those allowed in CapDL. *)
definition
  allActiveTCBs_relation :: "cdl_object_id set \<Rightarrow> word32 set \<Rightarrow> bool"
where
  "allActiveTCBs_relation a b \<equiv> b \<subseteq> a"

(* allActiveTCBs correspond *)
lemma allActiveTCBs_corres:
  "dcorres allActiveTCBs_relation \<top> (invs and valid_etcbs) (gets all_active_tcbs) allActiveTCBs"
  apply (clarsimp simp: allActiveTCBs_def gets_def)
  apply (clarsimp simp: corres_underlying_def)
  apply (clarsimp simp: exec_get split_def return_def)
  apply (clarsimp simp: allActiveTCBs_relation_def)
  apply (auto simp: getActiveTCBs_subset)
  done

crunch idle_thread[wp]: switch_to_idle_thread "\<lambda>s. P (idle_thread s)"

lemma dcorres_arch_switch_to_idle_thread_return: "dcorres dc \<top> \<top> (return ()) arch_switch_to_idle_thread"
  apply (clarsimp simp: arch_switch_to_idle_thread_def)
  apply (rule corres_guard_imp)
    apply (rule dcorres_gets_all_param)
    apply (rule dcorres_set_vm_root)
   by simp+

lemma change_current_domain_same: "\<lbrace>(=) s\<rbrace> change_current_domain \<exists>\<lbrace>\<lambda>r. (=) s\<rbrace>"
  apply (clarsimp simp: change_current_domain_def exs_valid_def bind_def return_def gets_def modify_def put_def fst_def snd_def get_def select_def)
  apply (rule_tac x="cdl_current_domain s" in exI)
  apply clarsimp
  done

lemma switch_to_idle_thread_dcorres:
  "dcorres dc \<top> (invs and valid_etcbs) (Schedule_D.switch_to_thread None) switch_to_idle_thread"
   apply (clarsimp simp: Schedule_D.switch_to_thread_def switch_to_idle_thread_def)
   apply (rule dcorres_symb_exec_r)
   apply (rule corres_guard_imp)
   apply (rule corres_split_noop_rhs)
         apply (clarsimp simp: corres_underlying_def gets_def modify_def get_def put_def do_machine_op_def select_f_def split_def bind_def in_return)
         apply (clarsimp simp: transform_def transform_current_thread_def transform_asid_table_def)
         apply assumption
        apply (rule dcorres_arch_switch_to_idle_thread_return)
      apply (wp | simp)+
  done

(* Switching to the idle thread and switching to "None" are equivalent. *)
lemma change_current_domain_and_switch_to_idle_thread_dcorres:
  "dcorres dc \<top> (invs and valid_etcbs)
                (do _ \<leftarrow> change_current_domain;
                    Schedule_D.switch_to_thread None
                 od)
                switch_to_idle_thread"
  including no_pre
  apply (clarsimp simp: Schedule_D.switch_to_thread_def switch_to_idle_thread_def)
  apply (rule dcorres_symb_exec_r)
  apply (rule corres_guard_imp)
  apply (rule corres_symb_exec_l)
  apply (rule_tac R=\<top> in corres_split_noop_rhs)
        apply (clarsimp simp: corres_underlying_def gets_def modify_def get_def put_def do_machine_op_def select_f_def split_def bind_def in_return)
        apply (clarsimp simp: transform_def transform_current_thread_def transform_asid_table_def)
        apply assumption
       apply (rule dcorres_arch_switch_to_idle_thread_return)
      apply (wp change_current_domain_same | simp)+
  done

lemma arch_switch_to_thread_dcorres:
  "dcorres dc \<top> (invs and (\<lambda>s. idle_thread s \<noteq> t) and valid_etcbs)
     (return ())
     (arch_switch_to_thread t)"
  apply (clarsimp simp: arch_switch_to_thread_def)
  apply (rule corres_dummy_return_pl)
  apply (rule corres_guard_imp)
    apply (rule corres_split [OF _ dcorres_set_vm_root])
      apply simp
      apply (rule dcorres_machine_op_noop)
      apply (simp add: ARM.clearExMonitor_def, wp)[1]
      apply (wp|simp)+
  done

crunch idle_thread [wp]: arch_switch_to_thread "\<lambda>s. P (idle_thread s)"
  (simp: crunch_simps wp: crunch_wps ignore: ARM.clearExMonitor)

(*
 * Setting the current thread.
 *)
lemma switch_to_thread_corres:
  "dcorres dc \<top> (invs and (\<lambda>s. idle_thread s \<noteq> x) and valid_etcbs)
           (Schedule_D.switch_to_thread (Some x)) (Schedule_A.switch_to_thread x)"
  apply (clarsimp simp: Schedule_D.switch_to_thread_def Schedule_A.switch_to_thread_def)
  apply (rule corres_dummy_return_pl)
  apply (rule corres_symb_exec_r)
     apply (rule corres_symb_exec_r)
        apply (rule corres_guard_imp)
          apply (rule corres_split [OF _ arch_switch_to_thread_dcorres])
            apply simp
            apply (rule dcorres_rhs_noop_above[OF tcb_sched_action_dcorres])
              apply (rule corres_modify [where P=\<top> and P'="\<lambda>s. idle_thread s \<noteq> x"])
              apply (clarsimp simp: transform_def)
              apply (simp add: transform_current_thread_def transform_asid_table_def)
             apply (wp+)[4]
         apply simp
        apply assumption
       apply (clarsimp|wp)+
  done

lemma corrupt_intents_current_thread:
  "cdl_current_thread (corrupt_intents x p s) = cdl_current_thread s"
  by (simp add: corrupt_intents_def)

crunch cdl_cur: corrupt_frame "\<lambda>s. cdl_current_thread s = x"
  (wp: select_wp simp: corrupt_intents_current_thread)

(* Switching to the active thread has no effect. *)
lemma switch_to_thread_idempotent_corres:
  "dcorres dc (\<lambda>s. cdl_current_thread s = x) \<top> (Schedule_D.switch_to_thread x) (return ())"
  apply (clarsimp simp: Schedule_D.switch_to_thread_def)
  apply (clarsimp simp: modify_def)
  apply (clarsimp simp: corres_underlying_def)
  apply (clarsimp simp: transform_def transform_current_thread_def)
  apply (clarsimp simp: in_return)
  apply (auto simp: in_return get_def put_def split_def bind_def)[1]
  done

(* getActiveTCB on the idle thread always returns None. *)
lemma getActiveTCB_idle: "invs s \<Longrightarrow> getActiveTCB (idle_thread s) s = None"
  apply (frule invs_valid_idle)
  apply (clarsimp simp: valid_idle_def getActiveTCB_def)
  apply (clarsimp simp: pred_tcb_at_def get_tcb_def get_obj_def obj_at_def)
  done

lemma switch_to_thread_same_corres:
  "dcorres dc (\<lambda>s. x = y) (invs and (\<lambda>s. idle_thread s \<noteq> x) and valid_etcbs)
           (Schedule_D.switch_to_thread (Some y)) (Schedule_A.switch_to_thread x)"
  apply (clarsimp simp: Schedule_D.switch_to_thread_def
                        Schedule_A.switch_to_thread_def)
  apply (rule corres_dummy_return_pl)
  apply (rule corres_symb_exec_r)
     apply (rule corres_symb_exec_r)
        apply (rule corres_guard_imp)
          apply (rule corres_split [OF _ arch_switch_to_thread_dcorres])
            apply simp
            apply (rule dcorres_rhs_noop_above[OF tcb_sched_action_dcorres])
              apply (rule corres_modify [where P'="\<lambda>s. idle_thread s \<noteq> x"])
              apply (clarsimp simp: transform_def transform_current_thread_def transform_asid_table_def)
              apply (simp add: transform_current_thread_def transform_asid_table_def)
             apply (wp+)[4]
         apply simp
        apply assumption
       apply (clarsimp|wp)+
  done

lemma set_scheduler_action_dcorres:
   "dcorres dc \<top> \<top> (return ()) (set_scheduler_action sa)"
  by (clarsimp simp: corres_underlying_def set_scheduler_action_def modify_def get_def put_def bind_def return_def)

lemma switch_to_thread_None_dcorres_L:
   "dcorres dc (\<lambda>s. cdl_current_thread s = None) \<top>
               (do _ \<leftarrow> change_current_domain;
                   Schedule_D.switch_to_thread None
                od)
               (return ())"
  apply (auto simp: Schedule_D.switch_to_thread_def modify_def corres_underlying_def get_def put_def bind_def return_def
                    change_current_domain_def gets_def select_def transform_def)
  done

lemma switch_to_thread_None_dcorres:
  "dcorres dc \<top> (\<lambda>s. cur_thread s = idle_thread s)
                (do _ \<leftarrow> change_current_domain;
                    Schedule_D.switch_to_thread None
                 od)
               (return ())"
  apply (rule_tac Q="\<lambda>s. cdl_current_thread s = None" and Q'="\<top>" in stronger_corres_guard_imp)
    apply (rule switch_to_thread_None_dcorres_L)
   apply (clarsimp simp: transform_def transform_current_thread_def)+
  done

lemma schedule_resume_cur_thread_dcorres_L:
    "\<And>cur cur_ts. dcorres dc ((\<lambda>s. \<exists>t tcb. cdl_current_thread s = Some t \<and>
                                           (\<exists>d. s = s \<lparr>cdl_current_domain := d\<rparr>) \<and>
                                           t \<in> active_tcbs_in_domain (cdl_current_domain s) s)
                                   or (\<lambda>s. cdl_current_thread s = None)) \<top>
        Schedule_D.schedule
       (do idle_t \<leftarrow> gets idle_thread;
           assert (runnable cur_ts \<or> cur = idle_t)
         od)"
  unfolding Schedule_D.schedule_def
  apply (rule corres_either_alternate2)
   apply (rule corres_guard_imp)
     apply (rule corres_symb_exec_l_Ex)
     apply (clarsimp)
     apply (rule corres_symb_exec_l_Ex)
     apply (rule corres_symb_exec_l_Ex)
     apply (rule corres_symb_exec_l_Ex)
     apply (rule dcorres_symb_exec_r)
       apply (clarsimp simp: assert_def)
       apply (rule conjI, clarsimp)
        apply (fold dc_def)
        apply (rule switch_to_thread_idempotent_corres)
       apply (rule conjI, clarsimp)
        apply (rule switch_to_thread_idempotent_corres)
       apply (clarsimp simp: corres_underlying_def fail_def)
      apply (wp | simp)+
    apply (fastforce simp: select_def gets_def active_tcbs_in_domain_def bind_def return_def domIff
                           get_def fst_def modify_def put_def change_current_domain_def)
   apply simp
  apply (rule corres_guard_imp)
    apply (rule dcorres_symb_exec_r)
      apply (clarsimp simp: assert_def)
      apply (rule conjI, clarsimp)
       apply (rule switch_to_thread_None_dcorres_L)
      apply (rule conjI, clarsimp)
       apply (rule switch_to_thread_None_dcorres_L)
      apply (clarsimp simp: corres_underlying_def fail_def)
     apply (wp | simp | fastforce)+
  done

lemma schedule_resume_cur_thread_dcorres:
         "\<And>cur cur_ts. dcorres dc \<top> (\<lambda>s. cur = cur_thread s \<and> st_tcb_at ((=) cur_ts) cur s \<and> valid_etcbs s \<and> valid_sched s \<and> invs s \<and> scheduler_action s = resume_cur_thread)
        Schedule_D.schedule
       (do idle_t \<leftarrow> gets idle_thread;
           assert (runnable cur_ts \<or> cur = idle_t)
         od)"
  apply (rule stronger_corres_guard_imp)
    apply (rule schedule_resume_cur_thread_dcorres_L)
   apply (case_tac "cur \<noteq> idle_thread s'")
    apply (clarsimp simp: valid_sched_def valid_sched_action_def is_activatable_def invs_def valid_state_def
                          pred_tcb_at_def obj_at_def ct_in_cur_domain_def in_cur_domain_def)
    apply (frule(1) valid_etcbs_tcb_etcb)
    apply (auto simp: transform_def transform_current_thread_def all_active_tcbs_def transform_objects_def active_tcbs_in_domain_def etcb_at_def tcb_boundntfn_slot_def tcb_pending_op_slot_def
                          map_add_def restrict_map_def option_map_def transform_object_def transform_tcb_def valid_idle_def st_tcb_def2 get_tcb_def
                          transform_cnode_contents_def infer_tcb_pending_op_def transform_cap_def domIff st_tcb_at_kh_def obj_at_def only_idle_def
                    split: option.splits if_split Structures_A.kernel_object.splits Structures_A.thread_state.splits)[1]
     (* cur = idle_thread s' *)
   apply (subgoal_tac "cdl_current_thread s = None")
    apply (clarsimp simp: transform_def transform_current_thread_def)+
  done

lemma schedule_switch_thread_helper:
            "\<lbrakk> valid_etcbs s;
               valid_sched s;
               invs s;
               scheduler_action s = switch_thread t
             \<rbrakk>
             \<Longrightarrow> t \<in> active_tcbs_in_domain (cur_domain s) (transform s)"
  apply (clarsimp simp: valid_sched_def valid_sched_action_def weak_valid_sched_action_def is_activatable_def invs_def
                        valid_state_def pred_tcb_at_def obj_at_def switch_in_cur_domain_def in_cur_domain_def only_idle_def)
  apply (frule(1) valid_etcbs_tcb_etcb)
  apply (clarsimp simp: valid_idle_def pred_tcb_at_def)
  apply (drule_tac s="idle_thread s" in sym)
  apply (auto simp: transform_def transform_current_thread_def all_active_tcbs_def transform_objects_def active_tcbs_in_domain_def etcb_at_def
                        map_add_def restrict_map_def option_map_def transform_object_def transform_tcb_def valid_idle_def pred_tcb_at_def get_tcb_def tcb_pending_op_slot_def tcb_boundntfn_slot_def
                        transform_cnode_contents_def infer_tcb_pending_op_def transform_cap_def domIff st_tcb_at_kh_def obj_at_def only_idle_def
                  split: option.splits if_split Structures_A.kernel_object.splits Structures_A.thread_state.splits)
  done

lemma schedule_choose_new_thread_helper:
            "\<lbrakk> ready_queues s (cur_domain s) prio \<noteq> [];
               t = hd (ready_queues s (cur_domain s) prio);
               valid_sched_except_blocked s;
               invs s;
               scheduler_action s = choose_new_thread
             \<rbrakk>
             \<Longrightarrow> (\<exists>y. cdl_objects (transform s) t = Some y) \<and> t \<in> active_tcbs_in_domain (cur_domain s) (transform s)"
  apply (clarsimp simp: valid_sched_def valid_sched_action_def is_activatable_def invs_def
                        valid_state_def pred_tcb_at_def obj_at_def DetSchedInvs_AI.valid_queues_def
                        max_non_empty_queue_def only_idle_def)
  apply (erule_tac x="cur_domain s" in allE)
  apply (erule_tac x="prio" in allE)
  apply clarsimp
  apply (erule_tac x="hd (ready_queues s (cur_domain s) prio)" in ballE)
  apply (clarsimp simp: valid_idle_def pred_tcb_at_def)
  apply (drule_tac s="idle_thread s" in sym)
  apply (auto simp: transform_def transform_current_thread_def all_active_tcbs_def transform_objects_def active_tcbs_in_domain_def etcb_at_def
                       is_etcb_at_def
                        map_add_def restrict_map_def option_map_def transform_object_def transform_tcb_def valid_idle_def st_tcb_def2 get_tcb_def
                        transform_cnode_contents_def infer_tcb_pending_op_def transform_cap_def domIff st_tcb_at_kh_def obj_at_def only_idle_def tcb_pending_op_slot_def tcb_boundntfn_slot_def
                  split: option.splits if_split Structures_A.kernel_object.splits Structures_A.thread_state.splits)
  done

lemma idle_thread_not_in_queue:
  "\<lbrakk> valid_idle s; DetSchedInvs_AI.valid_queues s; ready_queues s d p \<noteq> [] \<rbrakk> \<Longrightarrow> idle_thread s \<noteq> hd (ready_queues s d p)"
  apply (clarsimp simp: valid_idle_def DetSchedInvs_AI.valid_queues_def pred_tcb_at_def obj_at_def)
  apply (erule_tac x="d" in allE)
  apply (erule_tac x="p" in allE)
  apply clarsimp
  apply (erule_tac x="idle_thread s" in ballE)
   apply clarsimp
  apply (frule hd_in_set)
  apply clarsimp
  done

lemma change_current_domain_dcorres: "dcorres dc \<top> \<top> change_current_domain next_domain"
  by (auto simp: corres_underlying_def change_current_domain_def next_domain_def bind_def return_def modify_def Let_def put_def select_def
                    get_def transform_def trans_state_def transform_objects_def transform_cdt_def transform_current_thread_def
                    transform_asid_table_def)

lemma max_set_not_empty:
  "\<And>x::'a::{linorder,finite}. f x \<noteq> [] \<Longrightarrow> f (Max {x. f x \<noteq> []}) \<noteq> []"
  apply (rule_tac S="{x. f x \<noteq> []}" in Max_prop)
   apply auto
  done

lemma next_domain_valid_sched_except_blocked[wp]:
  "\<lbrace> valid_sched_except_blocked and (\<lambda>s. scheduler_action s  = choose_new_thread)\<rbrace> next_domain \<lbrace> \<lambda>_. valid_sched_except_blocked \<rbrace>"
  apply (simp add: next_domain_def Let_def)
  apply (wp, simp add: valid_sched_def valid_sched_action_2_def ct_not_in_q_2_def)
  done

lemma schedule_def_2:
  "Schedule_D.schedule \<equiv> do
     change_current_domain;
     (do
       next_domain \<leftarrow> gets cdl_current_domain;
       threads     \<leftarrow> gets (active_tcbs_in_domain next_domain);
       next_thread \<leftarrow> select threads;
       Schedule_D.switch_to_thread (Some next_thread)
     od \<sqinter> Schedule_D.switch_to_thread None)
   od"
  unfolding Schedule_D.schedule_def
  apply (subst alternative_bind_distrib_2, simp)
  done

lemma schedule_choose_new_thread_dcorres:
  "dcorres dc \<top>
        (\<lambda>s. valid_etcbs s \<and> valid_sched_except_blocked s \<and> invs s \<and> scheduler_action s = choose_new_thread)
        Schedule_D.schedule
        schedule_choose_new_thread"
  unfolding schedule_choose_new_thread_def
  apply (clarsimp simp: guarded_switch_to_def bind_assoc choose_thread_def)
  apply (rule dcorres_symb_exec_r, rename_tac dom_t)
    apply (case_tac "dom_t \<noteq> 0")
     apply (clarsimp)
     apply (rule dcorres_symb_exec_r, rename_tac cur_dom)
       apply (rule dcorres_symb_exec_r, rename_tac rq)
         apply (rule dcorres_rhs_noop_below_True[OF set_scheduler_action_dcorres])
         (* No threads in ready_queues *)
         apply (rule corres_guard_imp)
           apply (rule corres_if_rhs)
            apply (clarsimp simp: Schedule_D.schedule_def)
            apply (rule corres_alternate2)
            apply (rule change_current_domain_and_switch_to_idle_thread_dcorres)
           (* Threads in ready_queues *)
           apply (simp only: Schedule_D.schedule_def)
           unfolding max_non_empty_queue_def
           apply (rule corres_alternate1)
           apply (rule dcorres_symb_exec_r)
             apply (rule dcorres_symb_exec_r)
               apply (rule_tac P'="\<lambda>s. ready_queues s (cur_domain s) = rq \<and> valid_etcbs s \<and> valid_sched_except_blocked s \<and> invs s \<and> scheduler_action s = choose_new_thread"
                               in stronger_corres_guard_imp)
                 apply (rule corres_symb_exec_l_Ex)
                 apply (clarsimp)
                 apply (rule corres_symb_exec_l_Ex)
                 apply (rule corres_symb_exec_l_Ex)
                 apply (rule corres_symb_exec_l_Ex)
                 apply (rule switch_to_thread_same_corres)
                apply clarsimp
                apply (frule_tac prio="(Max {prio. ready_queues s' (cur_domain s') prio \<noteq> []})" in schedule_choose_new_thread_helper,simp,simp,simp,simp,simp)
                apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_queues_def max_non_empty_queue_def)
                apply (auto simp: select_def gets_def get_def bind_def return_def active_tcbs_in_domain_def
                        invs_def valid_state_def valid_objs_def change_current_domain_def
                    Schedule_D.switch_to_thread_def modify_def put_def
                    option_map_def restrict_map_def map_add_def get_tcb_def
                    transform_def transform_current_thread_def cur_tcb_def tcb_at_def)[1]
               apply (clarsimp simp: invs_def valid_state_def valid_sched_def max_non_empty_queue_def)
               apply (frule_tac p="Max {prio. ready_queues s' (cur_domain s') prio \<noteq> []}" in idle_thread_not_in_queue,simp,simp)
               apply (clarsimp)
              apply (wp hoare_drop_imp| simp | clarsimp simp: valid_sched_def)+
          apply (frule max_set_not_empty, fastforce)
         apply (wp hoare_drop_imp| simp)+
    apply (clarsimp simp: valid_sched_def)
    (* dom_t = 0 *)
    apply (simp only: schedule_def_2)
    apply (rule corres_guard_imp)
      apply (rule_tac r'="\<lambda>_ _. True" and  P=\<top> and P'=\<top> and R="\<lambda>_. \<top>" and R'="\<lambda>_ s. valid_etcbs s \<and> valid_sched_except_blocked s \<and> invs s \<and> scheduler_action s = choose_new_thread" in corres_split)
         apply (clarsimp)
         apply (rule dcorres_symb_exec_r)
           apply (rule dcorres_symb_exec_r, rename_tac rq)
             apply (fold dc_def, rule dcorres_rhs_noop_below_True[OF set_scheduler_action_dcorres])
             apply (rule corres_guard_imp)

               apply (rule corres_if_rhs)
                (* No threads in ready queues *)
                apply (rule corres_alternate2)
                apply (rule switch_to_idle_thread_dcorres)
               (* threads in ready queues *)
               apply (rule corres_alternate1)
               apply (rule dcorres_symb_exec_r)
                 apply (rule dcorres_symb_exec_r)
                   apply (rule_tac P'="\<lambda>s. ready_queues s (cur_domain s) = rq \<and> valid_etcbs s \<and> valid_sched_except_blocked s \<and> invs s \<and> scheduler_action s = choose_new_thread"
                          in stronger_corres_guard_imp)
                     apply (rule corres_symb_exec_l_Ex)
                     apply (rule corres_symb_exec_l_Ex)
                     apply (rule corres_symb_exec_l_Ex)
                     apply (rule switch_to_thread_same_corres)
                    apply clarsimp
                    apply (frule_tac prio="(Max {prio. ready_queues s' (cur_domain s') prio \<noteq> []})" in schedule_choose_new_thread_helper,simp,simp,simp,simp,simp)
                    apply (clarsimp simp: invs_def valid_state_def valid_sched_def)
                    apply (auto simp: select_def gets_def get_def bind_def return_def active_tcbs_in_domain_def
                        invs_def valid_state_def valid_objs_def change_current_domain_def
                        Schedule_D.switch_to_thread_def modify_def put_def
                        option_map_def restrict_map_def map_add_def get_tcb_def
                        transform_def transform_current_thread_def cur_tcb_def tcb_at_def)[1]
                   apply (clarsimp simp: invs_def valid_state_def valid_sched_def max_non_empty_queue_def)
                   apply (frule_tac p="Max {prio. ready_queues s' (cur_domain s') prio \<noteq> []}" in idle_thread_not_in_queue,simp,simp)
                   apply (clarsimp)
                  apply (wp hoare_drop_imp | clarsimp)+
              apply (frule max_set_not_empty, fastforce)
             apply (wp hoare_drop_imp | clarsimp)+
             apply simp
            apply (wp | clarsimp)+
        apply (rule change_current_domain_dcorres)
       unfolding dc_def
       apply (wp next_domain_valid_etcbs | simp)+
    apply (wp tcb_sched_action_transform | clarsimp simp: valid_sched_def)+
  done

lemma schedule_choose_new_thread_dcorres_fragment:
  "\<And>cur_ts cur. dcorres dc \<top>
        (\<lambda>s. cur = cur_thread s \<and> st_tcb_at ((=) cur_ts) cur s \<and> valid_etcbs s \<and> valid_sched s \<and> invs s \<and> scheduler_action s = choose_new_thread)
        Schedule_D.schedule
        (do y \<leftarrow> when (runnable cur_ts) (tcb_sched_action tcb_sched_enqueue cur);
            schedule_choose_new_thread
         od)"
  apply (rule dcorres_symb_exec_r)
    apply (rule corres_guard_imp)
      apply (rule schedule_choose_new_thread_dcorres)
     apply (wp tcb_sched_action_transform| simp add: valid_sched_def st_tcb_at_def obj_at_def not_cur_thread_def| clarsimp simp: transform_def)+
  done

lemma dcorres_If_both:
  "\<lbrakk> dcorres r P P' h m ;
     dcorres r P Q' h n \<rbrakk>
  \<Longrightarrow> dcorres r P (\<lambda>s. if b then P' s else Q' s) h (if b then m else n)"
  by (case_tac b; simp)

lemma set_scheduler_action_transform:
  "\<lbrace>\<lambda>ps. transform ps = cs\<rbrace> set_scheduler_action a \<lbrace>\<lambda>r s. transform s = cs\<rbrace>"
  by (clarsimp simp: set_scheduler_action_def etcb_at_def| wp )+

crunch valid_idle_etcb[wp]: set_scheduler_action valid_idle_etcb

(* RHS copy-pasted from schedule_dcorres switch_thread case *)
lemma schedule_switch_thread_dcorres:
      "dcorres dc \<top>
        (\<lambda>s. cur = cur_thread s \<and> st_tcb_at ((=) cur_ts) cur s \<and> valid_etcbs s \<and> valid_sched s
             \<and> invs s \<and> scheduler_action s = switch_thread target)
        Schedule_D.schedule
        (do y <- when (runnable cur_ts) (tcb_sched_action tcb_sched_enqueue cur);
            it <- gets idle_thread;
            target_prio <- ethread_get tcb_priority target;
            ct_prio <- ethread_get_when (cur \<noteq> it) tcb_priority cur;
            fastfail <- schedule_switch_thread_fastfail cur it ct_prio target_prio;
            cur_dom <- gets cur_domain;
            highest <- gets (is_highest_prio cur_dom target_prio);
            if fastfail \<and> \<not> highest then do y <- tcb_sched_action tcb_sched_enqueue target;
                                            y <- set_scheduler_action choose_new_thread;
                                            schedule_choose_new_thread
                                         od
            else if runnable cur_ts \<and> ct_prio = target_prio
                 then do y <- tcb_sched_action tcb_sched_append target;
                         y <- set_scheduler_action choose_new_thread;
                         schedule_choose_new_thread
                      od
                 else do y <- guarded_switch_to target;
                         set_scheduler_action resume_cur_thread
                      od
         od)" (is "dcorres _ _ (\<lambda>s. ?PRE s) _ _")
  supply ethread_get_wp[wp del]
  apply (rule dcorres_symb_exec_r)
    apply (rule dcorres_symb_exec_r)
      apply (rule dcorres_symb_exec_r)
        apply (rule dcorres_symb_exec_r)
          apply (rule dcorres_symb_exec_r)
            apply (rule dcorres_symb_exec_r)
              apply (rule dcorres_symb_exec_r)
                apply (rule dcorres_If_both)
                 apply (rule dcorres_symb_exec_r)
                   apply (rule dcorres_symb_exec_r)
                     apply simp
                     apply (rule schedule_choose_new_thread_dcorres)
                    apply (wp set_scheduler_action_transform tcb_sched_action_transform)+
                apply (rule dcorres_If_both)
                 apply (rule dcorres_symb_exec_r)
                   apply (rule dcorres_symb_exec_r)
                     apply simp
                     apply (rule schedule_choose_new_thread_dcorres)
                    apply (wp set_scheduler_action_transform tcb_sched_action_transform)+
                apply (simp add: Schedule_D.schedule_def guarded_switch_to_def bind_assoc)
                apply (rule corres_alternate1)
                apply (rule_tac P=\<top> and P'="?PRE" in stronger_corres_guard_imp)
                  apply (rule dcorres_symb_exec_r)
                    apply (rule dcorres_symb_exec_r)
                      apply (rule dcorres_rhs_noop_below_True[OF set_scheduler_action_dcorres])
                      apply (rule corres_symb_exec_l_Ex)
                      apply (rule corres_symb_exec_l_Ex)
                      apply (rule corres_symb_exec_l_Ex)
                      apply (rule corres_symb_exec_l_Ex)
                      apply (rule switch_to_thread_same_corres)
                     apply (wpsimp wp: gts_wp hoare_drop_imp)+
                 apply (frule schedule_switch_thread_helper, simp,simp,simp)
                 apply (fastforce simp: select_def gets_def get_def bind_def return_def
                                        active_tcbs_in_domain_def invs_def valid_state_def
                                        valid_objs_def change_current_domain_def
                                        Schedule_D.switch_to_thread_def modify_def put_def
                                        option_map_def restrict_map_def map_add_def get_tcb_def
                                        transform_def transform_current_thread_def cur_tcb_def
                                        tcb_at_def)
                apply (clarsimp)
                apply (frule invs_valid_idle)
                apply (fastforce simp: pred_tcb_at_def obj_at_def valid_idle_def valid_sched_def
                                       valid_sched_action_def weak_valid_sched_action_def)
               apply (wp tcb_sched_action_transform
                         hoare_drop_imp[where f="ethread_get tcb_priority x" for x]
                         hoare_drop_imp[where f="ethread_get_when b tcb_priority t" for b t]
                         hoare_drop_imp[where f="gets cur_domain"]
                      | clarsimp simp add: schedule_switch_thread_fastfail_def
                                 split del: if_split
                      | split if_split)+
   apply (fastforce elim: st_tcb_weakenE
                    simp: valid_sched_def valid_blocked_def valid_blocked_except_def
                          not_cur_thread_def valid_sched_action_def weak_valid_sched_action_def)
  apply (wp tcb_sched_action_transform, clarsimp)
  done

(*
 * The schedulers correspond.
 *
 * Most of the difficulties in this proof arise from needing to dance
 * around differences in switching to the idle thread: The CapDL spec
 * switches to "None", while the abstract spec switches to an actual
 * thread.
 *)

lemma schedule_dcorres:
  "dcorres dc \<top> (invs and valid_sched and valid_etcbs) Schedule_D.schedule Schedule_A.schedule"
  apply (clarsimp simp: Schedule_A.schedule_def)
  apply (rule dcorres_symb_exec_r)
    apply (rename_tac cur)
    apply (rule dcorres_symb_exec_r)
      apply (rename_tac cur_ts)
      apply (rule dcorres_symb_exec_r)
        apply (rename_tac "sa", case_tac "sa")
          (* sa = resume_cur_thread *)
          apply clarsimp
          apply (rule schedule_resume_cur_thread_dcorres)
         (* sa = switch_thread *)
         apply clarsimp
         apply (rule schedule_switch_thread_dcorres)
        (* sa = choose_new_thread *)
        apply clarsimp
        apply (rule schedule_choose_new_thread_dcorres_fragment)
       apply (wp gts_st_tcb | simp )+
  done

(*
 * The next few lemmas show that updating the register NextIP in the
 * tcb context of a thread does affect the state translation to capDL
 *)
lemma get_tcb_message_info_nextPC [simp]:
  "get_tcb_message_info (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP := pc))) tcb) =
   get_tcb_message_info tcb"
  by (simp add: get_tcb_message_info_def
                arch_tcb_context_get_def
                msg_info_register_def
                ARM.msgInfoRegister_def)

lemma map_msg_registers_nextPC [simp]:
  "map ((tcb_context tcb)(NextIP := pc)) msg_registers =
   map (tcb_context tcb) msg_registers"
  by (simp add: msg_registers_def ARM.msgRegisters_def
                upto_enum_red fromEnum_def toEnum_def enum_register)

lemma get_ipc_buffer_words_nextPC [simp]:
  "get_ipc_buffer_words m (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP := pc))) tcb) =
   get_ipc_buffer_words m tcb"
  by (rule ext) (simp add: get_ipc_buffer_words_def)

lemma get_tcb_mrs_nextPC [simp]:
  "get_tcb_mrs m (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP := pc))) tcb) =
   get_tcb_mrs m tcb"
  by (simp add: get_tcb_mrs_def Let_def arch_tcb_context_get_def)

lemma transform_tcb_NextIP:
  "transform_tcb m t (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP:= pc))) tcb)
  = transform_tcb m t tcb"
  by (auto simp add: transform_tcb_def transform_full_intent_def Let_def
                     cap_register_def ARM.capRegister_def
                     arch_tcb_context_get_def)

(*
 * setNextPC in the tcb context is not observable on the capDL level.
 *)
lemma as_user_setNextPC_corres:
  "dcorres dc \<top> \<top> (return x) (as_user t (setNextPC pc))"
  apply (clarsimp simp: corres_underlying_def gets_the_def
                   as_user_def setNextPC_def get_tcb_def
                   setRegister_def simpler_modify_def
                   select_f_def return_def in_monad
                   set_object_def get_object_def
                  split: option.splits Structures_A.kernel_object.splits)
  apply (subst tcb_context_update_aux)
  apply (simp add: transform_def transform_current_thread_def)
  apply (clarsimp simp: transform_objects_update_kheap_same_caps
                        transform_tcb_NextIP transform_objects_update_same
                        arch_tcb_update_aux3)
  done

crunch transform_inv[wp]: set_thread_state_ext "\<lambda>s. transform s = cs"

lemma dcorres_dummy_set_thread_state_runnable:
  "dcorres dc \<top>
  (not_idle_thread ptr and st_tcb_at (\<lambda>t. (infer_tcb_pending_op ptr t) = (infer_tcb_pending_op ptr st)) ptr)
  (return ())
  (set_thread_state ptr st)"
  apply (rule wp_to_dcorres)
  apply (clarsimp simp:set_thread_state_def not_idle_thread_def set_object_def get_object_def | wp)+
  apply (clarsimp simp:transform_def transform_current_thread_def st_tcb_at_def obj_at_def
       | rule ext)+
  apply (clarsimp simp:transform_objects_def not_idle_thread_def dest!:get_tcb_SomeD)
  apply (case_tac "x = ptr")
   apply (clarsimp simp:transform_tcb_def)
  apply (clarsimp simp:restrict_map_def Map.map_add_def)
  done

(*
 * Activating threads is not observable on the capDL level.
 *)
lemma activate_thread_corres:
  "dcorres dc \<top> (ct_in_state activatable and invs and valid_etcbs)
  (do t \<leftarrow> gets cdl_current_thread;
      case t of Some thread \<Rightarrow> do
       restart \<leftarrow> has_restart_cap thread;
       when restart $  KHeap_D.set_cap (thread,tcb_pending_op_slot) RunningCap
      od | None \<Rightarrow> return ()
  od)
  activate_thread"
  apply (simp add: activate_thread_def has_restart_cap_def gets_def bind_assoc)
  apply (rule dcorres_absorb_get_r)
  apply (rule dcorres_absorb_get_l)
  apply (simp add:get_thread_state_def bind_assoc thread_get_def)
  apply (rule dcorres_absorb_gets_the)
  apply (case_tac "cdl_current_thread (transform s'a) = None")
   apply (clarsimp simp: ct_in_state_def pred_tcb_at_def obj_at_def
     cdl_current_thread transform_current_thread_def valid_idle_def
     arch_activate_idle_thread_def
     split : if_splits dest!:get_tcb_SomeD invs_valid_idle)
  apply clarsimp
  apply (subgoal_tac "not_idle_thread (cur_thread s'b) s'b")
   prefer 2
   apply (clarsimp simp:transform_def transform_current_thread_def)
   apply (clarsimp simp:not_idle_thread_def)+
  apply (frule(1) valid_etcbs_get_tcb_get_etcb, clarsimp)
  apply (frule opt_object_tcb)
    apply simp
   apply simp
  apply (clarsimp simp:transform_tcb_def gets_def gets_the_def has_restart_cap_def
    get_thread_def bind_assoc cdl_current_thread transform_current_thread_def)
  apply (rule dcorres_absorb_get_l)
  apply (simp add:assert_opt_def when_def)
  apply (case_tac  "tcb_state obj'")
         apply (clarsimp simp:infer_tcb_pending_op_def tcb_pending_op_slot_def tcb_boundntfn_slot_def
           when_def pred_tcb_at_def ct_in_state_def obj_at_def
           dest!:get_tcb_SomeD)+
       apply (rule corres_guard_imp)
         apply (rule dcorres_symb_exec_r)
           apply (rule dcorres_symb_exec_r)
             apply (rule set_thread_state_corres[unfolded tcb_pending_op_slot_def])
            apply simp
            apply (wpsimp wp: dcorres_to_wp[OF as_user_setNextPC_corres,simplified])+
       apply (simp add:invs_mdb pred_tcb_at_def obj_at_def invs_valid_idle
         generates_pending_def not_idle_thread_def)
      apply (clarsimp simp:infer_tcb_pending_op_def arch_activate_idle_thread_def
             when_def pred_tcb_at_def ct_in_state_def obj_at_def tcb_pending_op_slot_def tcb_boundntfn_slot_def
             dest!:get_tcb_SomeD)+
  done

end

end


(*  Title:      HOL/Auth/n_german_lemma_inv__44_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__44_on_rules imports n_german_lemma_on_inv__44
begin
section{*All lemmas on causal relation between inv__44*}
lemma lemma_inv__44_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__44  p__Inv0 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) 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__44) done
    }

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

end


theory Germany imports
  Decentralised_Model
begin

locale germany =
  fixes gen_card :: "'user \<Rightarrow> ('card \<times> 'chip) spmf"
    and auth :: "('card \<times> 'chip) \<Rightarrow> ('user, 'query_out) query \<Rightarrow> 'query_out spmf"
    and valid_user :: "'user \<Rightarrow> bool"
    and valid_query :: "('user, 'query_out) query \<Rightarrow> bool"
  assumes lossless_gen_card: "lossless_spmf (gen_card user)"
begin

definition register :: "'user \<Rightarrow> (('card \<times> 'chip) \<times> (unit, unit) govt_store_data) spmf"
  where
    "register user = do {
      (card, chip) \<leftarrow> gen_card user;
      return_spmf ((card, chip), ({}, {}))}"

sublocale germany_id: decentralised_id register auth valid_user valid_query
  unfolding decentralised_id_def by(simp add: register_def lossless_gen_card)

lemma "germany_id.perfect_sens_attrs_hiding \<A>"
proof(rule germany_id.no_sens_attrs_imp_perfect_sens_attrs_hiding)
  show " \<forall>user token store_non_sens_attr store_sens_attr. (token, store_non_sens_attr, store_sens_attr) \<in> set_spmf (register user) \<longrightarrow> store_sens_attr = {}"
    by(simp add: register_def)
qed