(*
 * 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')"
  supply option.case_cong[cong]
  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 (rule dcorres_arch_switch_to_idle_thread_return)
       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 (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 (rule dcorres_arch_switch_to_idle_thread_return)
          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 (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"
  (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)"
  supply if_cong[cong]
  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 guarded_switch_to_def bind_assoc
            choose_thread_def max_non_empty_queue_def
  supply if_cong[cong]
  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)
           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)+
    (* dom_t = 0 *)
    apply (simp only: schedule_def_2)
    apply (rule corres_guard_imp)
      apply (rule_tac 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 (rule change_current_domain_dcorres)
        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)+
       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"
  supply if_cong[cong]
  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))"
  supply option.case_cong[cong]
  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)"
  supply option.case_cong[cong] if_cong[cong]
  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