From 9da39fdb2c8d786911a6ec09a46fe894cbbe45ed Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Sat, 6 Sep 2025 14:19:10 +1000 Subject: [PATCH 01/11] arm+riscv64 infoflow: relax assumptions Remove various instances of pspace_aligned, valid_vspace_objs, and valid_arch_state from the preconditions of valid and equiv_valid predicates. Signed-off-by: Ryan Barry --- proof/infoflow/ADT_IF.thy | 12 ------------ proof/infoflow/ARM/ArchADT_IF.thy | 6 ------ proof/infoflow/Ipc_IF.thy | 9 +++------ proof/infoflow/RISCV64/ArchADT_IF.thy | 6 ------ 4 files changed, 3 insertions(+), 30 deletions(-) diff --git a/proof/infoflow/ADT_IF.thy b/proof/infoflow/ADT_IF.thy index 2de2da0253..7dca4e18cf 100644 --- a/proof/infoflow/ADT_IF.thy +++ b/proof/infoflow/ADT_IF.thy @@ -913,18 +913,6 @@ locale ADT_IF_1 = "do_user_op_if uop tc \guarded_pas_domain aag\" and tcb_arch_ref_tcb_context_set[simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set uc) tcb) = tcb_arch_ref tcb" - and arch_switch_to_idle_thread_pspace_aligned[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. pspace_aligned s\" - and arch_switch_to_idle_thread_valid_vspace_objs[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. valid_vspace_objs s\" - and arch_switch_to_idle_thread_valid_arch_state[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. valid_arch_state s\" - and arch_switch_to_thread_pspace_aligned[wp]: - "arch_switch_to_thread t \\s :: det_ext state. pspace_aligned s\" - and arch_switch_to_thread_valid_vspace_objs[wp]: - "arch_switch_to_thread t \\s :: det_ext state. valid_vspace_objs s\" - and arch_switch_to_thread_valid_arch_state[wp]: - "arch_switch_to_thread t \\s :: det_ext state. valid_arch_state s\" and arch_switch_to_thread_cur_thread[wp]: "\P. arch_switch_to_thread t \\s :: det_state. P (cur_thread s)\" and arch_activate_idle_thread_cur_thread[wp]: diff --git a/proof/infoflow/ARM/ArchADT_IF.thy b/proof/infoflow/ARM/ArchADT_IF.thy index 59e5f2dd7b..6bbf4e7fbd 100644 --- a/proof/infoflow/ARM/ArchADT_IF.thy +++ b/proof/infoflow/ARM/ArchADT_IF.thy @@ -123,12 +123,6 @@ lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" by (simp add: tcb_arch_ref_def) -crunch arch_switch_to_idle_thread, arch_switch_to_thread - for pspace_aligned[ADT_IF_assms, wp]: "\s :: det_state. pspace_aligned s" - and valid_vspace_objs[ADT_IF_assms, wp]: "\s :: det_state. valid_vspace_objs s" - and valid_arch_state[ADT_IF_assms, wp]: "\s :: det_state. valid_arch_state s" - (wp: crunch_wps) - crunch arch_activate_idle_thread, arch_switch_to_thread for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" diff --git a/proof/infoflow/Ipc_IF.thy b/proof/infoflow/Ipc_IF.thy index 852a5476c4..91fad3a76d 100644 --- a/proof/infoflow/Ipc_IF.thy +++ b/proof/infoflow/Ipc_IF.thy @@ -2049,8 +2049,7 @@ end lemma reply_from_kernel_globals_equiv: - "\globals_equiv s and valid_objs and valid_arch_state and valid_global_refs and pspace_distinct - and pspace_aligned and (\s. thread \ idle_thread s)\ + "\globals_equiv s and valid_arch_state and (\s. thread \ idle_thread s)\ reply_from_kernel thread x \\_. globals_equiv s\" unfolding reply_from_kernel_def @@ -2205,10 +2204,8 @@ lemma handle_reply_reads_respects_g: lemma reply_from_kernel_reads_respects_g: assumes domains_distinct: "pas_domains_distinct aag" shows - "reads_respects_g aag l (valid_global_objs and valid_objs and valid_arch_state - and valid_global_refs and pspace_distinct - and pspace_aligned and (\s. thread \ idle_thread s) - and K (is_subject aag thread)) + "reads_respects_g aag l (valid_arch_state and (\s. thread \ idle_thread s) + and K (is_subject aag thread)) (reply_from_kernel thread x)" apply (rule equiv_valid_guard_imp[OF reads_respects_g]) apply (rule reply_from_kernel_reads_respects[OF domains_distinct]) diff --git a/proof/infoflow/RISCV64/ArchADT_IF.thy b/proof/infoflow/RISCV64/ArchADT_IF.thy index e1bdb8cc48..db5d01afec 100644 --- a/proof/infoflow/RISCV64/ArchADT_IF.thy +++ b/proof/infoflow/RISCV64/ArchADT_IF.thy @@ -81,12 +81,6 @@ lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" by (simp add: tcb_arch_ref_def) -crunch arch_switch_to_idle_thread, arch_switch_to_thread - for pspace_aligned[ADT_IF_assms, wp]: "\s :: det_state. pspace_aligned s" - and valid_vspace_objs[ADT_IF_assms, wp]: "\s :: det_state. valid_vspace_objs s" - and valid_arch_state[ADT_IF_assms, wp]: "\s :: det_state. valid_arch_state s" - (wp: crunch_wps simp: crunch_simps) - crunch arch_activate_idle_thread, arch_switch_to_thread for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" From 4efb42d66dde997d8cb381ac598c5fc4675d0897 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Sun, 9 Nov 2025 18:02:31 +1100 Subject: [PATCH 02/11] access: strengthen domain_sep_inv When the irqs parameter is false, domain_sep_inv asserts that all non-timer IRQs must be disabled. This change asserts that the interrupt state of any non-kernel IRQ is inactive, and therefore not a timer IRQ. Signed-off-by: Ryan Barry --- proof/access-control/DomainSepInv.thy | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/proof/access-control/DomainSepInv.thy b/proof/access-control/DomainSepInv.thy index fe1c304ff3..5c7ff47291 100644 --- a/proof/access-control/DomainSepInv.thy +++ b/proof/access-control/DomainSepInv.thy @@ -30,6 +30,7 @@ definition domain_sep_inv :: "bool \ 'a :: state_ext state \ \ cte_wp_at ((=) (IRQHandlerCap irq)) slot s \ interrupt_states s irq \ IRQSignal \ interrupt_states s irq \ IRQReserved + \ (irq \ non_kernel_IRQs \ interrupt_states s irq = IRQInactive) \ interrupt_states s = interrupt_states st))" definition domain_sep_inv_cap where @@ -59,6 +60,7 @@ lemma domain_sep_inv_def2: \ \ cte_wp_at ((=) (IRQHandlerCap irq)) slot s)) \ (irqs \ (\irq. interrupt_states s irq \ IRQSignal \ interrupt_states s irq \ IRQReserved + \ (irq \ non_kernel_IRQs \ interrupt_states s irq = IRQInactive) \ interrupt_states s = interrupt_states st)))" by (fastforce simp: domain_sep_inv_def) @@ -90,7 +92,9 @@ lemma domain_sep_inv_wp: apply (rule disjI2) apply simp apply (intro allI conjI) - apply (erule_tac P1="\x. x irq \ IRQSignal" in use_valid[OF _ irq_pres], assumption) + apply (erule_tac P1="\x. x irq \ IRQSignal" in use_valid[OF _ irq_pres], assumption) + apply blast + apply (erule use_valid[OF _ irq_pres], assumption) apply blast apply (erule use_valid[OF _ irq_pres], assumption) apply blast From b6414ff3ab93200730686cd591f4f9cc4166cf89 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Sat, 6 Sep 2025 14:21:38 +1000 Subject: [PATCH 03/11] aarch64 infoflow: copy riscv64 theories Use the RISCV64 InfoFlow proofs as a basis for AARCH64. Proofs have been copied verbatim modulo renaming the architecture. Signed-off-by: Ryan Barry --- proof/infoflow/AARCH64/ArchADT_IF.thy | 331 ++ proof/infoflow/AARCH64/ArchArch_IF.thy | 1277 ++++++ proof/infoflow/AARCH64/ArchCNode_IF.thy | 147 + proof/infoflow/AARCH64/ArchDecode_IF.thy | 333 ++ proof/infoflow/AARCH64/ArchFinalCaps.thy | 329 ++ proof/infoflow/AARCH64/ArchFinalise_IF.thy | 362 ++ proof/infoflow/AARCH64/ArchIRQMasks_IF.thy | 182 + proof/infoflow/AARCH64/ArchInfoFlow.thy | 73 + proof/infoflow/AARCH64/ArchInfoFlow_IF.thy | 122 + proof/infoflow/AARCH64/ArchInterrupt_IF.thy | 55 + proof/infoflow/AARCH64/ArchIpc_IF.thy | 472 ++ .../infoflow/AARCH64/ArchNoninterference.thy | 420 ++ proof/infoflow/AARCH64/ArchPasUpdates.thy | 123 + proof/infoflow/AARCH64/ArchRetype_IF.thy | 676 +++ proof/infoflow/AARCH64/ArchScheduler_IF.thy | 401 ++ proof/infoflow/AARCH64/ArchSyscall_IF.thy | 210 + proof/infoflow/AARCH64/ArchTcb_IF.thy | 269 ++ proof/infoflow/AARCH64/ArchUserOp_IF.thy | 850 ++++ .../infoflow/AARCH64/Example_Valid_State.thy | 1942 +++++++++ .../refine/AARCH64/ArchADT_IF_Refine.thy | 398 ++ .../refine/AARCH64/ArchADT_IF_Refine_C.thy | 237 + .../refine/AARCH64/Example_Valid_StateH.thy | 3835 +++++++++++++++++ 22 files changed, 13044 insertions(+) create mode 100644 proof/infoflow/AARCH64/ArchADT_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchArch_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchCNode_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchDecode_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchFinalCaps.thy create mode 100644 proof/infoflow/AARCH64/ArchFinalise_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchIRQMasks_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchInfoFlow.thy create mode 100644 proof/infoflow/AARCH64/ArchInfoFlow_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchInterrupt_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchIpc_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchNoninterference.thy create mode 100644 proof/infoflow/AARCH64/ArchPasUpdates.thy create mode 100644 proof/infoflow/AARCH64/ArchRetype_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchScheduler_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchSyscall_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchTcb_IF.thy create mode 100644 proof/infoflow/AARCH64/ArchUserOp_IF.thy create mode 100644 proof/infoflow/AARCH64/Example_Valid_State.thy create mode 100644 proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy create mode 100644 proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy create mode 100644 proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy diff --git a/proof/infoflow/AARCH64/ArchADT_IF.thy b/proof/infoflow/AARCH64/ArchADT_IF.thy new file mode 100644 index 0000000000..3661d2d0c7 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchADT_IF.thy @@ -0,0 +1,331 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +text \ + This file sets up a kernel automaton, ADT_A_if, which is + slightly different from ADT_A. + It then setups a big step framework to transfrom this automaton in the + big step automaton on which the infoflow theorem will be proved +\ + +theory ArchADT_IF +imports ADT_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems ADT_IF_assms + +(* FIXME: clagged from AInvs.do_user_op_invs *) +lemma do_user_op_if_invs[ADT_IF_assms]: + "\invs and ct_running\ + do_user_op_if f tc + \\_. invs and ct_running\" + apply (simp add: do_user_op_if_def split_def) + apply (wp do_machine_op_ct_in_state device_update_invs | wp (once) dmo_invs | simp)+ + apply (clarsimp simp: user_mem_def user_memory_update_def simpler_modify_def restrict_map_def + invs_def cur_tcb_def ptable_rights_s_def ptable_lift_s_def) + apply (frule ptable_rights_imp_frame) + apply fastforce + apply simp + apply (clarsimp simp: valid_state_def device_frame_in_device_region) + done + +crunch do_user_op_if + for domain_sep_inv[ADT_IF_assms, wp]: "domain_sep_inv irqs st" + (ignore: user_memory_update) + +crunch do_user_op_if + for valid_sched[ADT_IF_assms, wp]: "valid_sched" + (ignore: user_memory_update) + +crunch do_user_op_if + for irq_masks[ADT_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (ignore: user_memory_update wp: dmo_wp no_irq) + +crunch do_user_op_if + for valid_list[ADT_IF_assms, wp]: "valid_list" + (ignore: user_memory_update) + +lemma do_user_op_if_scheduler_action[ADT_IF_assms, wp]: + "do_user_op_if f tc \\s. P (scheduler_action s)\" + by (simp add: do_user_op_if_def | wp | wpc)+ + +lemma do_user_op_silc_inv[ADT_IF_assms, wp]: + "do_user_op_if f tc \silc_inv aag st\" + apply (simp add: do_user_op_if_def) + apply (wp | wpc | simp)+ + done + +lemma do_user_op_pas_refined[ADT_IF_assms, wp]: + "do_user_op_if f tc \pas_refined aag\" + apply (simp add: do_user_op_if_def) + apply (wp | wpc | simp)+ + done + +crunch do_user_op_if + for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" + and cur_domain[ADT_IF_assms, wp]: "\s. P (cur_domain s)" + and idle_thread[ADT_IF_assms, wp]: "\s. P (idle_thread s)" + and domain_fields[ADT_IF_assms, wp]: "domain_fields P" + (ignore: user_memory_update) + +lemma do_use_op_guarded_pas_domain[ADT_IF_assms, wp]: + "do_user_op_if f tc \guarded_pas_domain aag\" + by (rule guarded_pas_domain_lift; wp) + +lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: + "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" + by (simp add: tcb_arch_ref_def) + +crunch arch_switch_to_idle_thread, arch_switch_to_thread + for pspace_aligned[ADT_IF_assms, wp]: "\s :: det_state. pspace_aligned s" + and valid_vspace_objs[ADT_IF_assms, wp]: "\s :: det_state. valid_vspace_objs s" + and valid_arch_state[ADT_IF_assms, wp]: "\s :: det_state. valid_arch_state s" + (wp: crunch_wps simp: crunch_simps) + +crunch arch_activate_idle_thread, arch_switch_to_thread + for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" + +lemma arch_activate_idle_thread_scheduler_action[ADT_IF_assms, wp]: + "arch_activate_idle_thread t \\s :: det_state. P (scheduler_action s)\" + by (wpsimp simp: arch_activate_idle_thread_def) + +crunch handle_vm_fault, handle_hypervisor_fault + for domain_fields[ADT_IF_assms, wp]: "domain_fields P" + +lemma arch_perform_invocation_noErr[ADT_IF_assms, wp]: + "\\\ arch_perform_invocation a -, \Q\" + by (wpsimp simp: arch_perform_invocation_def) + +lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: + "\\\ arch_invoke_irq_control a -, \Q\" + by (cases a; wpsimp) + +lemma getActiveIRQ_None[ADT_IF_assms]: + "(None,s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) \ + irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" + apply (erule use_valid) + apply (wp dmo_getActiveIRQ_wp) + by simp + +lemma getActiveIRQ_Some[ADT_IF_assms]: + "(Some i, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" + apply (erule use_valid) + apply (wp dmo_getActiveIRQ_wp) + by simp + +lemma idle_equiv_as_globals_equiv: + "arm_us_global_vspace (arch_state s) \ idle_thread s + \ idle_equiv st s = + globals_equiv (st\arch_state := arch_state s, machine_state := machine_state s, + kheap:= (kheap st)(arm_us_global_vspace (arch_state s) := + kheap s (arm_us_global_vspace (arch_state s))), + cur_thread := cur_thread s\) s" + by (clarsimp simp: idle_equiv_def globals_equiv_def tcb_at_def2) + +lemma idle_globals_lift: + assumes g: "\st. \globals_equiv st and P\ f \\_. globals_equiv st\" + assumes i: "\s. P s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + shows "\idle_equiv st and P\ f \\_. idle_equiv st\" + apply (clarsimp simp: valid_def) + apply (subgoal_tac "arm_us_global_vspace (arch_state s) \ idle_thread s") + apply (subst (asm) idle_equiv_as_globals_equiv,simp+) + apply (frule use_valid[OF _ g]) + apply simp+ + apply (clarsimp simp: idle_equiv_def globals_equiv_def tcb_at_def2) + apply (erule i) + done + +lemma idle_equiv_as_globals_equiv_scheduler: + "arm_us_global_vspace (arch_state s) \ idle_thread s + \ idle_equiv st s = + globals_equiv_scheduler (st\arch_state := arch_state s, machine_state := machine_state s, + kheap:= (kheap st)(arm_us_global_vspace (arch_state s) := + kheap s (arm_us_global_vspace (arch_state s)))\) s" + by (clarsimp simp: idle_equiv_def tcb_at_def2 globals_equiv_scheduler_def + arch_globals_equiv_scheduler_def) + +lemma idle_globals_lift_scheduler: + assumes g: "\st. \globals_equiv_scheduler st and P\ f \\_. globals_equiv_scheduler st\" + assumes i: "\s. P s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + shows "\idle_equiv st and P\ f \\_. idle_equiv st\" + apply (clarsimp simp: valid_def) + apply (subgoal_tac "arm_us_global_vspace (arch_state s) \ idle_thread s") + apply (subst (asm) idle_equiv_as_globals_equiv_scheduler,simp+) + apply (frule use_valid[OF _ g]) + apply simp+ + apply (clarsimp simp: idle_equiv_def globals_equiv_scheduler_def tcb_at_def2) + apply (erule i) + done + +lemma invs_pt_not_idle_thread[intro]: + "invs s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + by (fastforce dest: valid_global_arch_objs_pt_at + simp: invs_def valid_state_def valid_arch_state_def valid_global_objs_def + obj_at_def valid_idle_def pred_tcb_at_def empty_table_def) + +lemma kernel_entry_if_idle_equiv[ADT_IF_assms]: + "\invs and (\s. e \ Interrupt \ ct_active s) and idle_equiv st + and (\s. ct_idle s \ tc = idle_context s)\ + kernel_entry_if e tc + \\_. idle_equiv st\" + apply (rule hoare_pre) + apply (rule idle_globals_lift) + apply (wp kernel_entry_if_globals_equiv) + apply force + apply (fastforce intro!: invs_pt_not_idle_thread)+ + done + +lemmas handle_preemption_idle_equiv[ADT_IF_assms, wp] = + idle_globals_lift[OF handle_preemption_globals_equiv invs_pt_not_idle_thread, simplified] + +lemmas schedule_if_idle_equiv[ADT_IF_assms, wp] = + idle_globals_lift_scheduler[OF schedule_if_globals_equiv_scheduler invs_pt_not_idle_thread, simplified] + +lemma do_user_op_if_idle_equiv[ADT_IF_assms, wp]: + "\idle_equiv st and invs\ + do_user_op_if uop tc + \\_. idle_equiv st\" + unfolding do_user_op_if_def + by (wpsimp wp: dmo_user_memory_update_idle_equiv dmo_device_memory_update_idle_equiv) + +lemma kernel_entry_if_valid_vspace_objs_if[ADT_IF_assms, wp]: + "\valid_vspace_objs_if and invs and (\s. e \ Interrupt \ ct_active s)\ + kernel_entry_if e tc + \\_. valid_vspace_objs_if\" + by wpsimp + +lemma handle_preemption_if_valid_pdpt_objs[ADT_IF_assms, wp]: + "\valid_vspace_objs_if\ handle_preemption_if a \\rv s. valid_vspace_objs_if s\" + by wpsimp + +lemma schedule_if_valid_pdpt_objs[ADT_IF_assms, wp]: + "\valid_vspace_objs_if\ schedule_if a \\rv s. valid_vspace_objs_if s\" + by wpsimp + +lemma do_user_op_if_valid_pdpt_objs[ADT_IF_assms, wp]: + "\valid_vspace_objs_if\ do_user_op_if a b \\rv s. valid_vspace_objs_if s\" + by wpsimp + +lemma valid_vspace_objs_if_ms_update[ADT_IF_assms, simp]: + "valid_vspace_objs_if (machine_state_update f s) = valid_vspace_objs_if s" + by simp + +lemma do_user_op_if_irq_state_of_state[ADT_IF_assms]: + "do_user_op_if utf uc \\s. P (irq_state_of_state s)\" + apply (rule hoare_pre) + apply (simp add: do_user_op_if_def user_memory_update_def | wp dmo_wp | wpc)+ + done + +lemma do_user_op_if_irq_masks_of_state[ADT_IF_assms]: + "do_user_op_if utf uc \\s. P (irq_masks_of_state s)\" + apply (rule hoare_pre) + apply (simp add: do_user_op_if_def user_memory_update_def | wp dmo_wp | wpc)+ + done + +lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: + "do_user_op_if utf uc \\s. P (irq_measure_if s)\" + apply (rule hoare_pre) + apply (simp add: do_user_op_if_def user_memory_update_def irq_measure_if_def + | wps |wp dmo_wp | wpc)+ + done + +crunch set_flags + for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" + +lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: + "\(\s. irq_state_inv st s) and domain_sep_inv False sta + and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ + invoke_tcb tinv + \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" + apply (case_tac tinv) + apply ((wp hoare_vcg_if_lift mapM_x_wp[OF _ subset_refl] + | wpc + | simp split del: if_split add: check_cap_at_def + | clarsimp + | wp (once) irq_state_inv_triv)+)[3] + defer + apply ((wp irq_state_inv_triv | simp)+)[2] + apply (simp add: split_def cong: option.case_cong) + by (wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + checked_cap_insert_domain_sep_inv cap_delete_deletes + cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] + cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] + cap_delete_valid_cap cap_delete_cte_at + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def + tcb_at_st_tcb_at option_update_thread_def + | strengthen use_no_cap_to_obj_asid_strg + | wp (once) irq_state_inv_triv hoare_drop_imps + | clarsimp split: option.splits | intro impI conjI allI)+ + +lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: + "\irq_state_inv st and K (irq_is_recurring irq st)\ + reset_untyped_cap slot + \\y. irq_state_inv st\, \\y. irq_state_next st\" + apply (cases "irq_is_recurring irq st", simp_all) + apply (simp add: reset_untyped_cap_def) + apply (rule hoare_pre) + apply (wp no_irq_clearMemory mapME_x_wp' hoare_vcg_const_imp_lift + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp)+ + done + +crunch + handle_vm_fault, handle_hypervisor_fault + for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp simp: crunch_simps) + +text \Not true of invoke_untyped any more.\ +crunch create_cap + for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (ignore: freeMemory + wp: dmo_wp modify_wp crunch_wps + simp: freeMemory_def storeWord_def clearMemory_def + machine_op_lift_def machine_rest_lift_def mapM_x_defsym) + +crunch arch_invoke_irq_control + for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: dmo_wp crunch_wps simp: setIRQTrigger_def machine_op_lift_def machine_rest_lift_def) + +lemma handle_reserved_irq_non_kernel_IRQs[ADT_IF_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + by (wpsimp simp: handle_reserved_irq_def) + +lemma thread_set_pas_refined[ADT_IF_assms]: + assumes cps: "\tcb. \(getF, v)\ran tcb_cap_cases. getF (f tcb) = getF tcb" + and st: "\tcb. tcb_state (f tcb) = tcb_state tcb" + and ntfn: "\tcb. tcb_bound_notification (f tcb) = tcb_bound_notification tcb" + and dom: "\tcb. tcb_domain (f tcb) = tcb_domain tcb" + shows "thread_set f t \pas_refined aag\" + by (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_state_vrefs thread_set_edomains[OF dom] + simp: pas_refined_def state_objs_to_policy_def + | wps thread_set_caps_of_state_trivial[OF cps] + thread_set_thread_st_auth_trivT[OF st] + thread_set_thread_bound_ntfns_trivT[OF ntfn])+ + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms | wp init_arch_objects_inv)?) +qed + +sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. + + +hide_fact ADT_IF_1.do_user_op_silc_inv +requalify_facts AARCH64.do_user_op_silc_inv +declare do_user_op_silc_inv[wp] + +end diff --git a/proof/infoflow/AARCH64/ArchArch_IF.thy b/proof/infoflow/AARCH64/ArchArch_IF.thy new file mode 100644 index 0000000000..bf70ea7386 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchArch_IF.thy @@ -0,0 +1,1277 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchArch_IF +imports Arch_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Arch_IF_assms + +(* we need to know we're not doing an asid pool update, or else this could affect + what some other domain sees *) +lemma set_object_equiv_but_for_labels: + "\equiv_but_for_labels aag L st and (\ s. \ asid_pool_at ptr s) and + K ((\asid_pool. obj \ ArchObj (ASIDPool asid_pool)) \ pasObjectAbs aag ptr \ L)\ + set_object ptr obj + \\_. equiv_but_for_labels aag L st\" + apply (wpsimp wp: set_object_wp) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (subst dummy_kheap_update[where st=st]) + apply (rule states_equiv_for_non_asid_pool_kheap_update) + apply assumption + apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forE) + apply (fastforce simp: non_asid_pool_kheap_update_def) + apply (clarsimp simp: non_asid_pool_kheap_update_def asid_pool_at_kheap) + done + +lemma get_tcb_not_asid_pool_at: + "get_tcb ref s = Some y \ \ asid_pool_at ref s" + by (fastforce simp: get_tcb_def asid_pool_at_kheap) + +lemma as_user_set_register_ev2: + assumes domains_distinct: "pas_domains_distinct aag" + shows "labels_are_invisible aag l (pasObjectAbs aag ` {thread,thread'}) + \ equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) (=) \ \ + (as_user thread (setRegister x y)) (as_user thread' (setRegister a b))" + apply (simp add: as_user_def) + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac L="{pasObjectAbs aag thread}" and L'="{pasObjectAbs aag thread'}" + and Q="\" and Q'="\" in ev2_invisible[OF domains_distinct]) + apply (simp add: labels_are_invisible_def)+ + apply ((rule modifies_at_mostI + | wp set_object_equiv_but_for_labels + | simp add: split_def + | fastforce dest: get_tcb_not_asid_pool_at)+)[2] + apply auto + done + +crunch arch_post_cap_deletion + for valid_global_refs[Arch_IF_assms, wp]: "valid_global_refs" + +crunch store_word_offs + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp simp: storeWord_def) + +crunch set_irq_state, arch_post_cap_deletion, handle_arch_fault_reply + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp simp: crunch_simps maskInterrupt_def) + +crunch arch_switch_to_idle_thread, arch_switch_to_thread + for irq_state_of_state[Arch_IF_assms, wp]: "\s :: det_state. P (irq_state_of_state s)" + (wp: dmo_wp modify_wp crunch_wps whenE_wp + simp: machine_op_lift_def setVSpaceRoot_def + machine_rest_lift_def crunch_simps storeWord_def) + +crunch arch_invoke_irq_handler + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: dmo_wp simp: maskInterrupt_def plic_complete_claim_def) + +crunch arch_perform_invocation + for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" + (wp: dmo_wp modify_wp simp: cache_machine_op_defs + wp: crunch_wps simp: crunch_simps ignore: ignore_failure) + +crunch arch_finalise_cap, prepare_thread_delete + for irq_state_of_state[Arch_IF_assms, wp]: "\s :: det_state. P (irq_state_of_state s)" + (wp: modify_wp crunch_wps dmo_wp + simp: crunch_simps hwASIDFlush_def) + +lemma equiv_asid_machine_state_update[Arch_IF_assms, simp]: + "equiv_asid asid (machine_state_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (machine_state_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma as_user_set_register_reads_respects'[Arch_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l \ (as_user thread (setRegister x y))" + apply (case_tac "aag_can_read aag thread \ aag_can_affect aag l thread") + apply (simp add: as_user_def split_def) + apply (rule gen_asm_ev) + apply (wp set_object_reads_respects select_f_ev gets_the_ev) + apply (auto intro: reads_affects_equiv_get_tcb_eq det_setRegister)[1] + apply (simp add: equiv_valid_def2) + apply (rule as_user_set_register_ev2[OF domains_distinct]) + apply (simp add: labels_are_invisible_def) + done + +lemma store_word_offs_reads_respects[Arch_IF_assms]: + "reads_respects aag l \ (store_word_offs ptr offs v)" + apply (simp add: store_word_offs_def) + apply (rule equiv_valid_get_assert) + apply (simp add: storeWord_def) + apply (simp add: do_machine_op_bind) + apply wp + apply (rule use_spec_ev) + apply (rule do_machine_op_spec_reads_respects) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad) + apply (fastforce intro: equiv_forI elim: equiv_forE simp: upto.simps comp_def) + apply (rule use_spec_ev do_machine_op_spec_reads_respects assert_ev2 + | simp add: spec_equiv_valid_def | wp modify_wp)+ + done + +lemma set_simple_ko_globals_equiv[Arch_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_simple_ko f ptr ep + \\_. globals_equiv s\" + unfolding set_simple_ko_def + apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] get_object_wp + simp: partial_inv_def)+ + apply (fastforce simp: obj_at_def valid_arch_state_def dest: valid_global_arch_objs_pt_at) + done + +crunch set_thread_state_act + for globals_equiv[wp]: "globals_equiv s" + +lemma set_thread_state_globals_equiv[Arch_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_thread_state ref ts + \\_. globals_equiv s\" + unfolding set_thread_state_def + apply (wp set_object_globals_equiv |simp)+ + apply (intro impI conjI allI) + apply (fastforce simp: valid_arch_state_def obj_at_def tcb_at_def2 get_tcb_def is_tcb_def + dest: get_tcb_SomeD valid_global_arch_objs_pt_at + split: option.splits kernel_object.splits)+ + done + +lemma set_cap_globals_equiv''[Arch_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_cap cap p + \\_. globals_equiv s\" + unfolding set_cap_def + apply (simp only: split_def) + apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def + dest: valid_global_arch_objs_pt_at)+ + done + +lemma as_user_globals_equiv[Arch_IF_assms]: + "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ + as_user tptr f + \\_. globals_equiv s\" + unfolding as_user_def + apply (wpsimp wp: set_object_globals_equiv simp: split_def) + apply (fastforce simp: valid_arch_state_def get_tcb_def obj_at_def + dest: valid_global_arch_objs_pt_at) + done + +declare arch_prepare_set_domain_inv[Arch_IF_assms] +declare arch_prepare_next_domain_inv[Arch_IF_assms] + +end + + +requalify_facts + AARCH64.set_simple_ko_globals_equiv + AARCH64.retype_region_irq_state_of_state + AARCH64.arch_perform_invocation_irq_state_of_state + +declare + retype_region_irq_state_of_state[wp] + arch_perform_invocation_irq_state_of_state[wp] + + +global_interpretation Arch_IF_1?: Arch_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Arch_IF_assms)?) +qed + + +lemmas invs_imps = + invs_sym_refs invs_psp_aligned invs_distinct invs_arch_state + invs_valid_global_objs invs_arch_state invs_valid_objs invs_valid_global_refs tcb_at_invs + invs_cur invs_kernel_mappings + + +context Arch begin global_naming AARCH64 + +lemma get_asid_pool_revrv': + "reads_equiv_valid_rv_inv (affects_equiv aag l) aag + (\rv rv'. aag_can_read aag ptr \ rv = rv') \ (get_asid_pool ptr)" + unfolding gets_map_def + apply (subst gets_apply) + apply (subst gets_apply) + apply (rule_tac W="\rv rv'. aag_can_read aag ptr \ rv = rv'" in equiv_valid_rv_bind) + apply (fastforce elim: reads_equivE equiv_forE + simp: equiv_valid_2_def opt_map_def gets_apply_def get_def bind_def return_def) + apply (fastforce simp: equiv_valid_2_def return_def assert_opt_def fail_def split: option.splits) + apply wp + done + +lemma get_asid_pool_rev: + "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_asid_pool ptr)" + unfolding gets_map_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma get_asid_pool_revrv: + "reads_equiv_valid_rv_inv (affects_equiv aag l) aag + (\rv rv'. rv (asid_low_bits_of asid) = rv' (asid_low_bits_of asid)) + (\s. Some a = arm_asid_table (arch_state s) (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0) + (get_asid_pool a)" + unfolding gets_map_def assert_opt_def2 + apply (rule equiv_valid_rv_guard_imp) + apply (rule_tac R'="\rv rv'. \p p'. rv a = Some p \ rv' a = Some p' + \ p (asid_low_bits_of asid) = p' (asid_low_bits_of asid)" + and P="\s. Some a = arm_asid_table (arch_state s) (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0" + and P'="\s. Some a = arm_asid_table (arch_state s) (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0" + in equiv_valid_2_bind) + apply (clarsimp simp: equiv_valid_2_def assert_def bind_def return_def fail_def + split: if_split) + apply (clarsimp simp: equiv_valid_2_def gets_def get_def bind_def return_def fail_def + split: if_split) + apply (drule_tac s="Some a" in sym) + apply (fastforce elim: reads_equivE simp: equiv_asids_def equiv_asid_def) + apply (wp wp_post_taut | simp)+ + done + +lemma asid_high_bits_0_eq_1: + "asid_high_bits_of 0 = asid_high_bits_of 1" + by (auto simp: asid_high_bits_of_def asid_low_bits_def) + +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq: + "\ is_subject_asid aag asid; reads_equiv aag s t; asid \ 0 \ + \ arm_asid_table (arch_state s) (asid_high_bits_of asid) = + arm_asid_table (arch_state t) (asid_high_bits_of asid)" + apply (erule reads_equivE) + apply (fastforce simp: equiv_asids_def equiv_asid_def intro: aag_can_read_own_asids) + done + +lemma set_vm_root_states_equiv_for[wp]: + "set_vm_root thread \states_equiv_for P Q R S st\" + unfolding set_vm_root_def catch_def fun_app_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for + hoare_vcg_all_lift whenE_wp hoare_drop_imps + simp: setVSpaceRoot_def dmo_bind_valid if_apply_def2)+ + +lemma find_vspace_for_asid_reads_respects: + "reads_respects aag l (K (asid \ 0 \ aag_can_read_asid aag asid)) (find_vspace_for_asid asid)" + unfolding find_vspace_for_asid_def + apply wpsimp + apply (simp add: throw_opt_def) + apply wpsimp + apply wpsimp+ + apply (erule reads_equivE) + apply (clarsimp simp: equiv_asids_def) + apply (erule equiv_forE) + apply (erule_tac x=asid in allE) + apply clarsimp + apply (fastforce simp: vspace_for_asid_def pool_for_asid_def vspace_for_pool_def + opt_map_def obind_def obj_at_def equiv_asid_def + split: option.splits) + done + +lemma ptes_of_reads_equiv: + "\ is_subject aag (table_base ptr); reads_equiv aag s t \ + \ ptes_of s ptr = ptes_of t ptr" + by (fastforce elim: reads_equivE equiv_forE simp: ptes_of_def obind_def opt_map_def) + +lemma pt_walk_reads_equiv: + "\ reads_equiv aag s t; pas_refined aag s; pspace_aligned s; valid_asid_table s; + valid_vspace_objs s; is_subject aag pt; vptr \ user_region; + level \ max_pt_level; vs_lookup_table level asid vptr s = Some (level, pt) \ + \ pt_walk level bot_level pt vptr (ptes_of s) = + pt_walk level bot_level pt vptr (ptes_of t)" + apply (induct level arbitrary: pt; clarsimp) + apply (simp (no_asm) add: pt_walk.simps) + apply (clarsimp simp: obind_def split: if_splits) + apply (subgoal_tac "ptes_of s (pt_slot_offset level pt vptr) = + ptes_of t (pt_slot_offset level pt vptr)") + apply (clarsimp split: option.splits) + apply (frule_tac bot_level="level-1" in vs_lookup_table_extend) + apply (fastforce simp: pt_walk.simps obind_def) + apply clarsimp + apply (erule_tac x="pptr_from_pte x2" in meta_allE) + apply (drule meta_mp) + apply (subst (asm) vs_lookup_split_Some[OF order_less_imp_le[OF bit0.pred]]) + apply fastforce+ + apply (erule_tac pt_ptr=pt in pt_walk_is_subject; fastforce) + apply (erule (1) meta_mp) + apply (rule ptes_of_reads_equiv) + apply (subst table_base_pt_slot_offset) + apply (erule vs_lookup_table_is_aligned) + by fastforce+ + +lemma pt_lookup_from_level_reads_respects: + "reads_respects aag l + (\s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ + is_subject aag pt \ level \ max_pt_level \ vref \ user_region \ + (\asid. vs_lookup_table level asid vref s = Some (level, pt))) + (pt_lookup_from_level level pt vref target_pt)" + apply (induct level arbitrary: pt) + apply (simp add: pt_lookup_from_level_simps) + apply wp + apply (simp (no_asm) add: pt_lookup_from_level_simps unlessE_def) + apply clarsimp + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: get_pte_rev | assumption)+ + apply (frule vs_lookup_table_is_aligned; clarsimp) + apply (prop_tac "pt_walk level (level - 1) pt vref (ptes_of s) = + Some (level - 1, pptr_from_pte rv)") + apply (fastforce simp: vs_lookup_split_Some[OF order_less_imp_le[OF bit0.pred]] + pt_walk.simps obind_def) + apply (rule conjI) + apply (erule_tac level=level and bot_level="level-1" and pt_ptr=pt in pt_walk_is_subject; fastforce) + apply (rule_tac x=asid in exI) + apply (erule (2) vs_lookup_table_extend) + done + +lemma unmap_page_table_reads_respects: + "reads_respects aag l + (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table + and K (asid \ 0 \ is_subject_asid aag asid \ vaddr \ user_region)) + (unmap_page_table asid vaddr pt)" + unfolding unmap_page_table_def fun_app_def + apply (rule gen_asm_ev) + apply (rule equiv_valid_guard_imp) + apply (wp dmo_mol_reads_respects store_pte_reads_respects get_pte_rev + pt_lookup_from_level_reads_respects pt_lookup_from_level_is_subject + find_vspace_for_asid_wp find_vspace_for_asid_reads_respects hoare_vcg_all_liftE_R + | wpc | simp add: sfence_def | wp (once) hoare_drop_imps)+ + apply clarsimp + apply (frule vspace_for_asid_is_subject) + apply (fastforce dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent)+ + done + +lemma perform_page_table_invocation_reads_respects: + "reads_respects aag l (pas_refined aag and pspace_aligned and valid_objs and valid_vspace_objs + and valid_asid_table and valid_pti pti + and K (authorised_page_table_inv aag pti)) + (perform_page_table_invocation pti)" + unfolding perform_page_table_invocation_def perform_pt_inv_map_def perform_pt_inv_unmap_def + apply (rule equiv_valid_guard_imp) + apply (wp dmo_mol_reads_respects store_pte_reads_respects set_cap_reads_respects mapM_x_ev'' + unmap_page_table_reads_respects get_cap_rev + | wpc | simp add: sfence_def)+ + apply (case_tac pti; clarsimp simp: authorised_page_table_inv_def) + apply (clarsimp simp: valid_pti_def) + apply (frule cte_wp_valid_cap) + apply fastforce + apply (clarsimp simp: is_PageTableCap_def valid_cap_def wellformed_mapdata_def) + done + +lemma unmap_page_reads_respects: + "reads_respects aag l + (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table + and K (asid \ 0 \ is_subject_asid aag asid \ vptr \ user_region)) + (unmap_page pgsz asid vptr pptr)" + unfolding unmap_page_def catch_def fun_app_def + supply gets_the_ev[wp del] + apply (simp add: unmap_page_def swp_def cong: vmpage_size.case_cong) + apply (simp add: unlessE_def gets_the_def) + apply (wp gets_ev' dmo_mol_reads_respects get_pte_rev throw_on_false_reads_respects + find_vspace_for_asid_reads_respects store_pte_reads_respects[simplified] + | wpc | wp (once) hoare_drop_imps | simp add: sfence_def is_aligned_mask[symmetric])+ + apply (clarsimp simp: pt_lookup_slot_def) + apply (frule (3) vspace_for_asid_is_subject) + apply safe + apply (frule vspace_for_asid_vs_lookup) + apply (frule (6) pt_walk_reads_equiv[where bot_level=0]) + apply (rule order_refl) + apply (erule vs_lookup_table_vref_independent[OF _ order_refl]) + apply (clarsimp simp: pt_lookup_slot_from_level_def obind_def split: option.splits) + apply (fastforce elim!: pt_lookup_slot_from_level_is_subject + dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent)+ + done + +lemma perform_page_invocation_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag l (pas_refined aag and authorised_page_inv aag pgi and valid_page_inv pgi + and valid_vspace_objs and valid_asid_table + and pspace_aligned and is_subject aag \ cur_thread) + (perform_page_invocation pgi)" + unfolding perform_page_invocation_def fun_app_def when_def perform_pg_inv_map_def + perform_pg_inv_unmap_def perform_pg_inv_get_addr_def + apply (rule equiv_valid_guard_imp) + apply (wp dmo_mol_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects + mapM_ev'' store_pte_reads_respects unmap_page_reads_respects dmo_mol_2_reads_respects + get_cap_rev set_mrs_reads_respects set_message_info_reads_respects + | simp add: sfence_def + | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ + apply (clarsimp simp: authorised_page_inv_def valid_page_inv_def) + apply (auto simp: cte_wp_at_caps_of_state authorised_slots_def cap_links_asid_slot_def + label_owns_asid_slot_def valid_arch_cap_def wellformed_mapdata_def + dest!: clas_caps_of_state pas_refined_Control)+ + done + +lemma equiv_asids_arm_asid_table_update: + "\ equiv_asids R s t; kheap s pool_ptr = kheap t pool_ptr \ + \ equiv_asids R + (s\arch_state := arch_state s\arm_asid_table := (asid_table s) + (asid_high_bits_of asid \ pool_ptr)\\) + (t\arch_state := arch_state t\arm_asid_table := (asid_table t) + (asid_high_bits_of asid \ pool_ptr)\\)" + by (clarsimp simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap opt_map_def) + +lemma arm_asid_table_update_reads_respects: + "reads_respects aag l (K (is_subject aag pool_ptr)) + (do r \ gets (arm_asid_table \ arch_state); + modify (\s. s\arch_state := + arch_state s\arm_asid_table := r(asid_high_bits_of asid \ pool_ptr)\\) + od)" + apply (simp add: equiv_valid_def2) + apply (rule_tac W="\\" + and Q="\rv s. is_subject aag pool_ptr \ rv = arm_asid_table (arch_state s)" + in equiv_valid_rv_bind) + apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) + apply wpsimp+ + apply (rule modify_ev2) + apply clarsimp + apply (drule (1) is_subject_kheap_eq[rotated]) + apply (fastforce simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def + intro!: equiv_asids_arm_asid_table_update) + apply wpsimp + done + +lemma perform_asid_control_invocation_reads_respects: + notes K_bind_ev[wp del] + shows "reads_respects aag l (K (authorised_asid_control_inv aag aci)) + (perform_asid_control_invocation aci)" + unfolding perform_asid_control_invocation_def + apply (rule gen_asm_ev) + apply (rule equiv_valid_guard_imp) + (* we do some hacky rewriting here to separate out the bit that does interesting stuff from the rest *) + apply (subst (6) my_bind_rewrite_lemma) + apply (subst (1) bind_assoc[symmetric]) + apply (subst another_hacky_rewrite) + apply (subst another_hacky_rewrite) + apply (wpc) + apply (rule bind_ev) + apply (rule K_bind_ev) + apply (rule_tac P'=\ in bind_ev) + apply (rule K_bind_ev) + apply (rule bind_ev) + apply (rule bind_ev) + apply (rule return_ev) + apply (rule K_bind_ev) + apply simp + apply (rule arm_asid_table_update_reads_respects) + apply (wp cap_insert_reads_respects retype_region_reads_respects + set_cap_reads_respects delete_objects_reads_respects get_cap_rev + | simp add: authorised_asid_control_inv_def)+ + apply (auto dest!: is_aligned_no_overflow) + done + +lemma set_asid_pool_reads_respects: + "reads_respects aag l (K (is_subject aag ptr)) (set_asid_pool ptr pool)" + unfolding set_asid_pool_def + by (wpsimp wp: set_object_reads_respects get_asid_pool_rev) + +lemma copy_global_mappings_valid_arch_state: + "\valid_arch_state and valid_global_vspace_mappings and pspace_aligned + and (\s. x \ global_refs s \ is_aligned x pt_bits)\ + copy_global_mappings x + \\_. valid_arch_state\" + unfolding copy_global_mappings_def including classic_wp_pre + apply simp + apply wp + apply (rule_tac Q'="\_. valid_arch_state and valid_global_vspace_mappings and pspace_aligned + and (\s. x \ global_refs s \ is_aligned x pt_bits)" + in hoare_strengthen_post) + apply (wp mapM_x_wp[OF _ subset_refl] + store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings) + apply (simp only: pt_index_def) + apply (subst table_base_offset_id) + apply clarsimp + apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def + table_size_def ptTranslationBits_def mask_def) + apply (word_bitwise, fastforce) + apply clarsimp + apply (simp_all) + apply (clarsimp simp: valid_arch_state_def) + apply (subst (asm) table_base_plus; simp add: mask_def) + done + +lemma set_asid_pool_globals_equiv: + "\globals_equiv s and valid_arch_state\ + set_asid_pool ptr pool + \\_. globals_equiv s\" + unfolding set_asid_pool_def + apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] simp: a_type_def) + apply (fastforce simp: valid_arch_state_def obj_at_def dest: valid_global_arch_objs_pt_at) + done + +lemma perform_asid_pool_invocation_reads_respects_g: + "reads_respects_g aag l (pas_refined aag and invs and K (authorised_asid_pool_inv aag api)) + (perform_asid_pool_invocation api)" + unfolding perform_asid_pool_invocation_def store_asid_pool_entry_def + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: reads_respects_g[OF set_asid_pool_reads_respects] + reads_respects_g[OF get_asid_pool_rev] + set_asid_pool_globals_equiv set_cap_reads_respects + doesnt_touch_globalsI get_cap_auth_wp[where aag=aag] get_cap_rev + copy_global_mappings_reads_respects_g copy_global_mappings_valid_arch_state + set_cap_reads_respects_g get_cap_reads_respects_g + | strengthen valid_arch_state_global_arch_objs + | wp (once) hoare_drop_imps)+ + apply (clarsimp simp: invs_arch_state invs_valid_global_objs invs_psp_aligned + invs_valid_global_vspace_mappings authorised_asid_pool_inv_def + cong: conj_cong) + apply (frule (1) caps_of_state_valid) + apply (clarsimp simp: is_ArchObjectCap_def is_PageTableCap_def + valid_cap_def cap_aligned_def pt_bits_def aag_cap_auth_def + cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply (fastforce dest: pas_refined_Control cap_not_in_valid_global_refs) + done + +lemma equiv_asids_arm_asid_table_delete: + "equiv_asids R s t + \ equiv_asids R + (s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of asid then None + else arm_asid_table (arch_state s) a\\) + (t\arch_state := arch_state t\arm_asid_table := \a. if a = asid_high_bits_of asid then None + else arm_asid_table (arch_state t) a\\)" + by (clarsimp simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap) + +lemma arm_asid_table_delete_ev2: + "equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) \\ + (\s. rv = arm_asid_table (arch_state s)) (\s. rv' = arm_asid_table (arch_state s)) + (modify (\s. s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of base + then None + else rv a\\)) + (modify (\s. s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of base + then None + else rv' a\\))" + apply (rule modify_ev2) + (* slow 15s *) + by (auto simp: reads_equiv_def2 affects_equiv_def2 + intro!: states_equiv_forI equiv_forI equiv_asids_arm_asid_table_delete + elim!: states_equiv_forE equiv_forE + elim: is_subject_kheap_eq[simplified reads_equiv_def2 states_equiv_for_def, rotated]) + + +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': + "\ (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base + \ is_subject_asid aag asid'); reads_equiv aag s t \ + \ arm_asid_table (arch_state s) (asid_high_bits_of base) = + arm_asid_table (arch_state t) (asid_high_bits_of base)" + apply (insert asid_high_bits_0_eq_1) + apply (case_tac "base = 0") + apply (subgoal_tac "is_subject_asid aag 1") + apply simp + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq[where aag=aag]) + apply (erule_tac x=1 in allE) + apply simp+ + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq[where aag=aag]) + apply (erule_tac x=base in allE) + apply simp+ + done + +lemma delete_asid_pool_reads_respects: + "reads_respects aag l (K (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base + \ is_subject_asid aag asid')) + (delete_asid_pool base ptr)" + unfolding delete_asid_pool_def + apply (rule equiv_valid_guard_imp) + apply (rule bind_ev) + apply (simp) + apply (subst equiv_valid_def2) + apply (rule_tac W="\\" + and Q="\rv s. rv = arm_asid_table (arch_state s) \ + (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base + \ is_subject_asid aag asid')" + in equiv_valid_rv_bind) + apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) + apply (wp, simp) + apply (simp add: when_def) + apply (clarsimp | rule conjI)+ + apply (rule equiv_valid_2_guard_imp) + apply (rule equiv_valid_2_bind) + apply (rule equiv_valid_2_bind) + apply (rule equiv_valid_2_unobservable) + apply (wp set_vm_root_states_equiv_for)+ + apply (rule arm_asid_table_delete_ev2) + apply (wp)+ + apply (rule equiv_valid_2_unobservable) + by (wp mapM_wp' return_ev2 + | rule conjI | drule (1) requiv_arm_asid_table_asid_high_bits_of_asid_eq' + | clarsimp | simp add: equiv_valid_2_def)+ + +lemma set_asid_pool_state_equal_except_kheap: + "((), s') \ fst (set_asid_pool ptr pool s) + \ states_equal_except_kheap_asid s s' \ + (\p. p \ ptr \ kheap s p = kheap s' p) \ + asid_pools_of s' ptr = Some pool \ + (\asid. asid \ 0 + \ arm_asid_table (arch_state s) (asid_high_bits_of asid) = + arm_asid_table (arch_state s') (asid_high_bits_of asid) \ + (\pool_ptr. arm_asid_table (arch_state s) (asid_high_bits_of asid) = + Some pool_ptr + \ asid_pool_at pool_ptr s = asid_pool_at pool_ptr s' \ + (\asid_pool asid_pool'. pool_ptr \ ptr + \ asid_pools_of s pool_ptr = + Some asid_pool \ + asid_pools_of s' pool_ptr = + Some asid_pool' + \ asid_pool (asid_low_bits_of asid) = + asid_pool' (asid_low_bits_of asid))))" + by (clarsimp simp: set_asid_pool_def put_def bind_def set_object_def get_object_def gets_map_def + gets_def get_def return_def assert_def assert_opt_def fail_def + states_equal_except_kheap_asid_def equiv_for_def obj_at_def + split: if_split_asm option.split_asm) + +lemma set_asid_pool_delete_ev2: + "equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) \\ + (\s. arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some a \ + asid_pools_of s a = Some pool \ asid \ 0 \ is_subject_asid aag asid) + (\s. arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some a \ + asid_pools_of s a = Some pool' \ asid \ 0 \ is_subject_asid aag asid) + (set_asid_pool a (pool(asid_low_bits_of asid := None))) + (set_asid_pool a (pool'(asid_low_bits_of asid := None)))" + apply (clarsimp simp: equiv_valid_2_def) + apply (frule_tac s'=b in set_asid_pool_state_equal_except_kheap) + apply (frule_tac s'=ba in set_asid_pool_state_equal_except_kheap) + apply (clarsimp simp: states_equal_except_kheap_asid_def) + apply (rule conjI) + apply (clarsimp simp: states_equiv_for_def reads_equiv_def equiv_for_def | rule conjI)+ + apply (case_tac "x=a") + apply (clarsimp simp: opt_map_def split: option.splits) + apply (fastforce) + apply (clarsimp simp: equiv_asids_def equiv_asid_def | rule conjI)+ + apply (case_tac "pool_ptr = a") + apply (clarsimp) + apply (erule_tac x="pasASIDAbs aag asid" in ballE) + apply (clarsimp) + apply (erule_tac x=asid in allE)+ + apply (clarsimp) + apply (drule aag_can_read_own_asids, simp) + apply (erule_tac x="pasASIDAbs aag asida" in ballE) + apply (clarsimp) + apply (erule_tac x=asida in allE)+ + apply (clarsimp) + apply (clarsimp) + apply (clarsimp) + apply (case_tac "pool_ptr=a") + apply (erule_tac x="pasASIDAbs aag asida" in ballE; clarsimp) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (clarsimp simp: affects_equiv_def equiv_for_def states_equiv_for_def | rule conjI)+ + apply (case_tac "x=a") + apply (clarsimp simp: opt_map_def split: option.splits) + apply (fastforce) + apply (clarsimp simp: equiv_asids_def equiv_asid_def | rule conjI)+ + apply (case_tac "pool_ptr=a") + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule_tac x=asid in allE)+ + apply (clarsimp simp: asid_pool_at_kheap) + apply (erule_tac x=asida in allE)+ + apply (clarsimp) + apply (clarsimp) + apply (case_tac "pool_ptr=a") + apply (clarsimp simp: opt_map_def split: option.splits) + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma delete_asid_reads_respects: + "reads_respects aag l (K (asid \ 0 \ is_subject_asid aag asid)) (delete_asid asid pt)" + unfolding delete_asid_def + apply (subst equiv_valid_def2) + apply (rule_tac W="\\" and Q="\rv s. rv = arm_asid_table (arch_state s) \ + is_subject_asid aag asid \ asid \ 0" in equiv_valid_rv_bind) + apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) + apply (wp, simp) + apply (case_tac "rv (asid_high_bits_of asid) = rv' (asid_high_bits_of asid)") + apply (simp) + apply (case_tac "rv' (asid_high_bits_of asid)") + apply (simp) + apply (wp return_ev2, simp) + apply (simp) + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. rv (asid_low_bits_of asid) = rv' (asid_low_bits_of asid)" + in equiv_valid_2_bind) + apply (simp add: when_def) + apply (clarsimp | rule conjI)+ + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (subst equiv_valid_def2[symmetric]) + apply (rule reads_respects_unobservable_unit_return) + apply (wp set_vm_root_states_equiv_for)+ + apply (rule set_asid_pool_delete_ev2) + apply (wp)+ + apply (rule equiv_valid_2_unobservable) + apply (wpsimp wp: do_machine_op_mol_states_equiv_for simp: hwASIDFlush_def)+ + apply (clarsimp | rule return_ev2)+ + apply (rule equiv_valid_2_guard_imp) + apply (wp get_asid_pool_revrv) + apply (simp)+ + apply (wp)+ + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def)+ + apply (clarsimp simp: equiv_valid_2_def reads_equiv_def + equiv_asids_def equiv_asid_def states_equiv_for_def) + apply (erule_tac x="pasASIDAbs aag asid" in ballE) + apply (clarsimp) + apply (drule aag_can_read_own_asids) + apply wpsimp+ + done + +lemma globals_equiv_arm_asid_table_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_asid_table := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma set_vm_root_globals_equiv[wp]: + "set_vm_root tcb \globals_equiv s\" + by (wpsimp wp: dmo_mol_globals_equiv hoare_vcg_all_lift hoare_drop_imps + simp: set_vm_root_def setVSpaceRoot_def) + +lemma delete_asid_pool_globals_equiv[wp]: + "delete_asid_pool base ptr \globals_equiv s\" + unfolding delete_asid_pool_def + by (wpsimp wp: set_vm_root_globals_equiv mapM_wp[OF _ subset_refl] modify_wp) + +lemma vs_lookup_slot_not_global: + "\ vs_lookup_slot level asid vref s = Some (level, pte); level \ max_pt_level; + pte_refs_of s pte = Some pt; vref \ user_region; invs s \ + \ pt \ global_refs s" + apply (prop_tac "vs_lookup_target level asid vref s = Some (level, pt)") + apply (clarsimp simp: vs_lookup_target_def obind_def split: if_splits) + apply (erule (2) vs_lookup_target_not_global) + done + +lemma unmap_page_table_globals_equiv: + "\invs and globals_equiv st and K (vaddr \ user_region)\ + unmap_page_table asid vaddr pt + \\rv. globals_equiv st\" + unfolding unmap_page_table_def + apply (wp store_pte_globals_equiv pt_lookup_from_level_wrp | wpc | simp add: sfence_def)+ + apply clarsimp + apply (rule_tac x=asid in exI) + apply clarsimp + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp) + apply (drule reachable_page_table_not_global, clarsimp+) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + done + +lemma unmap_page_table_valid_arch_state: + "\invs and valid_arch_state and K (vaddr \ user_region)\ + unmap_page_table asid vaddr pt + \\_. valid_arch_state\" + unfolding unmap_page_table_def + apply (wpsimp wp: store_pte_valid_arch_state_unreachable pt_lookup_from_level_wrp simp: sfence_def) + apply (rule_tac x=asid in exI) + apply clarsimp + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp) + apply (drule reachable_page_table_not_global, clarsimp+) + done + +lemma mapM_x_swp_store_pte_globals_equiv: + "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)\ + mapM_x (swp store_pte pte) slots + \\_. globals_equiv s\" + apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state + and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_x_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + apply (clarsimp simp: valid_arch_state_def) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply auto + done + +lemma mapM_x_swp_store_pte_valid_ko_at_arch[wp]: + "\pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)\ + mapM_x (swp store_pte A) slots + \\_. valid_arch_state\" + apply (rule_tac Q'="\_. pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_x_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + apply (clarsimp simp: valid_arch_state_def) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply auto + done + + +definition authorised_for_globals_page_table_inv :: + "page_table_invocation \ 's :: state_ext state \ bool" where + "authorised_for_globals_page_table_inv pti \ \s. + case pti of PageTableMap cap ptr pde p \ p && ~~ mask pt_bits \ arm_us_global_vspace (arch_state s) + | _ \ True" + + +lemma perform_pt_inv_map_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. table_base x14 \ global_pt s)\ + perform_pt_inv_map x11 x12 x13 x14 + \\_. globals_equiv st\" + unfolding perform_pt_inv_map_def + by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' simp: sfence_def) + +lemma perform_pt_inv_unmap_globals_equiv: + "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ + perform_pt_inv_unmap cap ct_slot + \\_. globals_equiv st\" + unfolding perform_pt_inv_unmap_def + apply (wpsimp wp: set_cap_globals_equiv'' mapM_x_swp_store_pte_globals_equiv) + apply (strengthen invs_imps invs_valid_global_vspace_mappings) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: unmap_page_table_globals_equiv unmap_page_table_invs) + apply wpsimp+ + apply auto + apply (drule cte_wp_valid_cap, fastforce) + apply (clarsimp simp: is_PageTableCap_def valid_cap_def valid_arch_cap_def wellformed_mapdata_def) + apply (frule cte_wp_valid_cap, fastforce) + apply (clarsimp simp: is_PageTableCap_def valid_cap_def valid_arch_cap_def wellformed_mapdata_def) + apply (prop_tac "table_base x = acap_obj cap") + apply (prop_tac "is_aligned x41 pt_bits") + apply (fastforce dest: is_aligned_pt simp: valid_arch_cap_def) + apply (simp only: is_aligned_neg_mask_eq') + apply (clarsimp simp: add_mask_fold) + apply (drule subsetD[OF upto_enum_step_subset], clarsimp) + apply (drule neg_mask_mono_le[where n=pt_bits]) + apply (drule neg_mask_mono_le[where n=pt_bits]) + apply (fastforce dest: plus_mask_AND_NOT_mask_eq) + apply clarsimp + apply (frule invs_valid_global_refs) + apply (drule (2) valid_global_refsD[OF invs_valid_global_refs]) + apply (clarsimp simp: cap_range_def) + done + +lemma perform_page_table_invocation_globals_equiv: + "\invs and globals_equiv st and valid_pti pti and authorised_for_globals_page_table_inv pti\ + perform_page_table_invocation pti + \\_. globals_equiv st\" + unfolding perform_page_table_invocation_def + apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' + perform_pt_inv_map_globals_equiv + perform_pt_inv_unmap_globals_equiv) + apply (case_tac pti; clarsimp simp: authorised_for_globals_page_table_inv_def valid_pti_def) + done + +lemma mapM_swp_store_pte_globals_equiv: + "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)\ + mapM (swp store_pte pte) slots + \\_. globals_equiv s\" + apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state + and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + apply (clarsimp simp: valid_arch_state_def) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply auto + done + +lemma mapM_swp_store_pte_valid_ko_at_arch[wp]: + "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)\ + mapM (swp store_pte pte) slots + \\_. valid_arch_state\" + apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state + and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + apply (clarsimp simp: valid_arch_state_def) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply auto + done + +lemma unmap_page_globals_equiv: + "\globals_equiv st and invs and K (vptr \ user_region)\ + unmap_page pgsz asid vptr pptr + \\_. globals_equiv st\" + unfolding unmap_page_def including no_pre + apply (induct pgsz) + apply (wpsimp wp: store_pte_globals_equiv | simp add: sfence_def)+ + apply (rule hoare_weaken_preE[OF find_vspace_for_asid_wp]) + apply clarsimp + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply (rule hoare_pre) + apply (wpsimp wp: store_pte_globals_equiv mapM_swp_store_pte_globals_equiv hoare_drop_imps + | simp add: sfence_def)+ + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_level) + apply (case_tac "x = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply (wpsimp wp: store_pte_globals_equiv | simp add: sfence_def)+ + apply (rule hoare_weaken_preE[OF find_vspace_for_asid_wp]) + apply clarsimp + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_level) + apply (case_tac "x = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + done + + +definition authorised_for_globals_page_inv :: + "page_invocation \ 'z :: state_ext state \ bool" where + "authorised_for_globals_page_inv pgi \ \s. + case pgi of PageMap cap ptr m \ (\slot. cte_wp_at (parent_for_refs m) slot s) | _ \ True" + + +lemma length_msg_lt_msg_max: + "length msg_registers < msg_max_length" + by (simp add: msg_registers_def msgRegisters_def upto_enum_def + fromEnum_def enum_register msg_max_length_def) + +lemma set_mrs_globals_equiv: + "\globals_equiv s and valid_arch_state and (\sa. thread \ idle_thread sa)\ + set_mrs thread buf msgs + \\_. globals_equiv s\" + unfolding set_mrs_def + apply (wp | wpc)+ + apply (simp add: zipWithM_x_mapM_x) + apply (rule conjI) + apply (rule impI) + apply (rule_tac Q'="\_. globals_equiv s" in hoare_strengthen_post) + apply (wp mapM_x_wp') + apply (simp add: split_def) + apply (wp store_word_offs_globals_equiv) + apply (simp) + apply (clarsimp) + apply (insert length_msg_lt_msg_max) + apply (simp) + apply (wp set_object_globals_equiv hoare_weak_lift_imp) + apply (wp hoare_vcg_all_lift set_object_globals_equiv hoare_weak_lift_imp)+ + apply (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def + dest: valid_global_arch_objs_pt_at) + done + +lemma perform_pg_inv_get_addr_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. cur_thread s \ idle_thread s)\ + perform_pg_inv_get_addr ptr + \\_. globals_equiv st\" + unfolding perform_pg_inv_get_addr_def + by (wpsimp wp: set_message_info_globals_equiv set_mrs_globals_equiv) + +lemma unmap_page_valid_arch_state: + "\invs and K (vptr \ user_region)\ + unmap_page pgsz asid vptr pptr + \\_. valid_arch_state\" + unfolding unmap_page_def + apply (wpsimp wp: store_pte_valid_arch_state_unreachable) + apply (frule invs_arch_state) + apply (frule invs_valid_global_vspace_mappings) + apply clarsimp + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_level) + apply (case_tac "x = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + done + +lemma perform_pg_inv_unmap_globals_equiv: + "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ + perform_pg_inv_unmap cap ct_slot + \\_. globals_equiv st\" + unfolding perform_pg_inv_unmap_def + apply (rule hoare_weaken_pre) + apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv + set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv + unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv + | wpc | simp add: do_machine_op_bind sfence_def)+ + apply (clarsimp simp: acap_map_data_def) + apply (intro conjI; clarsimp) + apply (clarsimp split: arch_cap.splits) + apply (drule cte_wp_valid_cap, fastforce) + apply (clarsimp simp: valid_cap_def valid_arch_cap_def wellformed_mapdata_def) + done + +lemma perform_pg_inv_map_globals_equiv: + "\invs and globals_equiv st and (\s. table_base slot \ global_pt s)\ + perform_pg_inv_map cap ct_slot pte slot + \\_. globals_equiv st\" + unfolding perform_pg_inv_map_def + by (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv + set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv + unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv + | wpc | simp add: do_machine_op_bind sfence_def | fastforce)+ + +lemma perform_page_invocation_globals_equiv: + "\invs and authorised_for_globals_page_inv pgi and valid_page_inv pgi + and globals_equiv st and ct_active\ + perform_page_invocation pgi + \\_. globals_equiv st\" + unfolding perform_page_invocation_def + apply (wpsimp wp: perform_pg_inv_get_addr_globals_equiv + perform_pg_inv_unmap_globals_equiv perform_pg_inv_map_globals_equiv) + apply (intro conjI) + apply (clarsimp simp: valid_page_inv_def same_ref_def) + apply (drule vs_lookup_slot_table_base; clarsimp) + apply (drule reachable_page_table_not_global, clarsimp+) + apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply (clarsimp simp: valid_page_inv_def) + apply clarsimp + apply (fastforce dest: invs_valid_idle + simp: valid_idle_def pred_tcb_at_def obj_at_def ct_in_state_def) + done + +lemma retype_region_ASIDPoolObj_globals_equiv: + "\globals_equiv s and (\sa. ptr \ global_pt s) and (\sa. ptr \ idle_thread sa)\ + retype_region ptr 1 0 (ArchObject ASIDPoolObj) dev + \\_. globals_equiv s\" + unfolding retype_region_def + apply (wpsimp wp: modify_wp dxo_wp_weak + simp: trans_state_update[symmetric] simp_del: trans_state_update) + apply (fastforce simp: globals_equiv_def idle_equiv_def tcb_at_def2) + done + +lemma perform_asid_control_invocation_globals_equiv: + notes delete_objects_invs[wp del] + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + shows "\globals_equiv s and invs and ct_active and valid_aci aci\ + perform_asid_control_invocation aci + \\_. globals_equiv s\" + unfolding perform_asid_control_invocation_def + apply (rule hoare_pre) + apply wpc + apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) + apply (wp modify_wp cap_insert_globals_equiv'' + retype_region_ASIDPoolObj_globals_equiv[simplified] + retype_region_invs_extras(5)[where sz=pageBits] + retype_region_invs_extras(6)[where sz=pageBits] + set_cap_globals_equiv + max_index_upd_invs_simple set_cap_no_overlap + set_cap_caps_no_overlap max_index_upd_caps_overlap_reserved + region_in_kernel_window_preserved + hoare_vcg_all_lift get_cap_wp hoare_weak_lift_imp + set_cap_idx_up_aligned_area[where dev = False,simplified] + | simp)+ + (* factor out the implication -- we know what the relevant components of the + cap referred to in the cte_wp_at are anyway from valid_aci, so just use + those directly to simplify the reasoning later on *) + apply (rule_tac Q'="\a b. globals_equiv s b \ invs b \ + word1 \ arm_us_global_vspace (arch_state b) \ word1 \ idle_thread b \ + (\idx. cte_wp_at ((=) (UntypedCap False word1 pageBits idx)) cslot_ptr2 b) \ + descendants_of cslot_ptr2 (cdt b) = {} \ + pspace_no_overlap_range_cover word1 pageBits b" + in hoare_strengthen_post) + prefer 2 + apply (clarsimp simp: globals_equiv_def invs_valid_global_objs) + apply (drule cte_wp_at_eqD2, assumption) + apply clarsimp + apply (clarsimp simp: empty_descendants_range_in) + apply (rule conjI, fastforce simp: cte_wp_at_def) + apply (clarsimp simp: obj_bits_api_def default_arch_object_def) + apply (frule untyped_cap_aligned, simp add: invs_valid_objs) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (strengthen refl caps_region_kernel_window_imp[mk_strg I E]) + apply (simp add: invs_valid_objs invs_cap_refs_in_kernel_window + atLeastatMost_subset_iff word_and_le2 + cong: conj_cong) + apply (rule conjI, rule descendants_range_caps_no_overlapI) + apply assumption + apply (simp add: cte_wp_at_caps_of_state) + apply (simp add: empty_descendants_range_in) + apply (clarsimp simp: range_cover_def) + apply (subst is_aligned_neg_mask_eq[THEN sym], assumption) + apply (simp add: word_bw_assocs pageBits_def mask_zero) + apply (wp add: delete_objects_invs_ex delete_objects_pspace_no_overlap[where dev=False] + delete_objects_globals_equiv hoare_vcg_ex_lift + del: Untyped_AI.delete_objects_pspace_no_overlap + | simp add: page_bits_def)+ + apply (clarsimp simp: conj_comms + invs_psp_aligned invs_valid_objs valid_aci_def) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (frule_tac cap="UntypedCap False a b c" for a b c in caps_of_state_valid, assumption) + apply (clarsimp simp: valid_cap_def cap_aligned_def untyped_min_bits_def) + apply (frule_tac slot="(aa,ba)" + in untyped_caps_do_not_overlap_global_refs[rotated, OF invs_valid_global_refs]) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply ((rule conjI |rule refl | simp)+)[1] + apply (rule conjI) + apply (clarsimp simp: global_refs_def ptr_range_memI) + apply (rule conjI) + apply clarify + apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply (drule_tac p="global_pt sa" in ptr_range_memI) + apply fastforce + apply (rule conjI, fastforce simp: global_refs_def) + apply (rule conjI) + apply clarify + apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply fastforce + apply (rule conjI) + apply (drule untyped_slots_not_in_untyped_range) + apply (blast intro!: empty_descendants_range_in) + apply (simp add: cte_wp_at_caps_of_state) + apply simp + apply (rule refl) + apply (rule subset_refl) + apply (simp) + apply (rule conjI) + apply fastforce + apply (auto intro: empty_descendants_range_in simp: descendants_range_def2 cap_range_def) + done + +lemma store_asid_pool_entry_globals_equiv: + "\globals_equiv st and valid_arch_state\ + store_asid_pool_entry pool_ptr asid ptr + \\_. globals_equiv st\" + unfolding store_asid_pool_entry_def + by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' get_cap_wp | wpc | simp)+ + +lemma perform_asid_pool_invocation_globals_equiv: + "\globals_equiv s and invs and valid_apinv api\ + perform_asid_pool_invocation api + \\_. globals_equiv s\" + unfolding perform_asid_pool_invocation_def + apply (rule hoare_weaken_pre) + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' + store_asid_pool_entry_globals_equiv copy_global_mappings_globals_equiv + copy_global_mappings_valid_arch_state get_cap_wp + | wpc | simp)+ + apply (clarsimp simp: valid_apinv_def cong: conj_cong) + apply (intro conjI; fastforce?) + apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (frule (1) cap_not_in_valid_global_refs) + apply (clarsimp simp: acap_obj_def is_pt_cap_def split: arch_cap.splits) + apply (rule caps_of_state_aligned_page_table) + apply (fastforce simp: cte_wp_at_caps_of_state is_pt_cap_def is_PageTableCap_def + split: option.splits) + apply clarsimp + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (frule (1) cap_not_in_valid_global_refs) + apply (clarsimp simp: acap_obj_def is_pt_cap_def split: arch_cap.splits) + done + + +definition authorised_for_globals_arch_inv :: + "arch_invocation \ ('z::state_ext) state \ bool" where + "authorised_for_globals_arch_inv ai \ + case ai of InvokePageTable oper \ authorised_for_globals_page_table_inv oper + | InvokePage oper \ authorised_for_globals_page_inv oper + | _ \ \" + + +lemma arch_perform_invocation_reads_respects_g: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_g aag l (ct_active and authorised_arch_inv aag ai and valid_arch_inv ai + and authorised_for_globals_arch_inv ai and invs + and pas_refined aag and is_subject aag \ cur_thread) + (arch_perform_invocation ai)" + unfolding arch_perform_invocation_def fun_app_def + apply (case_tac ai; rule equiv_valid_guard_imp) + by (wpsimp wp: doesnt_touch_globalsI + reads_respects_g[OF perform_page_table_invocation_reads_respects] + reads_respects_g[OF perform_page_invocation_reads_respects] + reads_respects_g[OF perform_asid_control_invocation_reads_respects] + perform_asid_pool_invocation_reads_respects_g + perform_page_table_invocation_globals_equiv + perform_page_invocation_globals_equiv + perform_asid_control_invocation_globals_equiv + perform_asid_pool_invocation_globals_equiv + simp: authorised_arch_inv_def valid_arch_inv_def authorised_for_globals_arch_inv_def + invs_psp_aligned invs_valid_objs invs_vspace_objs invs_valid_asid_table | simp)+ + +lemma arch_perform_invocation_globals_equiv: + "\globals_equiv s and invs and ct_active and valid_arch_inv ai + and authorised_for_globals_arch_inv ai\ + arch_perform_invocation ai + \\_. globals_equiv s\" + unfolding arch_perform_invocation_def + apply (wpsimp wp: perform_page_table_invocation_globals_equiv + perform_page_invocation_globals_equiv + perform_asid_control_invocation_globals_equiv + perform_asid_pool_invocation_globals_equiv)+ + apply (auto simp: authorised_for_globals_arch_inv_def invs_def valid_state_def valid_arch_inv_def) + done + +crunch arch_post_cap_deletion + for valid_global_objs[wp]: "valid_global_objs" + +lemma get_thread_state_globals_equiv[wp]: + "get_thread_state ref \globals_equiv s\" + by wp + +(* generalises auth_ipc_buffers_mem_Write *) +lemma auth_ipc_buffers_mem_Write': + "\ x \ auth_ipc_buffers s thread; pas_refined aag s; valid_objs s \ + \ (pasObjectAbs aag thread, Write, pasObjectAbs aag x) \ pasPolicy aag" + apply (clarsimp simp add: auth_ipc_buffers_member_def) + apply (drule (1) cap_auth_caps_of_state) + apply simp + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + vspace_cap_rights_to_auth_def vm_read_write_def + split: if_split_asm) + apply (auto dest: ipcframe_subset_page) + done + +lemma thread_set_globals_equiv: + "(\tcb. arch_tcb_context_get (tcb_arch (f tcb)) = arch_tcb_context_get (tcb_arch tcb)) + \ \globals_equiv s and valid_arch_state\ thread_set f tptr \\_. globals_equiv s\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + apply simp + apply (intro impI conjI allI) + apply (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def dest: valid_global_arch_objs_pt_at)+ + done + +end + +hide_fact as_user_globals_equiv + +context begin interpretation Arch . + +requalify_consts + authorised_for_globals_arch_inv + +requalify_facts + arch_post_cap_deletion_valid_global_objs + get_thread_state_globals_equiv + auth_ipc_buffers_mem_Write' + thread_set_globals_equiv + arch_post_modify_registers_cur_domain + arch_post_modify_registers_cur_thread + length_msg_lt_msg_max + set_mrs_globals_equiv + arch_perform_invocation_globals_equiv + as_user_globals_equiv + prepare_thread_delete_st_tcb_at_halted + make_arch_fault_msg_inv + check_valid_ipc_buffer_inv + arch_tcb_update_aux2 + arch_perform_invocation_reads_respects_g + +declare + arch_post_cap_deletion_valid_global_objs[wp] + get_thread_state_globals_equiv[wp] + arch_post_modify_registers_cur_domain[wp] + arch_post_modify_registers_cur_thread[wp] + prepare_thread_delete_st_tcb_at_halted[wp] + +end + +declare as_user_globals_equiv[wp] + +axiomatization dmo_reads_respects where + dmo_read_stval_reads_respects: "reads_respects aag l \ (do_machine_op read_stval)" + +end diff --git a/proof/infoflow/AARCH64/ArchCNode_IF.thy b/proof/infoflow/AARCH64/ArchCNode_IF.thy new file mode 100644 index 0000000000..3253d95651 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchCNode_IF.thy @@ -0,0 +1,147 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchCNode_IF +imports CNode_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems CNode_IF_assms + +lemma set_object_globals_equiv: + "\globals_equiv s and (\s. ptr \ arm_us_global_vspace (arch_state s)) and + (\t. ptr = idle_thread t + \ (\tcb. kheap t (idle_thread t) = Some (TCB tcb) + \ (\tcb'. obj = (TCB tcb') + \ arch_tcb_context_get (tcb_arch tcb) = arch_tcb_context_get (tcb_arch tcb'))) \ + (\tcb'. obj = (TCB tcb') \ tcb_at (idle_thread t) t))\ + set_object ptr obj + \\_. globals_equiv s\" + apply (wpsimp wp: set_object_wp) + apply (case_tac "ptr = idle_thread sa") + apply (clarsimp simp: globals_equiv_def idle_equiv_def tcb_at_def2) + apply (intro impI conjI allI notI iffI | clarsimp)+ + apply (clarsimp simp: globals_equiv_def idle_equiv_def tcb_at_def2) + done + +lemma set_object_globals_equiv'': + "\globals_equiv s and (\ s. ptr \ arm_us_global_vspace (arch_state s)) and (\t. ptr \ idle_thread t)\ + set_object ptr obj + \\_. globals_equiv s\" + by (wpsimp wp: set_object_globals_equiv) + +lemma set_cap_globals_equiv': + "\globals_equiv s and (\ s. fst p \ arm_us_global_vspace (arch_state s))\ + set_cap cap p + \\_. globals_equiv s\" + unfolding set_cap_def + apply (simp only: split_def) + apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ + apply (fastforce simp: obj_at_def is_tcb_def) + done + +lemma set_cap_globals_equiv[CNode_IF_assms]: + "\globals_equiv s and valid_global_objs and valid_arch_state\ + set_cap cap p + \\_. globals_equiv s\" + unfolding set_cap_def + apply (simp only: split_def) + apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ + apply (fastforce simp: is_tcb_def obj_at_def valid_arch_state_def + dest: valid_global_arch_objs_pt_at) + done + +definition irq_at :: "nat \ (irq \ bool) \ irq option" where + "irq_at pos masks \ let i = irq_oracle pos in (if i = 0x3F \ masks i then None else Some i)" + +lemma dmo_getActiveIRQ_wp[CNode_IF_assms]: + "\\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: irq_at_def Let_def split: if_splits) + done + +lemma arch_globals_equiv_irq_state_update[CNode_IF_assms, simp]: + "arch_globals_equiv ct it kh kh' as as' ms (irq_state_update f ms') = + arch_globals_equiv ct it kh kh' as as' ms ms'" + "arch_globals_equiv ct it kh kh' as as' (irq_state_update f ms) ms' = + arch_globals_equiv ct it kh kh' as as' ms ms'" + by auto + +end + + +requalify_consts AARCH64.irq_at + +global_interpretation CNode_IF_1?: CNode_IF_1 _ irq_at +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma is_irq_at_triv[CNode_IF_assms]: + assumes a: "\P. \(\s. P (irq_masks (machine_state s))) and Q\ + f + \\rv s. P (irq_masks (machine_state s))\" + shows "\(\s. P (is_irq_at s)) and Q\ f \\rv s. P (is_irq_at s)\" + apply (clarsimp simp: valid_def is_irq_at_def irq_at_def Let_def) + apply (erule use_valid[OF _ a]) + apply simp + done + +lemma is_irq_at_not_masked[CNode_IF_assms]: + "is_irq_at s irq pos \ \ irq_masks (machine_state s) irq" + by (clarsimp simp: is_irq_at_def irq_at_def split: option.splits simp: Let_def split: if_splits) + +end + + +global_interpretation CNode_IF_2?: CNode_IF_2 irq_at +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: + notes gets_ev[wp del] + shows "reads_respects aag l (invs and only_timer_irq_inv irq st) + (do_machine_op (getActiveIRQ in_kernel))" + apply (rule use_spec_ev) + apply (rule do_machine_op_spec_reads_respects') + apply (simp add: getActiveIRQ_def) + apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device + gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift + gets_irq_masks_equiv_valid modify_wp + | simp add: no_irq_def)+ + apply (rule only_timer_irq_inv_determines_irq_masks, blast+) + done + +end + + +global_interpretation CNode_IF_3?: CNode_IF_3 irq_at +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchDecode_IF.thy b/proof/infoflow/AARCH64/ArchDecode_IF.thy new file mode 100644 index 0000000000..407f1438e9 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchDecode_IF.thy @@ -0,0 +1,333 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchDecode_IF +imports Decode_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Decode_IF_assms + +lemma data_to_obj_type_rev[Decode_IF_assms]: + "reads_equiv_valid_inv A aag \ (data_to_obj_type type)" + unfolding data_to_obj_type_def fun_app_def arch_data_to_obj_type_def + apply (wp | wpc)+ + apply simp + done + +lemma check_valid_ipc_buffer_rev[Decode_IF_assms]: + "reads_equiv_valid_inv A aag \ (check_valid_ipc_buffer vptr cap)" + unfolding check_valid_ipc_buffer_def fun_app_def + apply (rule equiv_valid_guard_imp) + apply (wpc | wp)+ + apply simp + done + +lemma arch_check_irq_rev[Decode_IF_assms, wp]: + "reads_equiv_valid_inv A aag \ (arch_check_irq irq)" + unfolding arch_check_irq_def + apply (rule equiv_valid_guard_imp) + apply wpsimp+ + done + +lemma vspace_cap_rights_to_auth_mono[Decode_IF_assms]: + "R \ S \ vspace_cap_rights_to_auth R \ vspace_cap_rights_to_auth S" + by (auto simp: vspace_cap_rights_to_auth_def) + +lemma arch_decode_irq_control_invocation_rev[Decode_IF_assms]: + "reads_equiv_valid_inv A aag + (pas_refined aag and + K (is_subject aag (fst slot) \ (\cap\set caps. pas_cap_cur_auth aag cap) \ + (args \ [] \ (pasSubject aag, Control, pasIRQAbs aag (ucast (args ! 0))) \ pasPolicy aag))) + (arch_decode_irq_control_invocation label args slot caps)" + unfolding arch_decode_irq_control_invocation_def arch_check_irq_def + apply (wp ensure_empty_rev lookup_slot_for_cnode_op_rev + is_irq_active_rev whenE_inv + | wp (once) hoare_drop_imps + | simp add: Let_def)+ + apply safe + apply simp+ + apply (blast intro: aag_Control_into_owns_irq ) + apply (drule_tac x="caps ! 0" in bspec) + apply (fastforce intro: bang_0_in_set) + apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) + apply (fastforce dest: is_cnode_into_is_subject intro: bang_0_in_set) + done + +requalify_facts check_valid_ipc_buffer_inv + +end + + +global_interpretation Decode_IF_1?: Decode_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Decode_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq'': + "\ \asid. is_subject_asid aag asid; reads_equiv aag s t; pas_refined aag x \ + \ arm_asid_table (arch_state s) (asid_high_bits_of base) = + arm_asid_table (arch_state t) (asid_high_bits_of base)" + apply (subgoal_tac "asid_high_bits_of 0 = asid_high_bits_of 1") + apply (case_tac "base = 0") + apply (subgoal_tac "is_subject_asid aag 1") + apply ((auto intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq) | + (auto simp: asid_high_bits_of_def asid_low_bits_def))+ + done + +lemma pas_cap_cur_auth_ASIDControlCap: + "\ pas_cap_cur_auth aag (ArchObjectCap ASIDControlCap); reads_equiv aag s t; pas_refined aag x \ + \ arm_asid_table (arch_state s) = arm_asid_table (arch_state t)" + apply (rule ext) + apply (subst asid_high_bits_of_shift[symmetric]) + apply (subst (3) asid_high_bits_of_shift[symmetric]) + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq'') + apply (clarsimp simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def) + apply (rule pas_refined_Control_into_is_subject_asid, blast+) + done + +lemma decode_asid_pool_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (cap = ASIDPoolCap x xa) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_asid_pool_invocation label args slot cap excaps)" + unfolding decode_asid_pool_invocation_def + apply (rule equiv_valid_guard_imp) + apply (subst gets_applyE)+ + apply (wp check_vp_wpR + reads_respects_f_inv'[OF get_asid_pool_rev] + gets_apply_ev + select_ext_ev_bind_lift + | wpc + | simp add: Let_def unlessE_whenE + | wp (once) whenE_throwError_wp)+ + apply (intro impI allI conjI) + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq') + apply fastforce + apply (simp add: reads_equiv_f_def) + apply blast + apply (fastforce simp: aag_cap_auth_ASIDPoolCap) + done + +lemma decode_asid_control_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (cap = ASIDControlCap) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_asid_control_invocation label args slot cap excaps)" + unfolding decode_asid_control_invocation_def + apply (rule equiv_valid_guard_imp) + apply (wp check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + gets_apply_ev + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | wpc + | simp add: Let_def unlessE_whenE + | wp (once) whenE_throwError_wp)+ + apply clarsimp + apply (prop_tac "excaps ! Suc 0 \ set excaps", fastforce) + apply (drule_tac x="excaps ! Suc 0" in bspec, assumption) + apply (frule_tac x="excaps ! Suc 0" in bspec, assumption) + apply (drule_tac x="excaps ! 0" in bspec, fastforce intro!: bang_0_in_set) + apply (intro impI allI conjI) + apply (fastforce intro: pas_cap_cur_auth_ASIDControlCap[where aag=aag] simp: reads_equiv_f_def) + apply fastforce + apply (fastforce intro: owns_cnode_owns_obj_ref_of_child_cnodes[where slot="snd (excaps ! (Suc 0))"]) + apply clarify + apply (rule_tac cap="fst (excaps ! Suc 0)" and p="snd (excaps ! Suc 0)" in caps_of_state_pasObjectAbs_eq) + apply (rule cte_wp_at_caps_of_state') + apply fastforce + apply (erule cap_auth_conferred_cnode_cap) + apply fastforce + apply assumption + apply fastforce + done + +lemma decode_frame_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (cap = FrameCap p R sz dev m) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_frame_invocation label args slot cap excaps)" + unfolding decode_frame_invocation_def decode_fr_inv_map_def + check_slot_def check_vp_alignment_def gets_the_def + supply gets_the_ev[wp del] + apply (rule equiv_valid_guard_imp) + apply ((wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF get_pte_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | wpc + | simp add: Let_def unlessE_whenE + | wp (once) whenE_throwError_wp)+)[1] + apply clarsimp + apply (drule_tac x="excaps ! 0" in bspec, fastforce intro: bang_0_in_set)+ + apply (intro conjI; clarsimp) + apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) + apply (prop_tac "args ! 0 \ user_region") + apply (drule not_le_imp_less) + apply (frule order.strict_implies_order[where b=user_vtop]) + apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) + apply (drule canonical_below_pptr_base_user) + apply (erule below_user_vtop_canonical) + apply (clarsimp simp: user_region_def) + apply (drule is_aligned_no_overflow_mask) + apply (erule (1) dual_order.trans) + apply (rule conjI; clarsimp) + apply (clarsimp simp: reads_equiv_f_def) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac pt=xa and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv, + (fastforce dest: aag_has_Control_iff_owns + elim: vs_lookup_table_vref_independent + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def + split: option.splits)+)[1] + apply (subgoal_tac "is_subject aag (table_base bb)", clarsimp) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def vspace_for_asid_def) + apply (frule pt_walk_is_aligned) + apply (erule (1) vspace_for_pool_is_aligned[OF _ _ user_region0]; clarsimp) + apply clarsimp + apply (erule_tac asid=a in pt_walk_is_subject[rotated 4]; clarsimp?) + apply (clarsimp simp: vs_lookup_table_def in_omonad) + apply (fastforce intro: vspace_for_asid_is_subject simp: vspace_for_asid_def in_omonad) + done + +lemma decode_page_table_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (cap = PageTableCap p m) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_page_table_invocation label args slot cap excaps)" + unfolding decode_page_table_invocation_def decode_pt_inv_map_def gets_the_def + supply gets_the_ev[wp del] + apply (rule equiv_valid_guard_imp) + apply ((wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF get_pte_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | simp add: Let_def unlessE_whenE if_fun_split + | wpc + | wp (once) whenE_throwError_wp hoare_drop_imps)+)[1] + apply clarsimp + apply (rule conjI; clarsimp) + apply (drule_tac x="excaps ! 0" in bspec, fastforce intro: bang_0_in_set)+ + apply (prop_tac "args ! 0 \ user_region") + apply (drule not_le_imp_less) + apply (frule order.strict_implies_order[where b=user_vtop]) + apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) + apply (drule canonical_below_pptr_base_user) + apply (erule below_user_vtop_canonical) + apply (clarsimp simp: user_region_def) + apply clarsimp + apply (intro conjI impI allI; clarsimp) + apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) + apply (clarsimp simp: reads_equiv_f_def) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac pt=xa and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv, + (fastforce dest: aag_has_Control_iff_owns + elim: vs_lookup_table_vref_independent + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def + split: option.splits)+)[1] + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def vspace_for_asid_def) + apply (frule pt_walk_is_aligned) + apply (erule (1) vspace_for_pool_is_aligned[OF _ _ user_region0]; clarsimp) + apply clarsimp + apply (erule_tac asid=a in pt_walk_is_subject[rotated 4]; clarsimp?) + apply (clarsimp simp: vs_lookup_table_def in_omonad) + apply (fastforce intro: vspace_for_asid_is_subject simp: vspace_for_asid_def in_omonad) + apply (rule conjI, fastforce elim!: is_subject_not_silc_inv)+ + apply (clarsimp simp: reads_equiv_f_def) + apply (erule reads_equivE) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + apply (erule_tac x=a in allE) + apply (fastforce simp: vspace_for_asid_def pool_for_asid_def vspace_for_pool_def + asid_pools_of_ko_at obj_at_def obind_def opt_map_def + split: option.splits) + done + +lemma arch_decode_invocation_reads_respects_f[Decode_IF_assms]: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (arch_decode_invocation label args cap_index slot cap excaps)" + unfolding arch_decode_invocation_def + apply (cases cap; rule equiv_valid_guard_imp) + by (wpsimp wp: decode_asid_pool_invocation_reads_respects_f + decode_asid_control_invocation_reads_respects_f + decode_frame_invocation_reads_respects_f + decode_page_table_invocation_reads_respects_f | fastforce)+ + +end + + +global_interpretation Decode_IF_2?: Decode_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Decode_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchFinalCaps.thy b/proof/infoflow/AARCH64/ArchFinalCaps.thy new file mode 100644 index 0000000000..b7e698fbef --- /dev/null +++ b/proof/infoflow/AARCH64/ArchFinalCaps.thy @@ -0,0 +1,329 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchFinalCaps +imports FinalCaps +begin + +context Arch begin global_naming AARCH64 + +named_theorems FinalCaps_assms + +lemma FIXME_arch_gen_refs[FinalCaps_assms]: + "arch_gen_refs cap = {}" + by (clarsimp simp: arch_cap_set_map_def arch_gen_obj_refs_def split: cap.splits) + +lemma aobj_ref_same_aobject[FinalCaps_assms]: + "same_aobject_as cp cp' \ aobj_ref cp = aobj_ref cp'" + by (cases cp; cases cp'; clarsimp) + +lemma set_pt_silc_inv[wp]: + "set_pt ptr pt \silc_inv aag st\" + unfolding set_pt_def + apply (rule silc_inv_pres) + apply (wpsimp wp: set_object_wp_strong simp: a_type_def split: kernel_object.splits) + apply (fastforce simp: silc_inv_def obj_at_def is_cap_table_def) + apply (wp set_object_wp get_object_wp | simp)+ + apply (case_tac "ptr = fst slot") + apply (clarsimp split: kernel_object.splits) + apply (fastforce elim: cte_wp_atE simp: obj_at_def) + apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) + done + +lemma set_asid_pool_silc_inv[wp]: + "set_asid_pool ptr pool \silc_inv aag st\" + unfolding set_asid_pool_def + apply (rule silc_inv_pres) + apply (wpsimp wp: set_object_wp_strong simp: a_type_def split: kernel_object.splits) + apply (fastforce simp: silc_inv_def obj_at_def is_cap_table_def) + apply (wp set_object_wp get_object_wp | simp)+ + apply (case_tac "ptr = fst slot") + apply (clarsimp split: kernel_object.splits) + apply (fastforce elim: cte_wp_atE simp: obj_at_def) + apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) + done + +crunch arch_finalise_cap, prepare_thread_delete, init_arch_objects + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) + +crunch handle_reserved_irq, handle_vm_fault, handle_hypervisor_fault, handle_arch_fault_reply, + arch_invoke_irq_handler, arch_mask_irq_signal, + arch_post_cap_deletion, arch_post_modify_registers, + arch_activate_idle_thread, arch_switch_to_idle_thread, arch_switch_to_thread + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + +lemma arch_derive_cap_silc[FinalCaps_assms]: + "\\s. cap = ArchObjectCap acap \ + (\ cap_points_to_label aag cap l \ R (slots_holding_overlapping_caps cap s))\ + arch_derive_cap acap + \\cap' s. \ cap_points_to_label aag cap' l \ R (slots_holding_overlapping_caps cap' s)\, -" + apply (simp add: arch_derive_cap_def) + apply wpsimp + apply (auto simp: cap_points_to_label_def slots_holding_overlapping_caps_def) + done + +declare init_arch_objects_cte_wp_at[FinalCaps_assms] +declare handle_vm_fault_cur_thread[FinalCaps_assms] +declare finalise_cap_makes_halted[FinalCaps_assms] +declare init_arch_objects_inv[FinalCaps_assms] + +end + + +global_interpretation FinalCaps_1?: FinalCaps_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma perform_page_table_invocation_silc_inv_get_cap_helper: + "\silc_inv aag st and cte_wp_at (is_pt_cap or is_frame_cap) xa\ + get_cap xa + \(\capa s. (\ cap_points_to_label aag (ArchObjectCap $ update_map_data capa None) + (pasObjectAbs aag (fst xa)) + \ (\lslot. lslot \ slots_holding_overlapping_caps + (ArchObjectCap $ update_map_data capa None) s \ + pasObjectAbs aag (fst lslot) = SilcLabel))) \ the_arch_cap\" + apply (wp get_cap_wp) + apply clarsimp + apply (drule cte_wp_at_norm) + apply (clarify) + apply (drule (1) cte_wp_at_eqD2) + apply (case_tac cap, simp_all add: is_frame_cap_def is_pt_cap_def) + apply (clarsimp simp: cap_points_to_label_def update_map_data_def split: arch_cap.splits) + apply (drule silc_invD) + apply assumption + apply (fastforce simp: intra_label_cap_def cap_points_to_label_def) + apply (fastforce simp: slots_holding_overlapping_caps_def2 ctes_wp_at_def) + apply (drule silc_invD) + apply assumption + apply (fastforce simp: intra_label_cap_def cap_points_to_label_def) + apply (fastforce simp: slots_holding_overlapping_caps_def2 ctes_wp_at_def) + done + +lemmas perform_page_table_invocation_silc_inv_get_cap_helper' = + perform_page_table_invocation_silc_inv_get_cap_helper[simplified o_def fun_app_def] + +lemma mapM_x_swp_store_pte_silc_inv[wp]: + "mapM_x (swp store_pte A) slots \silc_inv aag st\" + by (wp mapM_x_wp[OF _ subset_refl] | simp add: swp_def)+ + +lemma is_arch_eq_pt_is_pt_or_frame_cap: + "cte_wp_at ((=) (ArchObjectCap (PageTableCap xa xb))) slot s + \ cte_wp_at (\a. is_pt_cap a \ is_frame_cap a) slot s" + apply (erule cte_wp_at_weakenE) + by (clarsimp simp: is_frame_cap_def is_pt_cap_def) + +lemma is_arch_eq_pg_is_pt_or_pg_cap: + "cte_wp_at ((=) (ArchObjectCap (FrameCap xa xb xc xd xe))) slot s + \ cte_wp_at (\a. is_pt_cap a \ is_frame_cap a) slot s" + apply (erule cte_wp_at_weakenE) + by (clarsimp simp: is_frame_cap_def is_pt_cap_def) + +lemma perform_page_table_invocation_silc_inv: + "\silc_inv aag st and valid_pti blah and K (authorised_page_table_inv aag blah)\ + perform_page_table_invocation blah + \\_. silc_inv aag st\" + unfolding perform_page_table_invocation_def perform_pt_inv_map_def perform_pt_inv_unmap_def + apply (rule hoare_pre) + apply (wp set_cap_silc_inv mapM_x_wp[OF _ subset_refl] + perform_page_table_invocation_silc_inv_get_cap_helper'[where st=st] + | wpc | simp only: o_def fun_app_def K_def swp_def)+ + apply (clarsimp simp: valid_pti_def authorised_page_table_inv_def + split: page_table_invocation.splits) + apply (rule conjI) + apply (clarsimp) + defer + apply (fastforce simp: silc_inv_def) + apply (fastforce dest: is_arch_eq_pt_is_pt_or_frame_cap + simp: silc_inv_def is_PageTableCap_def pred_disj_def) + apply (drule_tac slot="(aa,ba)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce) + apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) + apply fastforce + done + +lemma perform_page_invocation_silc_inv: + "\silc_inv aag st and valid_page_inv blah and authorised_page_inv aag blah\ + perform_page_invocation blah + \\_. silc_inv aag st\" + unfolding perform_page_invocation_def perform_pg_inv_map_def perform_pg_inv_unmap_def perform_pg_inv_get_addr_def + apply (rule hoare_pre) + apply (wp mapM_wp[OF _ subset_refl] set_cap_silc_inv + mapM_x_wp[OF _ subset_refl] + perform_page_table_invocation_silc_inv_get_cap_helper'[where st=st] + hoare_vcg_all_lift hoare_vcg_if_lift hoare_weak_lift_imp + | wpc + | simp only: swp_def o_def fun_app_def K_def + | wp (once) hoare_drop_imps)+ + apply (clarsimp simp: valid_page_inv_def authorised_page_inv_def + split: page_invocation.splits) + apply (intro allI impI conjI) + apply (drule_tac slot="(ab,bc)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce) + apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) + apply fastforce + apply (fastforce simp: silc_inv_def) + apply (fastforce dest: is_arch_eq_pg_is_pt_or_pg_cap simp: silc_inv_def pred_disj_def) + done + +lemma perform_asid_control_invocation_silc_inv: + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + shows + "\silc_inv aag st and valid_aci blah and invs and K (authorised_asid_control_inv aag blah)\ + perform_asid_control_invocation blah + \\_. silc_inv aag st\" + apply (rule hoare_gen_asm) + unfolding perform_asid_control_invocation_def + apply (rule hoare_pre) + apply (wp modify_wp cap_insert_silc_inv' retype_region_silc_inv[where sz=pageBits] + set_cap_silc_inv get_cap_slots_holding_overlapping_caps[where st=st] + delete_objects_silc_inv hoare_weak_lift_imp + | wpc | simp )+ + apply (clarsimp simp: authorised_asid_control_inv_def silc_inv_def valid_aci_def ptr_range_def page_bits_def) + apply (rule conjI) + apply (clarsimp simp: range_cover_def obj_bits_api_def default_arch_object_def asid_bits_def pageBits_def) + apply (rule of_nat_inverse) + apply simp + apply (drule is_aligned_neg_mask_eq'[THEN iffD1, THEN sym]) + apply (erule_tac t=x in ssubst) + apply (simp add: mask_AND_NOT_mask) + apply simp + apply (simp add: p_assoc_help) + apply (clarsimp simp: cap_points_to_label_def) + apply (erule bspec) + apply (fastforce intro: is_aligned_no_wrap' simp: blah) + done + +crunch store_asid_pool_entry, handle_spurious_irq + for silc_inv[wp]: "silc_inv aag st" + +crunch copy_global_mappings + for silc_inv[wp]: "silc_inv aag st" + (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) + +lemma perform_asid_pool_invocation_silc_inv: + "\silc_inv aag st and K (authorised_asid_pool_inv aag blah)\ + perform_asid_pool_invocation blah + \\_. silc_inv aag st\" + unfolding perform_asid_pool_invocation_def + apply (wpsimp wp: set_cap_silc_inv get_cap_wp)+ + apply (fastforce dest: silc_invD + simp: intra_label_cap_def cap_points_to_label_def silc_inv_def + slots_holding_overlapping_caps_def authorised_asid_pool_inv_def + is_ArchObjectCap_def is_PageTableCap_def update_map_data_def)+ + done + +declare handle_spurious_irq_silc_inv[wp, FinalCaps_assms] + +lemma arch_perform_invocation_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and invs and valid_arch_inv ai and authorised_arch_inv aag ai\ + arch_perform_invocation ai + \\_. silc_inv aag st\" + unfolding arch_perform_invocation_def + apply (rule hoare_pre) + apply (wp perform_page_table_invocation_silc_inv + perform_page_invocation_silc_inv + perform_asid_control_invocation_silc_inv + perform_asid_pool_invocation_silc_inv + | wpc)+ + apply (clarsimp simp: authorised_arch_inv_def valid_arch_inv_def split: arch_invocation.splits) + done + +lemma arch_invoke_irq_control_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and pas_refined aag and arch_irq_control_inv_valid arch_irq_cinv + and K (arch_authorised_irq_ctl_inv aag arch_irq_cinv)\ + arch_invoke_irq_control arch_irq_cinv + \\_. silc_inv aag st\" + unfolding arch_authorised_irq_ctl_inv_def + apply (rule hoare_gen_asm) + apply (case_tac arch_irq_cinv) + apply (wp cap_insert_silc_inv'' hoare_vcg_ex_lift slots_holding_overlapping_caps_lift + | simp add: authorised_irq_ctl_inv_def arch_irq_control_inv_valid_def)+ + apply (fastforce dest: new_irq_handler_caps_are_intra_label) + done + +crunch set_priority, set_flags + for silc_inv[wp]: "silc_inv aag st" + (simp: tcb_cap_cases_def) + +crunch arch_prepare_set_domain, arch_prepare_next_domain, arch_post_set_flags + for inv[FinalCaps_assms,wp]: P + +lemma invoke_tcb_silc_inv[FinalCaps_assms]: + notes hoare_weak_lift_imp [wp] + hoare_weak_lift_imp_conj [wp] + shows "\silc_inv aag st and einvs and simple_sched_action and pas_refined aag and tcb_inv_wf tinv + and K (authorised_tcb_inv aag tinv)\ + invoke_tcb tinv + \\_. silc_inv aag st\" + apply (case_tac tinv) + apply ((wp restart_silc_inv hoare_vcg_if_lift suspend_silc_inv mapM_x_wp[OF _ subset_refl] + hoare_weak_lift_imp + | wpc + | simp split del: if_split add: authorised_tcb_inv_def check_cap_at_def + | clarsimp + | strengthen invs_mdb + | force intro: notE[rotated,OF idle_no_ex_cap,simplified])+)[3] + defer + apply ((wp suspend_silc_inv restart_silc_inv | simp add: authorised_tcb_inv_def | force)+)[2] + (* NotificationControl *) + apply (rename_tac option) + apply (case_tac option; (wp | simp)+) + (* SetTLSBase *) + apply (wpsimp split: option.splits) + (* just ThreadControl left *) + apply (simp add: split_def cong: option.case_cong) + (* slow, ~2 mins *) + apply (strengthen use_no_cap_to_obj_asid_strg + | clarsimp + | simp only: conj_ac cong: conj_cong imp_cong + | wp checked_insert_pas_refined checked_cap_insert_silc_inv hoare_vcg_all_liftE_R + hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + cap_delete_silc_inv_not_transferable + cap_delete_pas_refined' cap_delete_deletes + cap_delete_valid_cap cap_delete_cte_at + check_cap_inv[where P="valid_cap c" for c] + check_cap_inv[where P="cte_at p0" for p0] + check_cap_inv[where P="\s. \ tcb_at t s" for t] + check_cap_inv2[where Q="\_. valid_list"] + check_cap_inv2[where Q="\_. valid_sched"] + check_cap_inv2[where Q="\_. simple_sched_action"] + checked_insert_no_cap_to + thread_set_tcb_fault_handler_update_invs + thread_set_pas_refined thread_set_emptyable thread_set_valid_cap + thread_set_not_state_valid_sched thread_set_cte_at + thread_set_no_cap_to_trivial + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def + st_tcb_at_triv option_update_thread_def + | strengthen use_no_cap_to_obj_asid_strg invs_mdb + invs_psp_aligned invs_vspace_objs invs_arch_state + | wp (once) hoare_drop_imps + | elim disjE; solves clarsimp)+ + (* also slow, ~30s *) + apply (intro impI conjI + | clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def + authorised_tcb_inv_def emptyable_def + split: cap.splits option.splits)+ + done + +end + + +global_interpretation FinalCaps_2?: FinalCaps_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchFinalise_IF.thy b/proof/infoflow/AARCH64/ArchFinalise_IF.thy new file mode 100644 index 0000000000..8cfcf47c9d --- /dev/null +++ b/proof/infoflow/AARCH64/ArchFinalise_IF.thy @@ -0,0 +1,362 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchFinalise_IF +imports Finalise_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Finalise_IF_assms + +crunch arch_post_cap_deletion + for globals_equiv[Finalise_IF_assms, wp]: "globals_equiv st" + and valid_arch_state[Finalise_IF_assms,wp]: valid_arch_state + +lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: + "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" + unfolding maskInterrupt_def + apply (rule use_spec_ev) + apply (rule do_machine_op_spec_reads_respects) + apply (simp add: equiv_valid_def2) + apply (rule modify_ev2) + apply (fastforce simp: equiv_for_def) + apply (wp modify_wp | simp)+ + done + +lemma arch_post_cap_deletion_read_respects[Finalise_IF_assms, wp]: + "reads_respects aag l \ (arch_post_cap_deletion acap)" + by wpsimp + +lemma equiv_asid_sa_update[Finalise_IF_assms, simp]: + "equiv_asid asid (scheduler_action_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (scheduler_action_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma equiv_asid_ready_queues_update[Finalise_IF_assms, simp]: + "equiv_asid asid (ready_queues_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (ready_queues_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma arch_finalise_cap_makes_halted[Finalise_IF_assms]: + "\invs and valid_cap (ArchObjectCap arch_cap) + and (\s. ex = is_final_cap' (ArchObjectCap arch_cap) s) + and cte_wp_at ((=) (ArchObjectCap arch_cap)) slot\ + arch_finalise_cap arch_cap ex + \\rv s. \t \ obj_refs_ac (fst rv). halted_if_tcb t s\" + by (wpsimp simp: arch_finalise_cap_def) + +(* FIXME: move *) +lemma set_object_modifies_at_most: + "modifies_at_most aag {pasObjectAbs aag ptr} + (\s. \ asid_pool_at ptr s \ (\asid_pool. obj \ ArchObj (ASIDPool asid_pool))) + (set_object ptr obj)" + apply (rule modifies_at_mostI) + apply (wp set_object_equiv_but_for_labels) + apply clarsimp + done + +lemma set_thread_state_reads_respects[Finalise_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l (\s. is_subject aag (cur_thread s)) (set_thread_state ref ts)" + unfolding set_thread_state_def fun_app_def + apply (simp add: bind_assoc[symmetric]) + apply (rule pre_ev) + apply (rule_tac P'=\ in bind_ev) + apply (rule set_thread_state_act_reads_respects) + apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") + apply (wp set_object_reads_respects gets_the_ev) + apply (fastforce simp: get_tcb_def split: option.splits + elim: reads_equivE affects_equivE equiv_forE) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_bind) + apply (rule equiv_valid_rv_trivial) + apply (wp | simp)+ + apply (rule_tac P=\ and P'=\ and L="{pasObjectAbs aag ref}" and L'="{pasObjectAbs aag ref}" + in ev2_invisible[OF domains_distinct]) + apply (blast | simp add: labels_are_invisible_def)+ + apply (rule set_object_modifies_at_most) + apply (rule set_object_modifies_at_most) + apply (simp | wp)+ + apply (blast dest: get_tcb_not_asid_pool_at) + apply (subst thread_set_def[symmetric, simplified fun_app_def]) + apply (wp | simp)+ + done + +lemma set_thread_state_runnable_reads_respects[Finalise_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "runnable ts \ reads_respects aag l \ (set_thread_state ref ts)" + unfolding set_thread_state_def fun_app_def + apply (simp add: bind_assoc[symmetric]) + apply (rule pre_ev) + apply (rule_tac P'=\ in bind_ev) + apply (rule set_thread_state_act_runnable_reads_respects) + apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") + apply (wp set_object_reads_respects gets_the_ev) + apply (fastforce simp: get_tcb_def split: option.splits elim: reads_equivE affects_equivE equiv_forE) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_bind) + apply (rule equiv_valid_rv_trivial) + apply (wp | simp)+ + apply (rule_tac P=\ and P'=\ and L="{pasObjectAbs aag ref}" and L'="{pasObjectAbs aag ref}" + in ev2_invisible[OF domains_distinct]) + apply (blast | simp add: labels_are_invisible_def)+ + apply (rule set_object_modifies_at_most) + apply (rule set_object_modifies_at_most) + apply (simp | wp)+ + apply (blast dest: get_tcb_not_asid_pool_at) + apply (subst thread_set_def[symmetric, simplified fun_app_def]) + apply (wp thread_set_st_tcb_at | simp)+ + done + +lemma set_bound_notification_none_reads_respects[Finalise_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l \ (set_bound_notification ref None)" + unfolding set_bound_notification_def fun_app_def + apply (rule pre_ev(5)[where Q=\]) + apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") + apply (wp set_object_reads_respects gets_the_ev)[1] + apply (fastforce simp: get_tcb_def split: option.splits elim: reads_equivE affects_equivE equiv_forE) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_bind) + apply (rule equiv_valid_rv_trivial) + apply (wp | simp)+ + apply (rule_tac P=\ and P'=\ and L="{pasObjectAbs aag ref}" and L'="{pasObjectAbs aag ref}" + in ev2_invisible[OF domains_distinct]) + apply (blast | simp add: labels_are_invisible_def)+ + apply (rule set_object_modifies_at_most) + apply (rule set_object_modifies_at_most) + apply (simp | wp)+ + apply (blast dest: get_tcb_not_asid_pool_at) + apply simp + done + +lemma set_tcb_queue_reads_respects[Finalise_IF_assms, wp]: + "reads_respects aag l \ (set_tcb_queue d prio queue)" + unfolding equiv_valid_def2 equiv_valid_2_def + apply (clarsimp simp: set_tcb_queue_def bind_def modify_def put_def get_def) + apply (rule conjI) + apply (rule reads_equiv_ready_queues_update, assumption) + apply (fastforce simp: reads_equiv_def affects_equiv_def states_equiv_for_def equiv_for_def) + apply (rule affects_equiv_ready_queues_update, assumption) + apply (clarsimp simp: reads_equiv_def affects_equiv_def states_equiv_for_def equiv_for_def + equiv_asids_def equiv_asid_def) + apply (rule ext) + apply force + done + +lemma set_tcb_queue_modifies_at_most: + "modifies_at_most aag L (\s. pasDomainAbs aag d \ L \ {}) (set_tcb_queue d prio queue)" + apply (rule modifies_at_mostI) + apply (simp add: set_tcb_queue_def modify_def, wp) + apply (force simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def equiv_asids_def) + done + +lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag ntfnptr \ L)\ + set_notification ntfnptr ntfn + \\_. equiv_but_for_labels aag L st\" + unfolding set_simple_ko_def + apply (wp set_object_equiv_but_for_labels get_object_wp) + apply (clarsimp simp: asid_pool_at_kheap partial_inv_def obj_at_def split: kernel_object.splits) + done + +lemma thread_set_reads_respects[Finalise_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l \ (thread_set x y)" + unfolding thread_set_def fun_app_def + apply (case_tac "aag_can_read aag y \ aag_can_affect aag l y") + apply (wp set_object_reads_respects) + apply (clarsimp, rule reads_affects_equiv_get_tcb_eq, simp+)[1] + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_guard_imp) + apply (rule_tac L="{pasObjectAbs aag y}" and L'="{pasObjectAbs aag y}" + in ev2_invisible[OF domains_distinct]) + apply (assumption | simp add: labels_are_invisible_def)+ + apply (rule modifies_at_mostI[where P="\"] + | wp set_object_equiv_but_for_labels + | simp + | (clarify, drule get_tcb_not_asid_pool_at))+ + done + +lemma aag_cap_auth_ASIDPoolCap: + "pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap r asid)) \ + pas_refined aag s \ is_subject aag r" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_PageDirectory: + "pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word (Some a))) \ + pas_refined aag s \ is_subject aag word" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_ASIDPoolCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap r asid)); asid' \ 0; + asid_high_bits_of asid' = asid_high_bits_of asid; pas_refined aag s \ + \ is_subject_asid aag asid'" + apply (frule (1) aag_cap_auth_ASIDPoolCap) + apply (unfold aag_cap_auth_def) + apply (rule is_subject_into_is_subject_asid) + apply auto + done + +lemma aag_cap_auth_PageCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (FrameCap dev ref r sz (Some (a, b)))); pas_refined aag s \ + \ is_subject_asid aag a" + by (auto simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + +lemma aag_cap_auth_PageTableCap: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word option)); pas_refined aag s \ + \ is_subject aag word" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_PageTableCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word (Some (a, b)))); pas_refined aag s \ + \ is_subject_asid aag a" + by (auto simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + +lemma aag_cap_auth_PageDirectoryCap: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word option)); pas_refined aag s \ + \ is_subject aag word" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_PageDirectoryCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word (Some (a,vref)))); pas_refined aag s \ + \ is_subject_asid aag a" + unfolding aag_cap_auth_def + by (auto simp: cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + +lemmas aag_cap_auth_subject = aag_cap_auth_ASIDPoolCap_asid + aag_cap_auth_PageCap_asid + aag_cap_auth_PageTableCap_asid + +lemma prepare_thread_delete_reads_respects_f[Finalise_IF_assms]: + "reads_respects_f aag l \ (prepare_thread_delete thread)" + unfolding prepare_thread_delete_def by wp + +lemma arch_finalise_cap_reads_respects[Finalise_IF_assms]: + "reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and K (pas_cap_cur_auth aag (ArchObjectCap cap))) + (arch_finalise_cap cap final)" + unfolding arch_finalise_cap_def + apply (rule gen_asm_ev) + apply (case_tac cap) + apply simp + apply (simp split: bool.splits) + apply (intro impI conjI) + by (wp delete_asid_pool_reads_respects unmap_page_reads_respects unmap_page_table_reads_respects + delete_asid_reads_respects find_vspace_for_asid_reads_respects + | simp add: invs_psp_aligned invs_vspace_objs invs_valid_objs valid_cap_def + valid_arch_state_asid_table invs_arch_state wellformed_mapdata_def + split: option.splits bool.splits + | intro impI conjI allI + | elim conjE + | drule cte_wp_valid_cap + | fastforce dest: aag_can_read_own_asids aag_cap_auth_subject)+ + +(*NOTE: Required to dance around the issue of the base potentially + being zero and thus we can't conclude it is in the current subject.*) +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': + "\ pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap p b)); reads_equiv aag s t; pas_refined aag x \ + \ asid_table s (asid_high_bits_of b) = + asid_table t (asid_high_bits_of b)" + apply (subgoal_tac "asid_high_bits_of 0 = asid_high_bits_of 1") + apply (case_tac "b = 0") + apply (subgoal_tac "is_subject_asid aag 1") + apply ((fastforce intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq + aag_cap_auth_ASIDPoolCap_asid)+)[2] + apply (auto intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq + aag_cap_auth_ASIDPoolCap_asid)[1] + apply (simp add: asid_high_bits_of_def asid_low_bits_def) + done + +lemma pt_cap_aligned: + "\ caps_of_state s p = Some (ArchObjectCap (PageTableCap word x)); valid_caps (caps_of_state s) s \ + \ is_aligned word pt_bits" + by (auto simp: obj_ref_of_def pt_bits_def pageBits_def + dest!: cap_aligned_valid[OF valid_capsD, unfolded cap_aligned_def, THEN conjunct1]) + +lemma maskInterrupt_no_mem: + "maskInterrupt a b \\ms. P (underlying_memory ms)\" + by (wpsimp simp: maskInterrupt_def) + +lemma set_irq_state_valid_global_objs: + "set_irq_state state irq \valid_global_objs\" + apply (simp add: set_irq_state_def) + apply (wp modify_wp) + apply (fastforce simp: valid_global_objs_def) + done + +lemma set_irq_state_globals_equiv[Finalise_IF_assms]: + "set_irq_state state irq \globals_equiv st\" + apply (simp add: set_irq_state_def) + apply (wp dmo_no_mem_globals_equiv maskInterrupt_no_mem modify_wp) + apply (simp add: globals_equiv_interrupt_states_update) + done + +lemma set_notification_globals_equiv[Finalise_IF_assms]: + "\globals_equiv st and valid_arch_state\ + set_notification ptr ntfn + \\_. globals_equiv st\" + unfolding set_simple_ko_def + apply (wp set_object_globals_equiv get_object_wp) + apply (fastforce simp: obj_at_def valid_arch_state_def dest: valid_global_arch_objs_pt_at) + done + +lemma delete_asid_globals_equiv: + "\globals_equiv st and valid_arch_state\ + delete_asid asid pt + \\_. globals_equiv st\" + unfolding delete_asid_def + by (wpsimp wp: set_vm_root_globals_equiv set_asid_pool_globals_equiv simp: hwASIDFlush_def) + +lemma arch_finalise_cap_globals_equiv[Finalise_IF_assms]: + "\globals_equiv st and invs and valid_arch_cap cap\ + arch_finalise_cap cap b + \\_. globals_equiv st\" + apply (induct cap; simp add: arch_finalise_cap_def) + by (wp delete_asid_pool_globals_equiv case_option_wp unmap_page_globals_equiv + unmap_page_table_globals_equiv delete_asid_globals_equiv + | wpc | clarsimp simp: valid_arch_cap_def wellformed_mapdata_def)+ + +declare arch_get_sanitise_register_info_def[simp] + +crunch prepare_thread_delete + for globals_equiv[Finalise_IF_assms, wp]: "globals_equiv st" + (wp: dxo_wp_weak) + +lemma set_bound_notification_globals_equiv[Finalise_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_bound_notification ref ts + \\_. globals_equiv s\" + unfolding set_bound_notification_def + apply (wp set_object_globals_equiv dxo_wp_weak |simp)+ + apply (intro impI conjI allI) + by (fastforce simp: valid_arch_state_def obj_at_def tcb_at_def2 get_tcb_def is_tcb_def + dest: get_tcb_SomeD valid_global_arch_objs_pt_at + split: option.splits kernel_object.splits)+ + +end + + +global_interpretation Finalise_IF_1?: Finalise_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Finalise_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy b/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy new file mode 100644 index 0000000000..a76aeae8e2 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy @@ -0,0 +1,182 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchIRQMasks_IF +imports IRQMasks_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems IRQMasks_IF_assms + +declare storeWord_irq_masks_inv[IRQMasks_IF_assms] + +lemma resetTimer_irq_masks[IRQMasks_IF_assms, wp]: + "resetTimer \\s. P (irq_masks s)\" + by (simp add: resetTimer_def | wp no_irq)+ + +lemma delete_objects_irq_masks[IRQMasks_IF_assms, wp]: + "delete_objects ptr bits \\s. P (irq_masks_of_state s)\" + apply (simp add: delete_objects_def) + apply (wp dmo_wp no_irq_mapM_x no_irq | simp add: freeMemory_def no_irq_storeWord)+ + done + +crunch invoke_untyped + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (ignore: delete_objects wp: crunch_wps dmo_wp + wp: mapME_x_inv_wp preemption_point_inv + simp: crunch_simps no_irq_clearMemory mapM_x_def_bak unless_def) + +crunch finalise_cap + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + ( wp: crunch_wps dmo_wp no_irq + simp: crunch_simps no_irq_setVSpaceRoot no_irq_hwASIDFlush) + +crunch send_signal, timer_tick + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: crunch_wps ignore: do_machine_op wp: dmo_wp simp: crunch_simps) + +lemma handle_interrupt_irq_masks[IRQMasks_IF_assms]: + notes no_irq[wp del] + shows + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and K (irq \ maxIRQ)\ + handle_interrupt irq + \\rv s. P (irq_masks_of_state s)\" + apply (rule hoare_gen_asm) + apply (simp add: handle_interrupt_def split del: if_split) + apply (rule hoare_pre) + apply (rule hoare_if) + apply simp + apply (wp dmo_wp + | simp add: ackInterrupt_def maskInterrupt_def when_def split del: if_split + | wpc + | simp add: get_irq_state_def handle_reserved_irq_def + | wp (once) hoare_drop_imp)+ + done + +lemma arch_invoke_irq_control_irq_masks[IRQMasks_IF_assms]: + "\domain_sep_inv False st and arch_irq_control_inv_valid invok\ + arch_invoke_irq_control invok + \\_ s. P (irq_masks_of_state s)\" + apply (case_tac invok) + apply (clarsimp simp: arch_irq_control_inv_valid_def domain_sep_inv_def valid_def) + done + +crunch handle_vm_fault, handle_hypervisor_fault + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp no_irq) + +lemma dmo_getActiveIRQ_irq_masks[IRQMasks_IF_assms, wp]: + "do_machine_op (getActiveIRQ in_kernel) \\s. P (irq_masks_of_state s)\" + apply (rule hoare_pre, rule dmo_wp) + apply (simp add: getActiveIRQ_def | wp | simp add: no_irq_def | clarsimp)+ + done + +lemma dmo_getActiveIRQ_return_axiom[IRQMasks_IF_assms, wp]: + "\\\ do_machine_op (getActiveIRQ in_kernel) \\rv s. (\x. rv = Some x \ x \ maxIRQ)\" + apply (simp add: getActiveIRQ_def) + apply (rule hoare_pre, rule dmo_wp) + apply (insert irq_oracle_max_irq) + apply (wp dmo_getActiveIRQ_irq_masks) + apply clarsimp + done + +crunch activate_thread, handle_spurious_irq + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + +crunch schedule + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp crunch_wps dxo_wp_weak simp: crunch_simps) + +end + + +global_interpretation IRQMasks_IF_1?: IRQMasks_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact IRQMasks_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +crunch do_reply_transfer, set_priority, set_flags, arch_post_set_flags + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: crunch_wps empty_slot_irq_masks simp: crunch_simps unless_def) + +crunch arch_perform_invocation + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp crunch_wps no_irq) + +(* FIXME: remove duplication in this proof -- requires getting the wp automation + to do the right thing with dropping imps in validE goals *) +lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and tcb_inv_wf tinv\ + invoke_tcb tinv + \\_ s. P (irq_masks_of_state s)\" + apply (case_tac tinv) + apply((wp restart_irq_masks hoare_vcg_if_lift mapM_x_wp[OF _ subset_refl] + | wpc + | simp split del: if_split add: check_cap_at_def + | clarsimp)+)[3] + defer + apply ((wp | simp )+)[2] + (* NotificationControl *) + apply (rename_tac option) + apply (case_tac option) + apply ((wp | simp)+)[2] + (* just ThreadControl left *) + apply (simp add: split_def cong: option.case_cong) + apply wpsimp+ + apply (rule hoare_strengthen_postE[OF cap_delete_irq_masks[where P=P]]) + apply blast + apply blast + apply (wpsimp wp: hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R hoare_vcg_all_lift hoare_drop_imps + checked_cap_insert_domain_sep_inv)+ + apply (rule_tac Q'="\ r s. domain_sep_inv False st s \ P (irq_masks_of_state s)" + and E'="\_ s. P (irq_masks_of_state s)" in hoare_strengthen_postE) + apply (wp hoare_vcg_conj_liftE1 cap_delete_irq_masks) + apply fastforce + apply blast + apply (wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift checked_cap_insert_domain_sep_inv)+ + apply (rule_tac Q'="\ r s. domain_sep_inv False st s \ P (irq_masks_of_state s)" + and E'="\_ s. P (irq_masks_of_state s)" in hoare_strengthen_postE) + apply (wp hoare_vcg_conj_liftE1 cap_delete_irq_masks) + apply fastforce + apply blast + apply (simp add: option_update_thread_def | wp hoare_weak_lift_imp hoare_vcg_all_lift | wpc)+ + by fastforce+ + +lemma init_arch_objects_irq_masks: + "init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_masks_of_state s)\" + by (rule init_arch_objects_inv) + +crunch arch_prepare_set_domain + for inv[IRQMasks_IF_assms,wp]: P + +end + + +global_interpretation IRQMasks_IF_2?: IRQMasks_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact IRQMasks_IF_assms)?) +qed + + +requalify_facts + AARCH64.init_arch_objects_irq_masks + AARCH64.arch_activate_idle_thread_irq_masks + AARCH64.retype_region_irq_masks + +declare + init_arch_objects_irq_masks[wp] + arch_activate_idle_thread_irq_masks[wp] + retype_region_irq_masks[wp] + +end diff --git a/proof/infoflow/AARCH64/ArchInfoFlow.thy b/proof/infoflow/AARCH64/ArchInfoFlow.thy new file mode 100644 index 0000000000..20ed8281a3 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchInfoFlow.thy @@ -0,0 +1,73 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInfoFlow +imports + "Access.ArchSyscall_AC" + "Lib.EquivValid" +begin + +context Arch begin global_naming AARCH64 + +section \Arch-specific equivalence properties\ + +subsection \ASID equivalence\ + +definition equiv_asid :: "asid \ det_ext state \ det_ext state \ bool" where + "equiv_asid asid s s' \ + ((arm_asid_table (arch_state s) (asid_high_bits_of asid)) = + (arm_asid_table (arch_state s') (asid_high_bits_of asid))) \ + (\pool_ptr. arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some pool_ptr + \ asid_pool_at pool_ptr s = asid_pool_at pool_ptr s' \ + (\asid_pool asid_pool'. asid_pools_of s pool_ptr = Some asid_pool \ + asid_pools_of s' pool_ptr = Some asid_pool' + \ asid_pool (asid_low_bits_of asid) = + asid_pool' (asid_low_bits_of asid)))" + +definition equiv_asid' where + "equiv_asid' asid pool_ptr_opt pool_ptr_opt' kh kh' \ + (case pool_ptr_opt of None \ pool_ptr_opt' = None + | Some pool_ptr \ + (case pool_ptr_opt' of None \ False + | Some pool_ptr' \ + (pool_ptr' = pool_ptr \ + ((\asid_pool. kh pool_ptr = Some (ArchObj (ASIDPool asid_pool))) = + (\asid_pool'. kh' pool_ptr' = Some (ArchObj (ASIDPool asid_pool')))) \ + (\asid_pool asid_pool'. kh pool_ptr = Some (ArchObj (ASIDPool asid_pool)) \ + kh' pool_ptr' = Some (ArchObj (ASIDPool asid_pool')) + \ asid_pool (asid_low_bits_of asid) = + asid_pool' (asid_low_bits_of asid)))))" + +definition non_asid_pool_kheap_update where + "non_asid_pool_kheap_update s kh \ + \x. (\asid_pool. kheap s x = Some (ArchObj (ASIDPool asid_pool)) \ + kh x = Some (ArchObj (ASIDPool asid_pool))) + \ kheap s x = kh x" + + +subsection \Exclusive machine state equivalence\ + +subsection \Global (Kernel) VSpace equivalence\ +(* globals_equiv should be maintained by everything except the scheduler, since + nothing else touches the globals frame *) + +definition arch_globals_equiv :: "obj_ref \ obj_ref \ kheap \ kheap \ arch_state \ + arch_state \ machine_state \ machine_state \ bool" where + "arch_globals_equiv ct it kh kh' as as' ms ms' \ + arm_us_global_vspace as = arm_us_global_vspace as' \ + kh (arm_us_global_vspace as) = kh' (arm_us_global_vspace as)" + +declare arch_globals_equiv_def[simp] + +end + +requalify_consts + AARCH64.equiv_asid + AARCH64.equiv_asid' + AARCH64.arch_globals_equiv + AARCH64.non_asid_pool_kheap_update + +end diff --git a/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy b/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy new file mode 100644 index 0000000000..84c2780a23 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy @@ -0,0 +1,122 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInfoFlow_IF +imports InfoFlow_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems InfoFlow_IF_assms + +lemma asid_pool_at_kheap: + "asid_pool_at ptr s = (\asid_pool. kheap s ptr = Some (ArchObj (ASIDPool asid_pool)))" + by (simp add: atyp_at_eq_kheap_obj) + +lemma equiv_asid: + "equiv_asid asid s s' = equiv_asid' asid (arm_asid_table (arch_state s) (asid_high_bits_of asid)) + (arm_asid_table (arch_state s') (asid_high_bits_of asid)) + (kheap s) (kheap s')" + by (auto simp: equiv_asid_def equiv_asid'_def asid_pool_at_kheap opt_map_def split: option.splits) + +lemma equiv_asids_refl[InfoFlow_IF_assms]: + "equiv_asids R s s" + by (auto simp: equiv_asids_def equiv_asid_def) + +lemma equiv_asids_sym[InfoFlow_IF_assms]: + "equiv_asids R s t \ equiv_asids R t s" + by (auto simp: equiv_asids_def equiv_asid_def) + +lemma equiv_asids_trans[InfoFlow_IF_assms]: + "\ equiv_asids R s t; equiv_asids R t u \ \ equiv_asids R s u" + by (fastforce simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap asid_pools_of_ko_at obj_at_def) + +lemma equiv_asids_non_asid_pool_kheap_update[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ + \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" + apply (clarsimp simp: equiv_asids_def equiv_asid non_asid_pool_kheap_update_def) + apply (fastforce simp: equiv_asid'_def split: option.splits) + done + +lemma equiv_asids_identical_kheap_updates[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; identical_kheap_updates s s' kh kh' \ + \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" + apply (clarsimp simp: equiv_asids_def equiv_asid_def opt_map_def + asid_pool_at_kheap identical_kheap_updates_def) + apply (case_tac "kh pool_ptr = kh' pool_ptr"; fastforce) + done + +lemma equiv_asids_trivial[InfoFlow_IF_assms]: + "(\x. P x \ False) \ equiv_asids P x y" + by (auto simp: equiv_asids_def) + +lemma equiv_asids_triv': + "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; + arm_asid_table (arch_state t) = arm_asid_table (arch_state s); + arm_asid_table (arch_state t') = arm_asid_table (arch_state s') \ + \ equiv_asids R t t'" + by (fastforce simp: equiv_asids_def equiv_asid equiv_asid'_def) + +lemma equiv_asids_triv[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; + arch_state t = arch_state s; arch_state t' = arch_state s' \ + \ equiv_asids R t t'" + by (fastforce simp: equiv_asids_triv') + +lemma globals_equiv_refl[InfoFlow_IF_assms]: + "globals_equiv s s" + by (simp add: globals_equiv_def idle_equiv_refl) + +lemma globals_equiv_sym[InfoFlow_IF_assms]: + "globals_equiv s t \ globals_equiv t s" + by (auto simp: globals_equiv_def idle_equiv_def) + +lemma globals_equiv_trans[InfoFlow_IF_assms]: + "\ globals_equiv s t; globals_equiv t u \ \ globals_equiv s u" + unfolding globals_equiv_def arch_globals_equiv_def + by clarsimp (metis idle_equiv_trans idle_equiv_def) + +lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" + by (auto simp: equiv_asids_def) + +lemma dmo_loadWord_rev[InfoFlow_IF_assms]: + "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) + (do_machine_op (loadWord p))" + apply (rule gen_asm_ev) + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_hoist_guard) + apply (rule do_machine_op_spec_rev) + apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) + apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" and Q="\\" and Q'="\\" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule_tac R'="(=)" and Q="\r s. p && mask 3 = 0" and Q'="\r s. p && mask 3 = 0" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule return_ev2) + apply (rule_tac f="word_rcat" in arg_cong) + apply (clarsimp simp: upto.simps) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def) + apply (rule assert_ev2[OF refl]) + apply (rule assert_wp)+ + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) + apply (erule equiv_forD) + apply fastforce + apply (wp wp_post_taut loadWord_inv | simp)+ + done + +end + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchInterrupt_IF.thy b/proof/infoflow/AARCH64/ArchInterrupt_IF.thy new file mode 100644 index 0000000000..ae4a9dcb45 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchInterrupt_IF.thy @@ -0,0 +1,55 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInterrupt_IF +imports Interrupt_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Interrupt_IF_assms + +lemma arch_invoke_irq_handler_reads_respects[Interrupt_IF_assms, wp]: + "reads_respects_f aag l (silc_inv aag st) (arch_invoke_irq_handler irq)" + apply (cases irq; wpsimp simp: plic_complete_claim_def) + apply (rule reads_respects_f[OF dmo_mol_reads_respects, where Q=\, simplified]) + apply wpsimp + done + +lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: + "reads_respects aag (l :: 'a subject_label) (K (arch_authorised_irq_ctl_inv aag i)) + (arch_invoke_irq_control i)" + apply (cases i) + apply (simp add: setIRQTrigger_def) + apply (wp cap_insert_reads_respects set_irq_state_reads_respects dmo_mol_reads_respects | simp)+ + apply (clarsimp simp: arch_authorised_irq_ctl_inv_def) + done + +lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: + "\globals_equiv st and valid_arch_state and valid_global_objs\ + arch_invoke_irq_control ai + \\_. globals_equiv st\" + apply (induct ai) + apply (simp add: setIRQTrigger_def) + apply (wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs + cap_insert_globals_equiv'' dmo_mol_globals_equiv) + done + +lemma arch_invoke_irq_handler_globals_equiv[Interrupt_IF_assms, wp]: + "arch_invoke_irq_handler irq \globals_equiv st\" + by (cases irq; wpsimp wp: dmo_no_mem_globals_equiv simp: plic_complete_claim_def) + +end + + +global_interpretation Interrupt_IF_1?: Interrupt_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Interrupt_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchIpc_IF.thy b/proof/infoflow/AARCH64/ArchIpc_IF.thy new file mode 100644 index 0000000000..fe762a1192 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchIpc_IF.thy @@ -0,0 +1,472 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchIpc_IF +imports Ipc_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Ipc_IF_assms + +lemma lookup_ipc_buffer_reads_respects[Ipc_IF_assms]: + "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) + (lookup_ipc_buffer is_receiver thread)" + unfolding lookup_ipc_buffer_def + by (wp thread_get_reads_respects get_cap_reads_respects | wpc | simp)+ + +lemma as_user_equiv_but_for_labels[Ipc_IF_assms]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag thread \ L)\ + as_user thread f + \\_. equiv_but_for_labels aag L st\" + unfolding as_user_def + apply (wp set_object_equiv_but_for_labels | simp add: split_def)+ + apply (blast dest: get_tcb_not_asid_pool_at) + done + +lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: + "\\ms. equiv_but_for_labels aag L st (s\machine_state := ms\) \ + for_each_byte_of_word (\x. pasObjectAbs aag x \ L) p\ + storeWord p v + \\_ ms. equiv_but_for_labels aag L st (s\machine_state := ms\)\" + unfolding storeWord_def + apply (wp modify_wp) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (rule states_equiv_forI) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) + apply (simp add: states_equiv_for_def) + apply (rule conjI) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=underlying_memory in equiv_forD,fastforce) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=device_state in equiv_forD,fastforce) + apply clarsimp + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) + done + +lemma set_thread_state_runnable_equiv_but_for_labels[Ipc_IF_assms]: + "runnable tst + \ \equiv_but_for_labels aag L st and K (pasObjectAbs aag thread \ L)\ + set_thread_state thread tst + \\_. equiv_but_for_labels aag L st\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_equiv_but_for_labels[THEN hoare_set_object_weaken_pre] + set_thread_state_act_runnable_equiv_but_for_labels) + apply (wpsimp wp: set_object_wp)+ + apply (fastforce dest: get_tcb_not_asid_pool_at simp: st_tcb_at_def obj_at_def) + done + +lemma set_endpoint_equiv_but_for_labels[Ipc_IF_assms]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag epptr \ L)\ + set_endpoint epptr ep + \\_. equiv_but_for_labels aag L st\" + unfolding set_simple_ko_def + apply (wp set_object_equiv_but_for_labels get_object_wp) + apply (clarsimp simp: asid_pool_at_kheap partial_inv_def obj_at_def split: kernel_object.splits) + done + +(* FIXME move *) +lemma conj_imp: + "\ Q \ R; P \ Q; P' \ Q \ \ (P \ R) \ (P' \ R)" + by fastforce + +(* basically clagged directly from lookup_ipc_buffer_has_auth *) +lemma lookup_ipc_buffer_has_read_auth[Ipc_IF_assms]: + "\pas_refined aag and valid_objs\ + lookup_ipc_buffer is_receiver thread + \\rv s. ipc_buffer_has_read_auth aag (pasObjectAbs aag thread) rv\" + apply (rule hoare_pre) + apply (simp add: lookup_ipc_buffer_def) + apply (wp get_cap_wp thread_get_wp' | wpc)+ + apply (clarsimp simp: cte_wp_at_caps_of_state ipc_buffer_has_read_auth_def get_tcb_ko_at[symmetric]) + apply (frule caps_of_state_tcb_cap_cases [where idx = "tcb_cnode_index 4"]) + apply (simp add: dom_tcb_cap_cases) + apply (frule (1) caps_of_state_valid_cap) + apply (clarsimp simp: vm_read_only_def vm_read_write_def) + apply (rule_tac Q="AllowRead \ xb" in conj_imp) + apply (clarsimp simp: valid_cap_simps cap_aligned_def) + apply (rule conjI) + apply (erule aligned_add_aligned) + apply (rule is_aligned_andI1) + apply (drule (1) valid_tcb_objs) + apply (clarsimp simp: valid_obj_def valid_tcb_def valid_ipc_buffer_cap_def + split: if_splits) + apply (rule order_trans [OF _ pbfs_atleast_pageBits]) + apply (simp add: msg_align_bits pageBits_def) + apply (drule (1) cap_auth_caps_of_state) + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + vspace_cap_rights_to_auth_def vm_read_only_def) + apply (drule bspec) + apply (erule (3) ipcframe_subset_page) + apply (simp_all) + done + +lemma cptrs_in_ipc_buffer[Ipc_IF_assms]: + "\ n \ set [buffer_cptr_index ..< buffer_cptr_index + unat (mi_extra_caps mi)]; + is_aligned (p :: obj_ref) msg_align_bits; + buffer_cptr_index + unat (mi_extra_caps mi) < 2 ^ (msg_align_bits - word_size_bits) \ + \ ptr_range (p + of_nat n * of_nat word_size) word_size_bits \ ptr_range p msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits' word_size_bits_def word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits' word_bits_def word_size_bits_def)+ + done + +lemma msg_in_ipc_buffer[Ipc_IF_assms]: + "\ n = msg_max_length \ n < msg_max_length; is_aligned p msg_align_bits; + unat (mi_length mi) < 2 ^ (msg_align_bits - word_size_bits) \ + \ ptr_range (p + of_nat n * of_nat word_size) word_size_bits + \ ptr_range (p :: obj_ref) msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def)+ + apply (simp add: image_def) + apply (rule_tac x=n in bexI) + apply (rule refl) + apply (auto simp: msg_max_length_def) + done + +lemma arch_derive_cap_reads_respects[Ipc_IF_assms]: + "reads_respects aag l \ (arch_derive_cap cap)" + unfolding arch_derive_cap_def fun_app_def + apply (rule equiv_valid_guard_imp) + apply (wp | wpc)+ + apply (simp) + done + +lemma arch_derive_cap_rev[Ipc_IF_assms]: + "reads_equiv_valid_inv aag l \ (arch_derive_cap cap)" + unfolding arch_derive_cap_def fun_app_def + apply (rule equiv_valid_guard_imp) + apply (wp | wpc)+ + apply (simp) + done + +lemma captransfer_in_ipc_buffer[Ipc_IF_assms]: + "\ is_aligned (buf :: obj_ref) msg_align_bits; n \ {0..2} \ + \ ptr_range (buf + (2 + (of_nat msg_max_length + of_nat msg_max_extra_caps)) * word_size + + n * word_size) + word_size_bits + \ ptr_range buf msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def)+ + apply (simp add: image_def msg_max_length_def msg_max_extra_caps_def) + apply (rule_tac x="(125::nat) + unat n" in bexI) + apply simp+ + apply (fastforce intro: unat_less_helper word_leq_minus_one_le) + done + +lemma mrs_in_ipc_buffer[Ipc_IF_assms]: + "\ n \ set [length msg_registers + 1 ..< Suc n']; + is_aligned (buf :: obj_ref) msg_align_bits; n' < 2 ^ (msg_align_bits - word_size_bits) \ + \ ptr_range (buf + of_nat n * of_nat word_size) word_size_bits \ ptr_range buf msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def word_size_bits_def)+ + apply (simp add: image_def) + apply (rule_tac x=n in bexI) + apply (rule refl) + apply (fastforce split: if_split_asm) + done + +lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: + "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) + (do_machine_op (loadWord p))" + apply (rule gen_asm_ev) + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_hoist_guard) + apply (rule do_machine_op_spec_reads_respects) + apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) + apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" + and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule_tac R'="(=)" and Q="\ r s. p && mask 3 = 0" and Q'="\ r s. p && mask 3 = 0" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule return_ev2) + apply (rule_tac f="word_rcat" in arg_cong) + apply (fastforce simp: upto.simps is_aligned_mask for_each_byte_of_word_def word_size_def + intro: is_aligned_no_wrap' word_plus_mono_right) + apply (rule assert_ev2[OF refl]) + apply (rule assert_wp)+ + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) + apply (fastforce elim: equiv_forD orthD1 simp: ptr_range_def add.commute) + apply (wp wp_post_taut loadWord_inv | simp)+ + done + +lemma complete_signal_reads_respects[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (K (aag_can_read aag ntfnptr \ aag_can_affect aag l ntfnptr)) + (complete_signal ntfnptr receiver)" + unfolding complete_signal_def + by (wp set_simple_ko_reads_respects get_simple_ko_reads_respects as_user_set_register_reads_respects' + | wpc | simp)+ + +lemma handle_arch_fault_reply_reads_respects[Ipc_IF_assms, wp]: + "reads_respects aag l (K (aag_can_read aag thread)) (handle_arch_fault_reply afault thread x y)" + by (simp add: handle_arch_fault_reply_def, wp) + +lemma arch_get_sanitise_register_info_reads_respects[Ipc_IF_assms, wp]: + "reads_respects aag l \ (arch_get_sanitise_register_info t)" + by wpsimp + +declare arch_get_sanitise_register_info_inv[Ipc_IF_assms] + +lemma lookup_ipc_buffer_ptr_range'[Ipc_IF_assms]: + "\valid_objs\ + lookup_ipc_buffer True thread + \\rv s. rv = Some buf' \ auth_ipc_buffers s thread = ptr_range buf' msg_align_bits\" + unfolding lookup_ipc_buffer_def + apply (rule hoare_pre) + apply (wp get_cap_wp thread_get_wp' | wpc)+ + apply (clarsimp simp: cte_wp_at_caps_of_state ipc_buffer_has_auth_def get_tcb_ko_at [symmetric]) + apply (frule caps_of_state_tcb_cap_cases [where idx = "tcb_cnode_index 4"]) + apply (simp add: dom_tcb_cap_cases) + apply (clarsimp simp: auth_ipc_buffers_def get_tcb_ko_at [symmetric]) + apply (drule(1) valid_tcb_objs) + apply (drule get_tcb_SomeD)+ + apply (simp add: vm_read_write_def valid_tcb_def valid_ipc_buffer_cap_def split: bool.splits) + done + +lemma lookup_ipc_buffer_aligned'[Ipc_IF_assms]: + "\valid_objs\ + lookup_ipc_buffer True thread + \\rv s. rv = Some buf' \ is_aligned buf' msg_align_bits\" + apply (insert lookup_ipc_buffer_aligned) + apply (fastforce simp: valid_def) + done + +lemma handle_arch_fault_reply_globals_equiv[Ipc_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ + handle_arch_fault_reply vmf thread x y + \\_. globals_equiv st\" + by (wpsimp simp: handle_arch_fault_reply_def)+ + +crunch arch_get_sanitise_register_info, handle_arch_fault_reply + for valid_global_objs[Ipc_IF_assms, wp]: "valid_global_objs" + +crunch handle_arch_fault_reply + for valid_arch_state[Ipc_IF_assms,wp]: "\s :: det_state. valid_arch_state s" + +lemma transfer_caps_loop_valid_arch[Ipc_IF_assms]: + "transfer_caps_loop ep buffer n caps slots mi \valid_arch_state :: det_ext state \ _\" + by (wp valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at) + +end + + +global_interpretation Ipc_IF_1?: Ipc_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Ipc_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma copy_mrs_reads_respects[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag (l :: 'a subject_label) + (K (aag_can_read_or_affect aag l sender \ aag_can_read_or_affect_ipc_buffer aag l sbuf + \ unat n < 2 ^ (msg_align_bits - word_size_bits))) + (copy_mrs sender sbuf receiver rbuf n)" + unfolding copy_mrs_def fun_app_def + apply (rule gen_asm_ev) + apply (wp mapM_ev'' store_word_offs_reads_respects load_word_offs_reads_respects + as_user_set_register_reads_respects' as_user_reads_respects + | wpc + | simp add: det_setRegister det_getRegister split del: if_split)+ + apply clarsimp + apply (rename_tac n') + apply (subgoal_tac "ptr_range (x + of_nat n' * of_nat word_size) word_size_bits + \ ptr_range x msg_align_bits") + apply (simp add: for_each_byte_of_word_def2) + apply (simp add: aag_can_read_or_affect_ipc_buffer_def) + apply (erule conjE) + apply (rule ballI) + apply (erule bspec) + apply (erule (1) subsetD[rotated]) + apply (rule ptr_range_subset) + apply (simp add: aag_can_read_or_affect_ipc_buffer_def) + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def word_size_bits_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def aag_can_read_or_affect_ipc_buffer_def )+ + apply (fastforce simp: image_def) + done + +lemma get_message_info_reads_respects[Ipc_IF_assms]: + "reads_respects aag (l :: 'a subject_label) (K (aag_can_read_or_affect aag l ptr)) (get_message_info ptr)" + apply (simp add: get_message_info_def) + apply (wp as_user_reads_respects | clarsimp simp: getRegister_def)+ + done + +lemma do_normal_transfer_reads_respects[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag (l :: 'a subject_label) + (pas_refined aag and valid_mdb and valid_objs + and K (aag_can_read_or_affect aag l sender \ + ipc_buffer_has_read_auth aag (pasObjectAbs aag sender) sbuf \ + ipc_buffer_has_read_auth aag (pasObjectAbs aag receiver) rbuf \ + (grant \ (is_subject aag sender \ is_subject aag receiver)))) + (do_normal_transfer sender sbuf endpoint badge grant receiver rbuf)" + apply (cases grant) + apply (rule gen_asm_ev) + apply (simp add: do_normal_transfer_def) + apply (wp copy_mrs_pas_refined get_message_info_rev lookup_extra_caps_rev + as_user_set_register_reads_respects' set_message_info_reads_respects + transfer_caps_reads_respects copy_mrs_reads_respects lookup_extra_caps_rev + lookup_extra_caps_authorised lookup_extra_caps_auth get_message_info_rev + get_mi_length' get_mi_length validE_E_wp_post_taut + copy_mrs_cte_wp_at hoare_vcg_ball_lift lec_valid_cap' + lookup_extra_caps_srcs[simplified ball_conj_distrib,THEN hoare_conjDR1] + lookup_extra_caps_srcs[simplified ball_conj_distrib,THEN hoare_conjDR2] + | wpc + | simp add: det_setRegister ball_conj_distrib)+ + apply (fastforce intro: aag_has_read_auth_can_read_or_affect_ipc_buffer) + apply (rule gen_asm_ev) + apply (simp add: do_normal_transfer_def transfer_caps_def) + apply (wp ev_irrelevant_bind[where f="get_receive_slots receiver rbuf"] + as_user_set_register_reads_respects' + set_message_info_reads_respects copy_mrs_reads_respects + get_message_info_reads_respects get_mi_length + | wpc + | simp)+ + apply (auto simp: ipc_buffer_has_read_auth_def aag_can_read_or_affect_ipc_buffer_def + dest: reads_read_thread_read_pages split: option.splits) + done + +lemma make_arch_fault_msg_reads_respects[Ipc_IF_assms]: + "reads_respects aag (l :: 'a subject_label) (\y. aag_can_read_or_affect aag l sender) + (make_arch_fault_msg x4 sender)" + apply (case_tac x4) + apply (wp as_user_reads_respects | simp add: det_getRegister det_getRestartPC)+ + done + +lemma set_mrs_equiv_but_for_labels[Ipc_IF_assms]: + "\equiv_but_for_labels (aag :: 'a subject_label PAS) L st and + K (pasObjectAbs aag thread \ L \ + (case buf of (Some buf') \ is_aligned buf' msg_align_bits \ + (\x \ ptr_range buf' msg_align_bits. pasObjectAbs aag x \ L) + | _ \ True))\ + set_mrs thread buf msgs + \\_. equiv_but_for_labels aag L st\" + unfolding set_mrs_def + apply (wp | wpc)+ + apply (subst zipWithM_x_mapM_x) + apply (rule_tac Q'="\_. equiv_but_for_labels aag L st and K (pasObjectAbs aag thread \ L \ + (case buf of (Some buf') \ is_aligned buf' msg_align_bits \ + (\x \ ptr_range buf' msg_align_bits. + pasObjectAbs aag x \ L) + | _ \ True))" in hoare_strengthen_post) + apply (wp mapM_x_wp' store_word_offs_equiv_but_for_labels | simp add: split_def)+ + apply (case_tac x, clarsimp split: if_split_asm elim!: in_set_zipE) + apply (clarsimp simp: for_each_byte_of_word_def) + apply (erule bspec) + apply (clarsimp simp: ptr_range_def) + apply (rule conjI) + apply (erule order_trans[rotated]) + apply (erule is_aligned_no_wrap') + apply (rule mul_word_size_lt_msg_align_bits_ofnat) + apply (fastforce simp: msg_max_length_def msg_align_bits') + apply (erule order_trans) + apply (subst p_assoc_help) + apply (simp add: add.assoc) + apply (rule word_plus_mono_right) + apply (rule word_less_sub_1) + apply (rule_tac y="of_nat msg_max_length * of_nat word_size + (word_size - 1)" + in le_less_trans) + apply (rule word_plus_mono_left) + apply (rule word_mult_le_mono1) + apply (erule disjE) + apply (rule word_of_nat_le) + apply (simp add: msg_max_length_def) + apply clarsimp + apply (rule word_of_nat_le) + apply (simp add: msg_max_length_def) + apply (simp add: word_size_def) + apply (simp add: msg_max_length_def word_size_def) + apply (simp add: msg_max_length_def word_size_def) + apply (rule mul_add_word_size_lt_msg_align_bits_ofnat) + apply (simp add: msg_max_length_def msg_align_bits') + apply (simp add: word_size_def) + apply (erule is_aligned_no_overflow') + apply simp + apply (wp set_object_equiv_but_for_labels hoare_vcg_all_lift hoare_weak_lift_imp | simp)+ + apply (fastforce dest: get_tcb_not_asid_pool_at)+ + done + +lemma set_mrs_reads_respects'[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag (l :: 'a subject_label) + (K (ipc_buffer_has_auth aag thread buf \ + (case buf of (Some buf') \ is_aligned buf' msg_align_bits | _ \ True))) + (set_mrs thread buf msgs)" + apply (case_tac "aag_can_read_or_affect aag l thread") + apply ((wp equiv_valid_guard_imp[OF set_mrs_reads_respects] | simp)+)[1] + apply (rule gen_asm_ev) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_guard_imp) + apply (case_tac buf) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in ev_invisible[OF domains_distinct]) + apply (clarsimp simp: labels_are_invisible_def) + apply (rule modifies_at_mostI) + apply (simp add: set_mrs_def) + apply ((wp set_object_equiv_but_for_labels | simp | auto dest: get_tcb_not_asid_pool_at)+)[1] + apply (simp) + apply (rule set_mrs_ret_eq) + apply (rename_tac buf') + apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) + ` (ptr_range buf' msg_align_bits)" + in ev_invisible[OF domains_distinct]) + apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def + dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] + apply (rule modifies_at_mostI) + apply (wp set_mrs_equiv_but_for_labels | simp)+ + apply (rule set_mrs_ret_eq) + by simp + +end + + +global_interpretation Ipc_IF_2?: Ipc_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Ipc_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchNoninterference.thy b/proof/infoflow/AARCH64/ArchNoninterference.thy new file mode 100644 index 0000000000..2d5183e5ab --- /dev/null +++ b/proof/infoflow/AARCH64/ArchNoninterference.thy @@ -0,0 +1,420 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchNoninterference +imports Noninterference +begin + +context Arch begin global_naming AARCH64 + +named_theorems Noninterference_assms + +(* clagged straight from ADT_AC.do_user_op_respects *) +lemma do_user_op_if_integrity[Noninterference_assms]: + "\invs and integrity aag X st and is_subject aag \ cur_thread and pas_refined aag\ + do_user_op_if uop tc + \\_. integrity aag X st\" + apply (simp add: do_user_op_if_def) + apply (wpsimp wp: dmo_user_memory_update_respects_Write dmo_device_update_respects_Write + hoare_vcg_all_lift hoare_vcg_imp_lift + wp_del: select_wp) + apply (rule hoare_pre_cont) + apply (wp | wpc | clarsimp)+ + apply (rule conjI) + apply clarsimp + apply (simp add: restrict_map_def ptable_lift_s_def ptable_rights_s_def split: if_splits) + apply (drule_tac auth=Write in user_op_access') + apply (simp add: vspace_cap_rights_to_auth_def)+ + apply clarsimp + apply (simp add: restrict_map_def ptable_lift_s_def ptable_rights_s_def split: if_splits) + apply (drule_tac auth=Write in user_op_access') + apply (simp add: vspace_cap_rights_to_auth_def)+ + done + +lemma do_user_op_if_globals_equiv_scheduler[Noninterference_assms]: + "\globals_equiv_scheduler st and invs\ + do_user_op_if tc uop + \\_. globals_equiv_scheduler st\" + apply (simp add: do_user_op_if_def) + apply (wpsimp wp: dmo_user_memory_update_globals_equiv_scheduler + dmo_device_memory_update_globals_equiv_scheduler)+ + apply (auto simp: ptable_lift_s_def ptable_rights_s_def) + done + +crunch do_user_op_if + for silc_dom_equiv[Noninterference_assms, wp]: "silc_dom_equiv aag st" + (ignore: do_machine_op user_memory_update wp: crunch_wps) + +lemma sameFor_scheduler_affects_equiv[Noninterference_assms]: + "\ (s,s') \ same_for aag PSched; (s,s') \ same_for aag (Partition l); + invs (internal_state_if s); invs (internal_state_if s') \ + \ scheduler_equiv aag (internal_state_if s) (internal_state_if s') \ + scheduler_affects_equiv aag (OrdinaryLabel l) (internal_state_if s) (internal_state_if s')" + apply (rule conjI) + apply (blast intro: sameFor_scheduler_equiv) + apply (clarsimp simp: scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + sameFor_def silc_dom_equiv_def reads_scheduler_def sameFor_scheduler_def) + (* simplifying using sameFor_subject_def in assumptions causes simp to loop *) + apply (simp (no_asm_use) add: sameFor_subject_def disjoint_iff_not_equal Bex_def) + apply (blast intro: globals_equiv_to_scheduler_globals_frame_equiv globals_equiv_to_cur_thread_eq) + done + +lemma do_user_op_if_partitionIntegrity[Noninterference_assms]: + "\partitionIntegrity aag st and pas_refined aag and invs and is_subject aag \ cur_thread\ + do_user_op_if tc uop + \\_. partitionIntegrity aag st\" + apply (rule_tac Q'="\rv s. integrity (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + (scheduler_affects_globals_frame st) st s \ + domain_fields_equiv st s \ idle_thread s = idle_thread st \ + globals_equiv_scheduler st s \ silc_dom_equiv aag st s" + in hoare_strengthen_post) + apply (wp hoare_vcg_conj_lift do_user_op_if_integrity do_user_op_if_globals_equiv_scheduler + hoare_vcg_all_lift domain_fields_equiv_lift[where Q="\" and R="\"] | simp)+ + apply (clarsimp simp: partitionIntegrity_def)+ + done + +lemma arch_activate_idle_thread_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (arch_activate_idle_thread t)" + unfolding arch_activate_idle_thread_def by wpsimp + +crunch handle_spurious_irq + for domain[wp]: "\s. Q (domain_time s) (domain_index s) (domain_list s)" + and irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" + +lemma handle_spurious_irq_reads_respect_scheduler[Noninterference_assms]: + "reads_respects_scheduler aag l \ handle_spurious_irq" + unfolding handle_spurious_irq_def + by wpsimp + +definition arch_globals_equiv_strengthener :: "machine_state \ machine_state \ bool" where + "arch_globals_equiv_strengthener ms ms' \ True" + +declare arch_globals_equiv_strengthener_def[simp] + +lemma arch_globals_equiv_strengthener_thread_independent[Noninterference_assms]: + "arch_globals_equiv_strengthener (machine_state s) (machine_state s') + \ \ct ct' it it'. arch_globals_equiv ct it (kheap s) (kheap s') + (arch_state s) (arch_state s') (machine_state s) (machine_state s') = + arch_globals_equiv ct' it' (kheap s) (kheap s') + (arch_state s) (arch_state s') (machine_state s) (machine_state s')" + by auto + +lemma integrity_asids_update_reference_state[Noninterference_assms]: + "is_subject aag t + \ integrity_asids aag {pasSubject aag} x a s (s\kheap := (kheap s)(t \ blah)\)" + by (clarsimp simp: integrity_asids_def opt_map_def) + +lemma inte_obj_arch: + assumes inte_obj: "(integrity_obj_atomic aag activate subjects l)\<^sup>*\<^sup>* ko ko'" + assumes "ko = Some (ArchObj ao)" + assumes "ko \ ko'" + shows "integrity_obj_atomic aag activate subjects l ko ko'" +proof (cases "l \ subjects") + case True + then show ?thesis by (fastforce intro: integrity_obj_atomic.intros) +next + case False + note l = this + have "\ao'. ko = Some (ArchObj ao) \ + ko \ ko' \ + integrity_obj_atomic aag activate subjects l ko ko'" + using inte_obj + proof (induct rule: rtranclp_induct) + case base + then show ?case by clarsimp + next + case (step y z) + have "\ao'. ko' = Some (ArchObj ao')" + using False inte_obj assms + by (auto elim!: rtranclp_induct integrity_obj_atomic.cases) + then show ?case using step.hyps + by (fastforce intro: troa_arch arch_troa_asidpool_clear integrity_obj_atomic.intros + elim!: integrity_obj_atomic.cases arch_integrity_obj_atomic.cases) + qed + then show ?thesis + using assms by fastforce +qed + +lemma asid_pool_into_aag: + "\ pool_for_asid asid s = Some p; kheap s p = Some (ArchObj (ASIDPool pool)); + pool r = Some p'; pas_refined aag s \ + \ abs_has_auth_to aag Control p p'" + apply (rule pas_refined_mem [rotated], assumption) + apply (rule sta_vref) + apply (rule state_vrefsD) + apply (erule pool_for_asid_vs_lookupD) + apply (fastforce simp: aobjs_of_Some) + apply fastforce + apply (fastforce simp: vs_refs_aux_def graph_of_def image_iff) + done + +lemma owns_mapping_owns_asidpool: + "\ pool_for_asid asid s = Some p; kheap s p = Some (ArchObj (ASIDPool pool)); + pool r = Some p'; pas_refined aag s; is_subject aag p'; + pas_wellformed (aag\pasSubject := (pasObjectAbs aag p)\) \ + \ is_subject aag p" + apply (frule asid_pool_into_aag) + apply assumption+ + apply (drule pas_wellformed_pasSubject_update_Control) + apply assumption + apply simp + done + +lemma partitionIntegrity_subjectAffects_aobj': + "\ pool_for_asid asid s = Some x; kheap s x = Some (ArchObj ao); ao \ ao'; + pas_refined aag s; silc_inv aag st s; pas_wellformed_noninterference aag; + arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} (pasObjectAbs aag x) ao ao' \ + \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" + unfolding arch_integrity_obj_atomic.simps asid_pool_integrity_def + apply clarsimp + apply (rule ccontr) + apply (drule fun_noteqD) + apply (erule exE, rename_tac r) + apply (drule_tac x=r in spec) + apply (clarsimp dest!: not_sym[where t=None]) + apply (subgoal_tac "is_subject aag x", force intro: affects_lrefl) + apply (frule (1) aag_Control_into_owns) + apply (frule (3) asid_pool_into_aag) + apply simp + apply (frule (1) pas_wellformed_noninterference_control_to_eq) + apply (fastforce elim!: silc_inv_cnode_onlyE obj_atE simp: is_cap_table_def) + apply clarsimp + done + +lemma partitionIntegrity_subjectAffects_aobj[Noninterference_assms]: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (ArchObj ao)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_refined aag s" + "pas_wellformed_noninterference aag" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" +proof (cases "pasObjectAbs aag x = pasSubject aag") + case True + then show ?thesis by (simp add: subjectAffects.intros(1)) +next + case False + obtain ao' where ao': "kheap s' x = Some (ArchObj ao')" + using assms False inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + have arch_tro: + "arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} (pasObjectAbs aag x) ao ao'" + using assms False ao' inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + obtain asid where asid: "pool_for_asid asid s = Some x" + using assms False inte_obj_arch[OF inte_obj] + integrity_subjects_asids[OF partitionIntegrity_integrity[OF par_inte]] + by (fastforce elim!: integrity_obj_atomic.cases arch_integrity_obj_atomic.cases + simp: integrity_asids_def aobjs_of_Some opt_map_def pool_for_asid_def)+ + show ?thesis + using assms ao' asid arch_tro + by (fastforce dest: partitionIntegrity_subjectAffects_aobj') +qed + +lemma partitionIntegrity_subjectAffects_asid[Noninterference_assms]: + "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; + valid_arch_state s; valid_arch_state s'; pas_wellformed_noninterference aag; + silc_inv aag st s'; invs s'; \ equiv_asids (\x. pasASIDAbs aag x = a) s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (clarsimp simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap) + apply (case_tac "arm_asid_table (arch_state s) (asid_high_bits_of asid) = + arm_asid_table (arch_state s') (asid_high_bits_of asid)") + apply (clarsimp simp: valid_arch_state_def valid_asid_table_def) + apply (erule disjE) + apply (case_tac "kheap s' pool_ptr = None"; clarsimp) + apply (prop_tac "pool_ptr \ dom (asid_pools_of s')") + apply (fastforce simp: not_in_domIff asid_pools_of_ko_at obj_at_def) + apply blast + apply (case_tac "\asid_pool. y = ArchObj (ASIDPool asid_pool)"; clarsimp) + apply (prop_tac "pool_ptr \ dom (asid_pools_of s)") + apply (fastforce simp: not_in_domIff asid_pools_of_ko_at obj_at_def) + apply blast + apply (prop_tac "pool_ptr \ dom (asid_pools_of s')") + apply (fastforce simp: not_in_domIff asid_pools_of_ko_at obj_at_def) + apply blast + apply clarsimp + apply (rule affects_asidpool_map) + apply (rule pas_refined_asid_mem) + apply (drule partitionIntegrity_integrity) + apply (drule integrity_subjects_obj) + apply (drule_tac x="pool_ptr" in spec)+ + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def) + apply (drule tro_tro_alt, erule integrity_obj_alt.cases; simp) + apply (drule_tac t="pasSubject aag" in sym) + apply simp + apply (rule sata_asidpool) + apply assumption + apply assumption + apply (clarsimp simp: arch_integrity_obj_alt.simps asid_pool_integrity_def) + apply (drule_tac x="asid_low_bits_of asid" in spec)+ + apply clarsimp + apply (drule owns_mapping_owns_asidpool[rotated]) + apply ((simp | blast intro: pas_refined_Control[THEN sym] + | fastforce simp: pool_for_asid_def + intro: pas_wellformed_pasSubject_update[simplified])+)[5] + apply (drule_tac t="pasSubject aag" in sym)+ + apply simp + apply (rule sata_asidpool) + apply assumption + apply assumption + apply assumption + apply clarsimp + apply (drule partitionIntegrity_integrity) + apply (clarsimp simp: integrity_def integrity_asids_def) + apply (drule_tac x=asid in spec)+ + apply (fastforce intro: affects_lrefl) + done + +(* clagged mostly from Scheduler_IF.dmo_storeWord_reads_respects_scheduler *) +lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (do_machine_op (storeWord ptr w))" + apply (clarsimp simp: do_machine_op_def bind_def gets_def get_def return_def fail_def + select_f_def storeWord_def assert_def simpler_modify_def) + apply (fold simpler_modify_def) + apply (intro impI conjI) + apply (rule ev_modify) + apply (rule conjI) + apply (fastforce simp: reads_equiv_g_def globals_equiv_def reads_equiv_def2 states_equiv_for_def + equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def upto.simps) + apply (rule affects_equiv_machine_state_update, assumption) + apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def upto.simps) + apply (simp add: equiv_valid_def2 equiv_valid_2_def) + done + +lemma set_vm_root_reads_respects: + "reads_respects aag l \ (set_vm_root tcb)" + by (rule reads_respects_unobservable_unit_return) wp+ + +lemmas set_vm_root_reads_respects_g[wp] = + reads_respects_g[OF set_vm_root_reads_respects, + OF doesnt_touch_globalsI[where P="\"], + simplified, + OF set_vm_root_globals_equiv] + +lemma arch_switch_to_thread_reads_respects_g'[Noninterference_assms]: + "equiv_valid (reads_equiv_g aag) (affects_equiv aag l) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (\s. is_subject aag t) + (arch_switch_to_thread t)" + apply (simp add: arch_switch_to_thread_def) + apply (rule equiv_valid_guard_imp) + by (wp bind_ev_general thread_get_reads_respects_g | simp)+ + +(* consider rewriting the return-value assumption using equiv_valid_rv_inv *) +lemma ev2_invisible'[Noninterference_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\ labels_are_invisible aag l L; labels_are_invisible aag l L'; + modifies_at_most aag L Q f; modifies_at_most aag L' Q' g; + doesnt_touch_globals Q f; doesnt_touch_globals Q' g; + \st :: det_state. f \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; + \st :: det_state. g \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; + \s t. P s \ P' t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (g t). W rva rvb) \ + \ equiv_valid_2 (reads_equiv_g aag) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + W (P and Q) (P' and Q') f g" + apply (clarsimp simp: equiv_valid_2_def) + apply (rule conjI) + apply blast + apply (drule_tac s=s in modifies_at_mostD, assumption+) + apply (drule_tac s=t in modifies_at_mostD, assumption+) + apply (drule_tac s=s in globals_equivI, assumption+) + apply (drule_tac s=t in globals_equivI, assumption+) + apply (frule (1) equiv_but_for_reads_equiv[OF domains_distinct]) + apply (frule_tac s=t in equiv_but_for_reads_equiv[OF domains_distinct], assumption) + apply (drule (1) equiv_but_for_affects_equiv[OF domains_distinct]) + apply (drule_tac s=t in equiv_but_for_affects_equiv[OF domains_distinct], assumption) + apply (clarsimp simp: reads_equiv_g_def) + apply (blast intro: reads_equiv_trans reads_equiv_sym affects_equiv_trans + affects_equiv_sym globals_equiv_trans globals_equiv_sym) + done + +lemma arch_switch_to_idle_thread_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (arch_switch_to_idle_thread)" + apply (simp add: arch_switch_to_idle_thread_def) + apply wp + apply (clarsimp simp: reads_equiv_g_def globals_equiv_idle_thread_ptr) + done + +lemma arch_globals_equiv_threads_eq[Noninterference_assms]: + "arch_globals_equiv t' t'' kh kh' as as' ms ms' + \ arch_globals_equiv t t kh kh' as as' ms ms'" + by clarsimp + +lemma arch_globals_equiv_globals_equiv_scheduler[Noninterference_assms, elim]: + "arch_globals_equiv (cur_thread t) (idle_thread s) (kheap s) (kheap t) + (arch_state s) (arch_state t) (machine_state s) (machine_state t) + \ arch_globals_equiv_scheduler (kheap s) (kheap t) (arch_state s) (arch_state t)" + by (auto simp: arch_globals_equiv_scheduler_def) + +lemma getActiveIRQ_ret_no_dmo[Noninterference_assms, wp]: + "\\\ getActiveIRQ in_kernel \\rv s. \x. rv = Some x \ x \ maxIRQ\" + apply (simp add: getActiveIRQ_def) + apply (rule hoare_pre) + apply (insert irq_oracle_max_irq) + apply (wp dmo_getActiveIRQ_irq_masks) + apply clarsimp + done + +(*FIXME: Move to scheduler_if*) +lemma dmo_getActive_IRQ_reads_respect_scheduler[Noninterference_assms]: + "reads_respects_scheduler aag l (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ in_kernel))" + apply (simp add: getActiveIRQ_def) + apply (simp add: dmo_distr dmo_if_distr dmo_gets_distr dmo_modify_distr cong: if_cong) + apply wp + apply (rule ev_modify[where P=\]) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def + scheduler_globals_frame_equiv_def silc_dom_equiv_def idle_equiv_def) + apply wp + apply (rule_tac P="\s. irq_masks_of_state st = irq_masks_of_state s" in gets_ev') + apply wp + apply clarsimp + apply (simp add: scheduler_equiv_def) + done + +lemma getActiveIRQ_no_non_kernel_IRQs[Noninterference_assms]: + "getActiveIRQ True = getActiveIRQ False" + by (clarsimp simp: getActiveIRQ_def non_kernel_IRQs_def) + +lemma valid_cur_hyp_triv[Noninterference_assms]: + "valid_cur_hyp s" + by (simp add: valid_cur_hyp_def) + +lemma arch_tcb_get_registers_equality[Noninterference_assms]: + "arch_tcb_get_registers (tcb_arch tcb) = arch_tcb_get_registers (tcb_arch tcb') + \ tcb_arch tcb = tcb_arch tcb'" + by (auto simp: arch_tcb_get_registers_def intro: arch_tcb.equality user_context.expand) + +end + + +requalify_consts AARCH64.arch_globals_equiv_strengthener +requalify_facts AARCH64.arch_globals_equiv_strengthener_thread_independent + + +global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv_strengthener +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\)?) +qed + + +sublocale valid_initial_state \ valid_initial_state?: + Noninterference_valid_initial_state arch_globals_equiv_strengthener .. + +end diff --git a/proof/infoflow/AARCH64/ArchPasUpdates.thy b/proof/infoflow/AARCH64/ArchPasUpdates.thy new file mode 100644 index 0000000000..b4d143b856 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchPasUpdates.thy @@ -0,0 +1,123 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchPasUpdates +imports PasUpdates +begin + +context Arch begin + +named_theorems PasUpdates_assms + +crunch arch_post_cap_deletion, arch_finalise_cap, prepare_thread_delete + for domain_fields[PasUpdates_assms, wp]: "domain_fields P" + ( wp: syscall_valid crunch_wps rec_del_preservation cap_revoke_preservation modify_wp + simp: crunch_simps check_cap_at_def filterM_mapM unless_def + ignore: without_preemption filterM rec_del check_cap_at cap_revoke + ignore_del: create_cap_ext cap_insert_ext cap_move_ext + empty_slot_ext cap_swap_ext set_thread_state_act tcb_sched_action reschedule_required) + +end + + +global_interpretation PasUpdates_1?: PasUpdates_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact PasUpdates_assms)?) +qed + + +context Arch begin + +crunch arch_perform_invocation, arch_post_modify_registers, init_arch_objects, + arch_invoke_irq_control, arch_invoke_irq_handler, handle_arch_fault_reply + for domain_fields[PasUpdates_assms, wp]: "domain_fields P" + (wp: syscall_valid crunch_wps mapME_x_inv_wp + simp: crunch_simps check_cap_at_def detype_def mapM_x_defsym + ignore: check_cap_at syscall + ignore_del: set_domain set_priority possible_switch_to + rule: transfer_caps_loop_pres) + +declare init_arch_objects_inv[PasUpdates_assms] + +lemma state_asids_to_policy_aux_pasSubject_update: + "state_asids_to_policy_aux (aag\pasSubject := x\) caps asid vrefs = + state_asids_to_policy_aux aag caps asid vrefs" + apply (rule equalityI) + apply clarify + apply (erule state_asids_to_policy_aux.cases + | simp + | fastforce intro: state_asids_to_policy_aux.intros)+ + apply clarify + apply (erule state_asids_to_policy_aux.cases) + apply (simp, subst pasObjectAbs_pasSubject_update[symmetric] + , subst pasASIDAbs_pasSubject_update[symmetric] + , rule state_asids_to_policy_aux.intros + , assumption+)+ + done + +lemma state_asids_to_policy_pasSubject_update[PasUpdates_assms]: + "state_asids_to_policy (aag\pasSubject := x\) s = + state_asids_to_policy aag s" + by (simp add: state_asids_to_policy_aux_pasSubject_update) + +lemma state_asids_to_policy_aux_pasMayActivate_update: + "state_asids_to_policy_aux (aag\pasMayActivate := x\) caps asid_tab vrefs = + state_asids_to_policy_aux aag caps asid_tab vrefs" + apply (rule equalityI) + apply clarify + apply (erule state_asids_to_policy_aux.cases + | simp + | fastforce intro: state_asids_to_policy_aux.intros)+ + apply clarify + apply (erule state_asids_to_policy_aux.cases) + apply (simp, subst pasObjectAbs_pasMayActivate_update[symmetric] + , subst pasASIDAbs_pasMayActivate_update[symmetric] + , rule state_asids_to_policy_aux.intros + , assumption+)+ + done + +lemma state_asids_to_policy_pasMayActivate_update[PasUpdates_assms]: + "state_asids_to_policy (aag\pasMayActivate := x\) s = + state_asids_to_policy aag s" + by (simp add: state_asids_to_policy_aux_pasMayActivate_update) + +lemma state_asids_to_policy_aux_pasMayEditReadyQueues_update: + "state_asids_to_policy_aux (aag\pasMayEditReadyQueues := x\) caps asid_tab vrefs = + state_asids_to_policy_aux aag caps asid_tab vrefs" + apply (rule equalityI) + apply (clarify) + apply (erule state_asids_to_policy_aux.cases + | simp + | fastforce intro: state_asids_to_policy_aux.intros)+ + apply (clarify) + apply (erule state_asids_to_policy_aux.cases) + apply (simp, subst pasObjectAbs_pasMayEditReadyQueues_update[symmetric] + , subst pasASIDAbs_pasMayEditReadyQueues_update[symmetric] + , rule state_asids_to_policy_aux.intros + , assumption+)+ + done + +lemma state_asids_to_policy_pasMayEditReadyQueues_update[PasUpdates_assms]: + "state_asids_to_policy (aag\pasMayEditReadyQueues := x\) s = + state_asids_to_policy aag s" + by (simp add: state_asids_to_policy_aux_pasMayEditReadyQueues_update) + +declare arch_post_set_flags_inv[PasUpdates_assms] +declare arch_prepare_set_domain_inv[PasUpdates_assms] + +end + + +global_interpretation PasUpdates_2?: PasUpdates_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact PasUpdates_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchRetype_IF.thy b/proof/infoflow/AARCH64/ArchRetype_IF.thy new file mode 100644 index 0000000000..7c11b27129 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchRetype_IF.thy @@ -0,0 +1,676 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchRetype_IF +imports Retype_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Retype_IF_assms + +lemma do_ipc_transfer_valid_arch_no_caps[wp]: + "do_ipc_transfer s ep bg grt r \valid_arch_state\" + by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at) + +lemma create_cap_valid_arch_state_no_caps[wp]: + "\valid_arch_state \ create_cap tp sz p dev ref + \\rv. valid_arch_state\" + by (wp valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at) + +lemma modify_underlying_memory_update_0_ev: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \ + (modify (underlying_memory_update (\m. m(x := word_rsplit 0 ! 7, + x + 1 := word_rsplit 0 ! 6, + x + 2 := word_rsplit 0 ! 5, + x + 3 := word_rsplit 0 ! 4, + x + 4 := word_rsplit 0 ! 3, + x + 5 := word_rsplit 0 ! 2, + x + 6 := word_rsplit 0 ! Suc 0, + x + 7 := word_rsplit 0 ! 0))))" + by (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad + elim: equiv_forE + intro: equiv_forI) + +lemma storeWord_ev: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \ (storeWord x 0)" + unfolding storeWord_def + by (wp modify_underlying_memory_update_0_ev assert_inv | simp add: no_irq_def upto.simps comp_def)+ + +lemma clearMemory_ev[Retype_IF_assms]: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) (\_. True) (clearMemory ptr bits)" + unfolding clearMemory_def + apply (rule equiv_valid_guard_imp) + apply (rule mapM_x_ev[OF storeWord_ev]) + apply (rule wp_post_taut | simp)+ + done + +lemma freeMemory_ev[Retype_IF_assms]: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) (\_. True) (freeMemory ptr bits)" + unfolding freeMemory_def + apply (rule equiv_valid_guard_imp) + apply (rule mapM_x_ev[OF storeWord_ev]) + apply (rule wp_post_taut | simp)+ + done + +lemma set_pt_globals_equiv: + "\globals_equiv st and (\s. a \ global_pt s)\ + set_pt a b + \\_. globals_equiv st\" + apply (unfold set_pt_def gets_map_def) + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev set_object_globals_equiv) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma set_pt_reads_respects: + "reads_respects aag l (K (is_subject aag a)) (set_pt a b)" + apply (unfold set_pt_def gets_map_def) + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev set_object_reads_respects) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma set_pt_reads_respects_g: + "reads_respects_g aag l (\ s. is_subject aag ptr \ ptr \ global_pt s) (set_pt ptr pt)" + by (fastforce intro: equiv_valid_guard_imp[OF reads_respects_g] doesnt_touch_globalsI + set_pt_reads_respects set_pt_globals_equiv) + +crunch clearMemory + for irq_state[Retype_IF_assms, wp]: "\s. P (irq_state s)" + (wp: crunch_wps simp: crunch_simps storeWord_def ignore_del: clearMemory) + +crunch freeMemory + for irq_state[Retype_IF_assms, wp]: "\s. P (irq_state s)" + (wp: crunch_wps simp: crunch_simps storeWord_def) + +lemma get_pt_rev: + "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_pt ptr)" + apply (unfold gets_map_def) + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma get_pt_revg: + "reads_equiv_valid_g_inv A aag (\ s. ptr = arm_us_global_vspace (arch_state s)) (get_pt ptr)" + apply (unfold gets_map_def) + apply (subst gets_apply) + apply (wp gets_apply_ev') + defer + apply (wp hoare_drop_imps) + apply (rule conjI) + apply assumption + apply simp + apply (auto simp: reads_equiv_g_def globals_equiv_def opt_map_def) + done + +lemma store_pte_reads_respects: + "reads_respects aag l (K (is_subject aag (ptr && ~~ mask pt_bits))) (store_pte ptr pte)" + unfolding store_pte_def fun_app_def + apply (wp set_pt_reads_respects get_pt_rev) + apply (clarsimp) + done + +lemma store_pte_globals_equiv: + "\globals_equiv s and (\ s. ptr && ~~ mask pt_bits \ arm_us_global_vspace (arch_state s))\ + store_pte ptr pde + \\_. globals_equiv s\" + unfolding store_pte_def + apply (wp set_pt_globals_equiv) + apply simp + done + +lemma store_pte_reads_respects_g: + "reads_respects_g aag l (\s. is_subject aag (ptr && ~~ mask pt_bits) \ + ptr && ~~ mask pt_bits \ arm_us_global_vspace (arch_state s)) + (store_pte ptr pte)" + by (fastforce intro: equiv_valid_guard_imp[OF reads_respects_g] doesnt_touch_globalsI + store_pte_reads_respects store_pte_globals_equiv) + +lemma get_pte_rev: + "reads_equiv_valid_inv A aag (K (is_subject aag (ptr && ~~ mask pt_bits))) (get_pte ptr)" + unfolding gets_map_def fun_app_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (fastforce elim: reads_equivE equiv_forE simp: ptes_of_def obind_def opt_map_def) + done + +lemma get_pte_revg: + "reads_equiv_valid_g_inv A aag (\s. (ptr && ~~ mask pt_bits) = arm_us_global_vspace (arch_state s)) + (get_pte ptr)" + apply (unfold gets_map_def) + apply (subst gets_apply) + apply (wp gets_apply_ev') + defer + apply (wp hoare_drop_imps) + apply (rule conjI) + apply assumption + apply simp + apply (auto simp: reads_equiv_g_def globals_equiv_def opt_map_def ptes_of_def obind_def) + done + +lemma copy_global_mappings_reads_respects_g: + "reads_respects_g aag l + ((\s. x \ arm_us_global_vspace (arch_state s)) and pspace_aligned and valid_global_arch_objs + and K (is_aligned x pt_bits \ is_subject aag x)) + (copy_global_mappings x)" + unfolding copy_global_mappings_def + apply (rule gen_asm_ev) + apply clarsimp + apply (rule bind_ev_pre) + prefer 3 + apply (rule_tac P'="\s. is_subject aag x \ x \ arm_us_global_vspace (arch_state s) \ + pspace_aligned s \ valid_global_arch_objs s" in hoare_weaken_pre) + apply (rule gets_sp) + apply (assumption) + apply (wp mapM_x_ev store_pte_reads_respects_g get_pte_revg) + apply (simp only: pt_index_def) + apply (subst table_base_offset_id) + apply clarsimp + apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def + table_size_def ptTranslationBits_def mask_def) + apply (word_bitwise, fastforce) + apply (erule ssubst[OF table_base_offset_id]) + apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def + table_size_def ptTranslationBits_def mask_def) + apply (word_bitwise, fastforce) + apply clarsimp + apply (wpsimp wp: get_pte_inv store_pte_aligned)+ + apply (fastforce dest: reads_equiv_gD simp: globals_equiv_def) + done + +lemma dmo_no_mem_globals_equiv: + "\ \P. f \\ms. P (underlying_memory ms)\; + \P. f \\ms. P (device_state ms)\; + \P. f \\ms. P (exclusive_state ms)\ \ + \ do_machine_op f \globals_equiv s\" + unfolding do_machine_op_def + apply (wp | simp add: split_def)+ + apply atomize + apply (erule_tac x="(=) (underlying_memory (machine_state sa))" in allE) + apply (erule_tac x="(=) (device_state (machine_state sa))" in allE) + apply (erule_tac x="(=) (exclusive_state (machine_state sa))" in allE) + apply (fastforce simp: valid_def globals_equiv_def idle_equiv_def) + done + +lemma dmo_mol_globals_equiv[wp]: + "do_machine_op (machine_op_lift f) \globals_equiv s\" + by (wpsimp wp: dmo_no_mem_globals_equiv simp: machine_op_lift_def machine_rest_lift_def) + +lemma mol_globals_equiv: + "machine_op_lift mop \\ms. globals_equiv st (s\machine_state := ms\)\" + unfolding machine_op_lift_def + apply (simp add: machine_rest_lift_def split_def) + apply wp + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + done + +lemma storeWord_globals_equiv: + "storeWord p v \\ms. globals_equiv st (s\machine_state := ms\)\" + unfolding storeWord_def + apply (simp add: is_aligned_mask[symmetric]) + apply wp + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + done + +lemma dmo_clearMemory_globals_equiv[Retype_IF_assms]: + "do_machine_op (clearMemory ptr (2 ^ bits)) \globals_equiv s\" + apply (simp add: do_machine_op_def clearMemory_def split_def) + apply wpsimp + apply (erule use_valid) + by (wpsimp wp: mapM_x_wp' storeWord_globals_equiv mol_globals_equiv)+ + +lemma dmo_freeMemory_globals_equiv[Retype_IF_assms]: + "do_machine_op (freeMemory ptr bits) \globals_equiv s\" + apply (rule hoare_pre) + apply (simp add: do_machine_op_def freeMemory_def split_def) + apply (wp) + apply clarsimp + apply (erule use_valid) + apply (wp mapM_x_wp' storeWord_globals_equiv mol_globals_equiv) + apply (simp_all) + done + +lemma init_arch_objects_reads_respects_g: + "reads_respects_g aag l \ (init_arch_objects new_type dev ptr num_objects obj_sz refs)" + unfolding init_arch_objects_def by wp + +lemma copy_global_mappings_globals_equiv: + "\globals_equiv s and (\s. x \ arm_us_global_vspace (arch_state s) \ is_aligned x pt_bits)\ + copy_global_mappings x + \\_. globals_equiv s\" + unfolding copy_global_mappings_def including classic_wp_pre + apply simp + apply wp + apply (rule_tac Q'="\_. globals_equiv s and (\s. x \ arm_us_global_vspace (arch_state s) \ + is_aligned x pt_bits)" in hoare_strengthen_post) + apply (wp mapM_x_wp[OF _ subset_refl] store_pte_globals_equiv) + apply (simp only: pt_index_def) + apply (subst table_base_offset_id) + apply clarsimp + apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def + table_size_def ptTranslationBits_def mask_def) + apply (word_bitwise, fastforce) + apply (simp_all) + done + +(* FIXME: cleanup this proof *) +lemma retype_region_globals_equiv[Retype_IF_assms]: + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + shows + "\globals_equiv s and invs + and (\s. \i. cte_wp_at (\c. c = UntypedCap dev (p && ~~ mask sz) sz i) slot s \ + (i \ unat (p && mask sz) \ pspace_no_overlap_range_cover p sz s)) + and K (range_cover p sz (obj_bits_api type o_bits) num \ 0 < num)\ + retype_region p num o_bits type dev + \\_. globals_equiv s\" + apply (simp only: retype_region_def foldr_upd_app_if fun_app_def K_bind_def) + apply (wp |simp)+ + apply clarsimp + apply (simp only: globals_equiv_def) + apply (clarsimp split del: if_split) + apply (subgoal_tac "pspace_no_overlap_range_cover p sz sa") + apply (rule conjI) + apply (clarsimp simp: pspace_no_overlap_def) + apply (drule_tac x="arm_us_global_vspace (arch_state sa)" in spec) + apply (frule valid_global_arch_objs_pt_at[OF invs_valid_global_arch_objs]) + apply (clarsimp simp: invs_def valid_state_def valid_global_objs_def + valid_vso_at_def obj_at_def ptr_add_def) + apply (frule_tac p=x in range_cover_subset) + apply (simp add: blah) + apply simp + apply (frule range_cover_subset') + apply simp + apply (clarsimp simp: p_assoc_help) + apply (drule disjoint_subset_neg1[OF _ subset_thing], rule is_aligned_no_wrap') + apply (clarsimp simp: valid_pspace_def pspace_aligned_def) + apply (drule_tac x="arm_us_global_vspace (arch_state sa)" and A="dom (kheap sa)" in bspec) + apply (simp add: domI) + apply simp + apply (rule word_power_less_1) + apply (simp add: table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def) + apply simp + apply simp + apply simp + apply (drule (1) subset_trans) + apply (erule_tac P="a \ b" for a b in notE) + apply (erule_tac A="{p + c..d}" for c d in subsetD) + apply (simp add: blah) + apply (rule is_aligned_no_wrap') + apply (rule is_aligned_add[OF _ is_aligned_mult_triv2]) + apply (simp add: range_cover_def) + apply (rule word_power_less_1) + apply (simp add: range_cover_def) + apply (erule updates_not_idle) + apply (clarsimp simp: pspace_no_overlap_def) + apply (drule_tac x="idle_thread sa" in spec) + apply (clarsimp simp: invs_def valid_state_def valid_global_objs_def + obj_at_def ptr_add_def valid_idle_def pred_tcb_at_def) + apply (frule_tac p=a in range_cover_subset) + apply (simp add: blah) + apply simp + apply (frule range_cover_subset') + apply simp + apply (clarsimp simp: p_assoc_help) + apply (drule disjoint_subset_neg1[OF _ subset_thing], rule is_aligned_no_wrap') + apply (clarsimp simp: valid_pspace_def pspace_aligned_def) + apply (drule_tac x="idle_thread sa" and A="dom (kheap sa)" in bspec) + apply (simp add: domI) + apply simp + apply uint_arith + apply simp+ + apply (drule (1) subset_trans) + apply (erule_tac P="a \ b" for a b in notE) + apply (erule_tac A="{idle_thread_ptr..d}" for d in subsetD) + apply (simp add: blah) + apply (erule_tac t=idle_thread_ptr in subst) + apply (rule is_aligned_no_wrap') + apply (rule is_aligned_add[OF _ is_aligned_mult_triv2]) + apply (simp add: range_cover_def)+ + apply (auto intro!: cte_wp_at_pspace_no_overlapI simp: range_cover_def word_bits_def)[1] + done + +lemma no_irq_freeMemory[Retype_IF_assms]: + "no_irq (freeMemory ptr sz)" + apply (simp add: freeMemory_def) + apply (wp no_irq_mapM_x no_irq_storeWord) + done + +lemma equiv_asid_detype[Retype_IF_assms]: + "equiv_asid asid s s' \ equiv_asid asid (detype N s) (detype N s')" + by (auto simp: equiv_asid_def) + +end + + +global_interpretation Retype_IF_1?: Retype_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Retype_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma detype_globals_equiv: + "\globals_equiv st and ((\s. arm_us_global_vspace (arch_state s) \ S) and (\s. idle_thread s \ S))\ + modify (detype S) + \\_. globals_equiv st\" + apply (wp) + apply (clarsimp simp: globals_equiv_def detype_def idle_equiv_def tcb_at_def2) + done + +lemma detype_reads_respects_g: + "reads_respects_g aag l ((\s. arm_us_global_vspace (arch_state s) \ S) and (\s. idle_thread s \ S)) + (modify (detype S))" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_g) + apply (rule detype_reads_respects) + apply (rule doesnt_touch_globalsI[OF detype_globals_equiv]) + apply simp + done + +lemma delete_objects_reads_respects_g: + "reads_equiv_valid_g_inv (affects_equiv aag l) aag + (\s. arm_us_global_vspace (arch_state s) \ ptr_range p b \ + idle_thread s \ ptr_range p b \ + is_aligned p b \ 2 \ b \ b < word_bits) + (delete_objects p b)" + apply (simp add: delete_objects_def2) + apply (rule equiv_valid_guard_imp) + apply (wp dmo_freeMemory_reads_respects_g) + apply (rule detype_reads_respects_g) + apply wp + apply (unfold ptr_range_def) + apply simp + done + +lemma reset_untyped_cap_reads_respects_g: + "reads_equiv_valid_g_inv (affects_equiv aag (l :: 'a subject_label)) aag + (\s. cte_wp_at is_untyped_cap slot s \ invs s \ ct_active s \ only_timer_irq_inv irq st s \ + is_subject aag (fst slot) \ (descendants_of slot (cdt s) = {})) + (reset_untyped_cap slot)" + apply (simp add: reset_untyped_cap_def cong: if_cong) + apply (rule equiv_valid_guard_imp) + apply (wp set_cap_reads_respects_g dmo_clearMemory_reads_respects_g + | simp add: unless_def when_def split del: if_split)+ + apply (rule_tac I="invs and cte_wp_at (\cp. is_untyped_cap rv + \ (\idx. cp = free_index_update (\_. idx) rv) + \ free_index_of rv \ 2 ^ (bits_of rv) + \ is_subject aag (fst slot)) slot + and pspace_no_overlap (untyped_range rv) + and only_timer_irq_inv irq st + and (\s. descendants_of slot (cdt s) = {})" in mapME_x_ev) + apply (rule equiv_valid_guard_imp) + apply wp + apply (rule reads_respects_g_from_inv) + apply (rule preemption_point_reads_respects[where irq=irq and st=st]) + apply ((wp preemption_point_inv set_cap_reads_respects_g set_untyped_cap_invs_simple + only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] + dmo_clearMemory_reads_respects_g + | simp)+) + apply (strengthen empty_descendants_range_in) + apply (wp only_timer_irq_inv_pres[where P=\ and Q=\] no_irq_clearMemory + | simp | wp (once) dmo_wp)+ + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def) + apply (frule(1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps + free_index_of_def invs_valid_global_objs) + apply (simp add: aligned_add_aligned is_aligned_shiftl) + apply (clarsimp simp: Kernel_Config.resetChunkBits_def) + apply (rule hoare_pre) + apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at + set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] + irq_state_independent_A_conjI + | simp)+ + apply (strengthen empty_descendants_range_in) + apply (wp only_timer_irq_inv_pres[where P=\ and Q=\] no_irq_clearMemory + | simp | wp (once) dmo_wp)+ + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def) + apply (frule(1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def) + apply (wp | simp)+ + apply (wp delete_objects_reads_respects_g) + apply (simp add: if_apply_def2) + apply (strengthen invs_valid_global_objs) + apply (wp add: delete_objects_invs_ex hoare_vcg_const_imp_lift + delete_objects_pspace_no_overlap_again + only_timer_irq_inv_pres[where P=\ and Q=\] + delete_objects_valid_arch_state + del: Untyped_AI.delete_objects_pspace_no_overlap + | simp)+ + apply (rule get_cap_reads_respects_g) + apply (wp get_cap_wp) + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def) + apply (frule(1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps + free_index_of_def invs_valid_global_objs) + apply (frule valid_global_refsD2, clarsimp+) + apply (clarsimp simp: ptr_range_def[symmetric] global_refs_def descendants_range_def2) + apply (frule if_unsafe_then_capD[OF caps_of_state_cteD], clarsimp+) + apply (strengthen refl[where t=True] refl ex_tupleI[where t=slot] empty_descendants_range_in + | clarsimp)+ + apply (drule ex_cte_cap_protects[OF _ _ _ _ order_refl], erule caps_of_state_cteD) + apply (clarsimp simp: descendants_range_def2 empty_descendants_range_in) + apply clarsimp+ + apply (fastforce dest: invs_valid_global_arch_objs valid_global_arch_objs_global_ptD + simp: untyped_min_bits_def ptr_range_def) + done + +lemma retype_region_ret_pt_aligned: + "\K (range_cover ptr sz (obj_bits_api tp us) num_objects)\ + retype_region ptr num_objects us tp dev + \\rv. K (\ref \ set rv. tp = ArchObject PageTableObj \ is_aligned ref pt_bits)\" + apply (rule hoare_strengthen_post) + apply (rule hoare_weaken_pre) + apply (rule retype_region_aligned_for_init) + apply simp + apply (clarsimp simp: obj_bits_api_def default_arch_object_def pt_bits_def pageBits_def) + done + +lemma post_retype_invs_valid_global_objsI: + "post_retype_invs ty rv s \ valid_global_objs s" + by (clarsimp simp: post_retype_invs_def invs_def valid_state_def split: if_split_asm) + +lemma invoke_untyped_reads_respects_g_wcap[Retype_IF_assms]: + notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost + atLeastatMost_empty_iff split_paired_Ex + shows "reads_respects_g aag (l :: 'a subject_label) + (invs and valid_untyped_inv_wcap ui (Some (UntypedCap dev ptr sz idx)) + and only_timer_irq_inv irq st and ct_active and pas_refined aag + and K (authorised_untyped_inv aag ui)) + (invoke_untyped ui)" + apply (case_tac ui) + apply (rename_tac cslot_ptr reset ptr_base ptr' apiobject_type nat list dev') + apply (case_tac "\ (dev' = dev \ ptr = ptr' && ~~ mask sz)") + (* contradictory *) + apply (rule equiv_valid_guard_imp, rule_tac gen_asm_ev'[where P="\" and Q=False], simp) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (simp add: invoke_untyped_def mapM_x_def[symmetric]) + apply (wpsimp wp: mapM_x_ev'' create_cap_reads_respects_g + hoare_vcg_ball_lift init_arch_objects_reads_respects_g)+ + apply (wp retype_region_reads_respects_g[where sz=sz and slot="slot_of_untyped_inv ui"]) + apply (rule_tac Q'="\rvc s. (\x\set rvc. is_subject aag x) \ + (\x\set rvc. is_aligned x (obj_bits_api apiobject_type nat)) \ + ((0::obj_ref) < of_nat (length list)) \ + post_retype_invs apiobject_type rvc s \ + global_refs s \ set rvc = {} \ + (\x\set list. is_subject aag (fst x))" + for sz in hoare_strengthen_post) + apply (wp retype_region_ret_is_subject[where sz=sz, simplified] + retype_region_global_refs_disjoint[where sz=sz] + retype_region_ret_pt_aligned[where sz=sz] + retype_region_aligned_for_init[where sz=sz] + retype_region_post_retype_invs_spec[where sz=sz]) + apply clarsimp + apply (fastforce simp: global_refs_def obj_bits_api_def + post_retype_invs_valid_arch_stateI + post_retype_invs_valid_global_objsI + pageBits_def default_arch_object_def + intro: post_retype_invs_pspace_alignedI + post_retype_invs_valid_arch_stateI + elim: in_set_zipE) + apply (rule set_cap_reads_respects_g) + apply simp + apply (wp hoare_vcg_ex_lift set_cap_cte_wp_at_cases + hoare_vcg_disj_lift set_cap_no_overlap + set_free_index_invs_UntypedCap + set_untyped_cap_caps_overlap_reserved + set_cap_caps_no_overlap + region_in_kernel_window_preserved) + apply (wp when_ev delete_objects_reads_respects_g hoare_vcg_disj_lift + delete_objects_pspace_no_overlap + delete_objects_descendants_range_in + delete_objects_caps_no_overlap + region_in_kernel_window_preserved + get_cap_reads_respects_g get_cap_wp + | simp split del: if_split)+ + apply (rule reset_untyped_cap_reads_respects_g[where irq=irq and st=st]) + apply (rule_tac P="authorised_untyped_inv aag ui \ + (\p \ ptr_range ptr sz. is_subject aag p)" in hoare_gen_asmE) + apply (rule validE_validE_R, + rule_tac E'="\\" + and Q'="\_. invs and valid_untyped_inv_wcap ui (Some (UntypedCap dev ptr sz (If reset 0 idx))) + and ct_active + and (\s. reset \ pspace_no_overlap {ptr .. ptr + 2 ^ sz - 1} s)" + in hoare_strengthen_postE) + apply (rule hoare_pre, wp whenE_wp) + apply (rule validE_validE_R, rule hoare_strengthen_postE, rule reset_untyped_cap_invs_etc) + apply (clarsimp simp only: if_True simp_thms, intro conjI, assumption+) + apply simp + apply assumption + apply clarify + apply (frule(2) invoke_untyped_proofs.intro) + apply (clarsimp simp: cte_wp_at_caps_of_state bits_of_def + free_index_of_def untyped_range_def + if_split[where P="\x. x \ unat v" for v] + split del: if_split) + apply (frule(1) valid_global_refsD2[OF _ invs_valid_global_refs]) + apply (strengthen refl) + apply (strengthen invs_valid_global_objs invs_arch_state) + apply (clarsimp simp: authorised_untyped_inv_def conj_comms invoke_untyped_proofs.simps) + apply (simp add: arg_cong[OF mask_out_sub_mask, where f="\y. x - y" for x] + field_simps invoke_untyped_proofs.idx_le_new_offs + invoke_untyped_proofs.idx_compare' untyped_range_def) + apply (strengthen caps_region_kernel_window_imp[mk_strg I E]) + apply (simp add: invoke_untyped_proofs.simps untyped_range_def invs_cap_refs_in_kernel_window + atLeastatMost_subset_iff[where b=x and d=x for x] + cong: conj_cong split del: if_split) + apply (intro conjI) + (* mostly clagged from Untyped_AI *) + apply (simp add: atLeastatMost_subset_iff word_and_le2) + apply (case_tac reset) + apply (clarsimp elim!: pspace_no_overlap_subset del: subsetI + simp: blah word_and_le2) + apply (drule invoke_untyped_proofs.ps_no_overlap) + apply (simp add: field_simps) + apply (simp add: Int_commute, erule disjoint_subset2[rotated]) + apply (simp add: atLeastatMost_subset_iff word_and_le2) + apply (clarsimp dest!: invoke_untyped_proofs.idx_le_new_offs) + apply (simp add: ptr_range_def) + apply (erule ball_subset, rule range_subsetI[OF _ order_refl]) + apply (simp add: word_and_le2) + apply (erule order_trans[OF invoke_untyped_proofs.subset_stuff]) + apply (simp add: atLeastatMost_subset_iff word_and_le2) + apply (drule invoke_untyped_proofs.usable_range_disjoint) + apply (clarsimp simp: field_simps mask_out_sub_mask shiftl_t2n) + apply blast + apply (clarsimp simp: cte_wp_at_caps_of_state authorised_untyped_inv_def) + apply (strengthen refl) + apply (frule(1) cap_auth_caps_of_state) + apply (simp add: aag_cap_auth_def untyped_range_def + aag_has_Control_iff_owns ptr_range_def[symmetric]) + apply (erule disjE, simp_all)[1] + done + +lemma delete_objects_globals_equiv[wp]: + "\globals_equiv st and (\s. is_aligned p b \ 2 \ b \ b < word_bits \ + arm_us_global_vspace (arch_state s) \ ptr_range p b \ + idle_thread s \ ptr_range p b)\ + delete_objects p b + \\_. globals_equiv st\" + apply (simp add: delete_objects_def) + apply (wp detype_globals_equiv dmo_freeMemory_globals_equiv) + apply (clarsimp simp: ptr_range_def)+ + done + +lemma reset_untyped_cap_globals_equiv: + "\globals_equiv st and invs and cte_wp_at is_untyped_cap slot + and ct_active and (\s. descendants_of slot (cdt s) = {})\ + reset_untyped_cap slot + \\_. globals_equiv st\" + apply (simp add: reset_untyped_cap_def cong: if_cong) + apply (rule hoare_pre) + apply (wp set_cap_globals_equiv dmo_clearMemory_globals_equiv + preemption_point_inv | simp add: unless_def)+ + apply (rule valid_validE) + apply (rule_tac P="cap_aligned cap \ is_untyped_cap cap" in hoare_gen_asm) + apply (rule_tac Q'="\_ s. valid_global_objs s \ valid_arch_state s \ globals_equiv st s" + in hoare_strengthen_post) + apply (rule validE_valid, rule mapME_x_wp') + apply (rule hoare_pre) + apply (wp set_cap_globals_equiv dmo_clearMemory_globals_equiv + preemption_point_inv | simp add: if_apply_def2)+ + apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] + cap_aligned_def bits_of_def free_index_of_def) + apply (clarsimp simp: Kernel_Config.resetChunkBits_def) + apply (strengthen invs_valid_global_objs invs_arch_state) + apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ + apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def + split del: if_split) + apply (frule caps_of_state_valid_cap, clarsimp+) + apply (clarsimp simp: valid_cap_simps cap_aligned_def untyped_min_bits_def) + apply (frule valid_global_refsD2, clarsimp+) + apply (clarsimp simp: ptr_range_def[symmetric] global_refs_def) + apply (strengthen empty_descendants_range_in) + apply (cases slot) + apply (fastforce dest: valid_global_arch_objs_global_ptD[OF invs_valid_global_arch_objs]) + done + +lemma invoke_untyped_globals_equiv: + notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost + atLeastatMost_empty_iff split_paired_Ex + shows "\globals_equiv st and invs and valid_untyped_inv ui and ct_active\ + invoke_untyped ui + \\_. globals_equiv st\" + apply (rule hoare_name_pre_state) + apply (rule hoare_pre, rule invoke_untyped_Q) + apply (wp create_cap_globals_equiv) + apply auto[1] + apply wpsimp + apply (rule hoare_pre, wp retype_region_globals_equiv[where slot="slot_of_untyped_inv ui"]) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (strengthen refl) + apply simp + apply (wp set_cap_globals_equiv) + apply auto[1] + apply (wp reset_untyped_cap_globals_equiv) + apply (cases ui, clarsimp simp: cte_wp_at_caps_of_state) + done + +end + + +global_interpretation Retype_IF_2?: Retype_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Retype_IF_assms)?) +qed + + +requalify_facts + AARCH64.reset_untyped_cap_reads_respects_g + AARCH64.reset_untyped_cap_globals_equiv + AARCH64.invoke_untyped_globals_equiv + AARCH64.storeWord_globals_equiv + +end diff --git a/proof/infoflow/AARCH64/ArchScheduler_IF.thy b/proof/infoflow/AARCH64/ArchScheduler_IF.thy new file mode 100644 index 0000000000..5ae58b0267 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchScheduler_IF.thy @@ -0,0 +1,401 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchScheduler_IF +imports Scheduler_IF + +begin + +context Arch begin global_naming AARCH64 + +named_theorems Scheduler_IF_assms + +definition arch_globals_equiv_scheduler :: "kheap \ kheap \ arch_state \ arch_state \ bool" where + "arch_globals_equiv_scheduler kh kh' as as' \ + arm_us_global_vspace as = arm_us_global_vspace as' \ kh (arm_us_global_vspace as) = kh' (arm_us_global_vspace as)" + +definition + "arch_scheduler_affects_equiv s s' \ True" + +lemma arch_globals_equiv_from_scheduler[Scheduler_IF_assms]: + "\ arch_globals_equiv_scheduler (kheap s) (kheap s') (arch_state s) (arch_state s'); + cur_thread s' \ idle_thread s \ arch_scheduler_affects_equiv s s' \ + \ arch_globals_equiv (cur_thread s') (idle_thread s) (kheap s) (kheap s') + (arch_state s) (arch_state s') (machine_state s) (machine_state s')" + by (clarsimp simp: arch_globals_equiv_scheduler_def arch_scheduler_affects_equiv_def) + +lemma arch_globals_equiv_scheduler_refl[Scheduler_IF_assms]: + "arch_globals_equiv_scheduler (kheap s) (kheap s) (arch_state s) (arch_state s)" + by (simp add: idle_equiv_refl arch_globals_equiv_scheduler_def) + +lemma arch_globals_equiv_scheduler_sym[Scheduler_IF_assms]: + "arch_globals_equiv_scheduler (kheap s) (kheap s') (arch_state s) (arch_state s') + \ arch_globals_equiv_scheduler (kheap s') (kheap s) (arch_state s') (arch_state s)" + by (auto simp: arch_globals_equiv_scheduler_def) + +lemma arch_globals_equiv_scheduler_trans[Scheduler_IF_assms]: + "\ arch_globals_equiv_scheduler (kheap s) (kheap s') (arch_state s) (arch_state s'); + arch_globals_equiv_scheduler (kheap s') (kheap s'') (arch_state s') (arch_state s'') \ + \ arch_globals_equiv_scheduler (kheap s) (kheap s'') (arch_state s) (arch_state s'')" + by (clarsimp simp: arch_globals_equiv_scheduler_def) + +lemma arch_scheduler_affects_equiv_trans[Scheduler_IF_assms, elim]: + "\ arch_scheduler_affects_equiv s s'; arch_scheduler_affects_equiv s' s'' \ + \ arch_scheduler_affects_equiv s s''" + by (simp add: arch_scheduler_affects_equiv_def) + +lemma arch_scheduler_affects_equiv_sym[Scheduler_IF_assms, elim]: + "arch_scheduler_affects_equiv s s' \ arch_scheduler_affects_equiv s' s" + by (simp add: arch_scheduler_affects_equiv_def) + +lemma arch_scheduler_affects_equiv_sa_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (scheduler_action_update f s) s' = + arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (scheduler_action_update f s') = + arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +lemma equiv_asid_cur_thread_update[Scheduler_IF_assms, simp]: + "equiv_asid asid (cur_thread_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (cur_thread_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma arch_scheduler_affects_equiv_ready_queues_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (ready_queues_update f s) s' = arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (ready_queues_update f s') = arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +crunch arch_switch_to_thread, arch_switch_to_idle_thread + for idle_thread[Scheduler_IF_assms, wp]: "\s :: det_state. P (idle_thread s)" + and kheap[Scheduler_IF_assms, wp]: "\s :: det_state. P (kheap s)" + (wp: crunch_wps simp: crunch_simps) + +crunch arch_switch_to_thread, arch_switch_to_idle_thread + for cur_domain[Scheduler_IF_assms, wp]: "\s. P (cur_domain s)" + and domain_fields[Scheduler_IF_assms, wp]: "domain_fields P" + +crunch arch_switch_to_idle_thread + for globals_equiv[Scheduler_IF_assms, wp]: "globals_equiv st" + and states_equiv_for[Scheduler_IF_assms, wp]: "states_equiv_for P Q R S st" + and work_units_completed[Scheduler_IF_assms, wp]: "\s. P (work_units_completed s)" + +crunch arch_activate_idle_thread + for cur_domain[Scheduler_IF_assms, wp]: "\s. P (cur_domain s)" + and idle_thread[Scheduler_IF_assms, wp]: "\s. P (idle_thread s)" + and irq_state_of_state[Scheduler_IF_assms, wp]: "\s. P (irq_state_of_state s)" + and domain_fields[Scheduler_IF_assms, wp]: "domain_fields P" + +lemma arch_scheduler_affects_equiv_cur_thread_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (cur_thread_update f s) s' = arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (cur_thread_update f s') = arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +lemma equiv_asid_domain_time_update[Scheduler_IF_assms, simp]: + "equiv_asid asid (domain_time_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (domain_time_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma arch_scheduler_affects_equiv_domain_time_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (domain_time_update f s) s' = arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (domain_time_update f s') = arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +crunch ackInterrupt + for irq_state[Scheduler_IF_assms, wp]: "\s. P (irq_state s)" + +lemma thread_set_context_globals_equiv[Scheduler_IF_assms]: + "\(\s. t = idle_thread s \ tc = idle_context s) and invs and globals_equiv st\ + thread_set (tcb_arch_update (arch_tcb_context_set tc)) t + \\rv. globals_equiv st\" + apply (clarsimp simp: thread_set_def) + apply (wpsimp wp: set_object_wp) + apply (subgoal_tac "t \ arm_us_global_vspace (arch_state s)") + apply (clarsimp simp: idle_equiv_def globals_equiv_def tcb_at_def2 get_tcb_def idle_context_def) + apply (clarsimp split: option.splits kernel_object.splits) + apply (fastforce simp: get_tcb_def obj_at_def valid_arch_state_def + dest: valid_global_arch_objs_pt_at invs_arch_state) + done + +lemma arch_scheduler_affects_equiv_update[Scheduler_IF_assms]: + "arch_scheduler_affects_equiv st s + \ arch_scheduler_affects_equiv st (s\kheap := (kheap s)(x \ TCB y')\)" + by (clarsimp simp: arch_scheduler_affects_equiv_def) + +lemma equiv_asid_equiv_update[Scheduler_IF_assms]: + "\ get_tcb x s = Some y; equiv_asid asid st s \ + \ equiv_asid asid st (s\kheap := (kheap s)(x \ TCB y')\)" + by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) + +declare arch_prepare_next_domain_inv[Scheduler_IF_assms] + +end + + +requalify_consts + AARCH64.arch_globals_equiv_scheduler + AARCH64.arch_scheduler_affects_equiv + +global_interpretation Scheduler_IF_1?: + Scheduler_IF_1 arch_globals_equiv_scheduler arch_scheduler_affects_equiv +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Scheduler_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +definition swap_things where + "swap_things s t \ + t\machine_state := underlying_memory_update + (\m a. if a \ scheduler_affects_globals_frame t + then underlying_memory (machine_state s) a + else m a) + (machine_state t)\ + \cur_thread := cur_thread s\" + +lemma globals_equiv_scheduler_inv'[Scheduler_IF_assms]: + "(\st. \P and globals_equiv st\ f \\_. globals_equiv st\) + \ \P and globals_equiv_scheduler s\ f \\_. globals_equiv_scheduler s\" + apply atomize + apply (rule use_spec) + apply (simp add: spec_valid_def) + apply (erule_tac x="(swap_things sa s)" in allE) + apply (rule_tac Q'="\r st. globals_equiv (swap_things sa s) st" in hoare_strengthen_post) + apply (rule hoare_pre) + apply assumption + apply (clarsimp simp: globals_equiv_def swap_things_def globals_equiv_scheduler_def + arch_globals_equiv_scheduler_def arch_scheduler_affects_equiv_def)+ + done + +lemma arch_switch_to_thread_globals_equiv_scheduler[Scheduler_IF_assms]: + "\invs and globals_equiv_scheduler sta\ + arch_switch_to_thread thread + \\_. globals_equiv_scheduler sta\" + unfolding arch_switch_to_thread_def storeWord_def + by (wpsimp wp: dmo_wp modify_wp thread_get_wp' globals_equiv_scheduler_inv'[where P="\"]) + +crunch arch_activate_idle_thread + for silc_dom_equiv[Scheduler_IF_assms, wp]: "silc_dom_equiv aag st" + and scheduler_affects_equiv[Scheduler_IF_assms, wp]: "scheduler_affects_equiv aag l st" + +lemma set_vm_root_arch_scheduler_affects_equiv[wp]: + "set_vm_root tcb \arch_scheduler_affects_equiv st\" + unfolding arch_scheduler_affects_equiv_def by wpsimp + +lemmas set_vm_root_scheduler_affects_equiv[wp] = + scheduler_affects_equiv_unobservable[OF set_vm_root_states_equiv_for + set_vm_root_cur_domain _ _ _ set_vm_root_it + set_vm_root_arch_scheduler_affects_equiv] + +lemma set_vm_root_reads_respects_scheduler[wp]: + "reads_respects_scheduler aag l \ (set_vm_root thread)" + apply (rule reads_respects_scheduler_unobservable'[OF scheduler_equiv_lift' + [OF globals_equiv_scheduler_inv']]) + apply (wp silc_dom_equiv_states_equiv_lift set_vm_root_states_equiv_for | simp)+ + done + +lemma store_cur_thread_fragment_midstrength_reads_respects: + "equiv_valid (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (scheduler_affects_equiv aag l) invs + (do x \ modify (cur_thread_update (\_. t)); + set_scheduler_action resume_cur_thread + od)" + apply (rule equiv_valid_guard_imp) + apply (rule equiv_valid_weaken_pre) + apply (rule ev_asahi_ex_to_full_fragement) + apply (auto simp: midstrength_scheduler_affects_equiv_def asahi_scheduler_affects_equiv_def + asahi_ex_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def + arch_scheduler_affects_equiv_def equiv_asids_def equiv_asid_def + scheduler_globals_frame_equiv_def + simp del: split_paired_All) + done + +lemma arch_switch_to_thread_globals_equiv_scheduler': + "\invs and globals_equiv_scheduler sta\ + set_vm_root t + \\_. globals_equiv_scheduler sta\" + by (rule globals_equiv_scheduler_inv', wpsimp) + +lemma arch_switch_to_thread_reads_respects_scheduler[wp]: + "reads_respects_scheduler aag l + ((\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)) and invs) + (arch_switch_to_thread t)" + apply (rule reads_respects_scheduler_cases) + apply (simp add: arch_switch_to_thread_def) + apply wp + apply (clarsimp simp: scheduler_equiv_def globals_equiv_scheduler_def) + apply (simp add: arch_switch_to_thread_def) + apply wp + apply simp + done + +lemmas globals_equiv_scheduler_inv = globals_equiv_scheduler_inv'[where P="\",simplified] + +lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_assms, wp]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "midstrength_reads_respects_scheduler aag l + (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (do _ <- arch_switch_to_thread t; + _ <- modify (cur_thread_update (\_. t)); + modify (scheduler_action_update (\_. resume_cur_thread)) + od)" + apply (rule equiv_valid_guard_imp) + apply (rule midstrength_reads_respects_scheduler_cases[ + where Q="(invs and pas_refined aag and + (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)))", + OF domains_distinct]) + apply (simp add: arch_switch_to_thread_def bind_assoc) + apply (rule bind_ev_general) + apply (fold set_scheduler_action_def) + apply (rule store_cur_thread_fragment_midstrength_reads_respects) + apply (rule_tac P="\" and P'="\" in equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift'[where P=\]) + apply (wp globals_equiv_scheduler_inv silc_dom_lift | simp)+ + apply (wp midstrength_scheduler_affects_equiv_unobservable set_vm_root_states_equiv_for + | simp)+ + apply (wp cur_thread_update_not_subject_reads_respects_scheduler | simp | fastforce)+ + done + +lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: + "\invs and globals_equiv_scheduler sta\ + arch_switch_to_idle_thread + \\_. globals_equiv_scheduler sta\" + unfolding arch_switch_to_idle_thread_def storeWord_def + by (wp dmo_wp modify_wp thread_get_wp' arch_switch_to_thread_globals_equiv_scheduler') + +lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: + "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ + arch_switch_to_idle_thread + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: arch_switch_to_idle_thread_def) + apply wp + apply (clarsimp simp add: scheduler_equiv_def domain_fields_equiv_def invs_def valid_state_def) + done + +lemma arch_switch_to_thread_unobservable[Scheduler_IF_assms]: + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ + arch_switch_to_thread t + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: arch_switch_to_thread_def) + apply (wp set_vm_root_scheduler_affects_equiv | simp)+ + done + +(* Can split, but probably more effort to generalise *) +lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: + "equiv_valid (scheduler_equiv aag) (weak_scheduler_affects_equiv aag l) + (midstrength_scheduler_affects_equiv aag l) \ next_domain" + apply (simp add: next_domain_def) + apply (subst is_extended.dxo_eq) + apply (clarsimp simp: is_extended_def is_extended'_def is_extended_axioms_def) + apply wpsimp + apply (clarsimp simp: modify_modify) + apply (rule ev_modify) + apply (clarsimp simp: equiv_for_def equiv_asid_def equiv_asids_def Let_def scheduler_equiv_def + globals_equiv_scheduler_def silc_dom_equiv_def domain_fields_equiv_def + weak_scheduler_affects_equiv_def midstrength_scheduler_affects_equiv_def + states_equiv_for_def idle_equiv_def) + done + +lemma resetTimer_irq_state[wp]: + "resetTimer \\s. P (irq_state s)\" + apply (simp add: resetTimer_def machine_op_lift_def machine_rest_lift_def) + apply (wp | wpc| simp)+ + done + +lemma dmo_resetTimer_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l \ (do_machine_op resetTimer)" + apply (rule reads_respects_scheduler_unobservable) + apply (rule scheduler_equiv_lift) + apply (simp add: globals_equiv_scheduler_def[abs_def] idle_equiv_def) + apply (wpsimp wp: dmo_wp) + apply ((wp silc_dom_lift dmo_wp | simp)+)[5] + apply (rule scheduler_affects_equiv_unobservable) + apply (simp add: states_equiv_for_def[abs_def] equiv_for_def equiv_asids_def equiv_asid_def) + apply (rule hoare_pre) + apply (wp | simp add: arch_scheduler_affects_equiv_def | wp dmo_wp)+ + done + +lemma ackInterrupt_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l \ (do_machine_op (ackInterrupt irq))" + apply (rule reads_respects_scheduler_unobservable) + apply (rule scheduler_equiv_lift) + apply (simp add: globals_equiv_scheduler_def[abs_def] idle_equiv_def) + apply (rule hoare_pre) + apply wps + apply (wp dmo_wp ackInterrupt_irq_masks | simp add:no_irq_def)+ + apply clarsimp + apply ((wp silc_dom_lift dmo_wp | simp)+)[5] + apply (rule scheduler_affects_equiv_unobservable) + apply (simp add: states_equiv_for_def[abs_def] equiv_for_def equiv_asids_def equiv_asid_def) + apply (rule hoare_pre) + apply wps + apply (wp dmo_wp | simp add: arch_scheduler_affects_equiv_def ackInterrupt_def)+ + done + +lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: + "\(\s. x \ idle_thread s \ pasObjectAbs aag x \ reads_scheduler aag l) and + (\s. x = idle_thread s \ tc = idle_context s) and scheduler_affects_equiv aag l st\ + thread_set (tcb_arch_update (arch_tcb_context_set tc)) x + \\_. scheduler_affects_equiv aag l st\" + apply (simp add: thread_set_def) + apply (wp set_object_wp) + apply (intro impI conjI) + apply (case_tac "x \ idle_thread s",simp_all) + apply (clarsimp simp: scheduler_affects_equiv_def get_tcb_def scheduler_globals_frame_equiv_def + split: option.splits kernel_object.splits) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply (elim states_equiv_forE equiv_forE) + apply (rule states_equiv_forI,simp_all add: equiv_for_def equiv_asids_def equiv_asid_def) + apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: idle_context_def get_tcb_def + split: option.splits kernel_object.splits) + apply (subst arch_tcb_update_aux) + apply simp + apply (subgoal_tac "s = (s\kheap := (kheap s)(idle_thread s \ TCB y)\)", simp) + apply (rule state.equality) + apply (rule ext) + apply simp+ + done + +lemma set_object_reads_respects_scheduler[Scheduler_IF_assms, wp]: + "reads_respects_scheduler aag l \ (set_object ptr obj)" + unfolding equiv_valid_def2 equiv_valid_2_def + by (auto simp: set_object_def bind_def get_def put_def return_def get_object_def assert_def + fail_def gets_def scheduler_equiv_def domain_fields_equiv_def equiv_for_def + globals_equiv_scheduler_def arch_globals_equiv_scheduler_def silc_dom_equiv_def + scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + scheduler_globals_frame_equiv_def identical_kheap_updates_def + intro: states_equiv_for_identical_kheap_updates idle_equiv_identical_kheap_updates) + +lemma arch_activate_idle_thread_reads_respects_scheduler[Scheduler_IF_assms, wp]: + "reads_respects_scheduler aag l \ (arch_activate_idle_thread rv)" + unfolding arch_activate_idle_thread_def by wpsimp + +lemma arch_prepare_next_domain_ev[Scheduler_IF_assms]: + "equiv_valid_inv I A (\_. True) arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def by wp + +end + + +global_interpretation Scheduler_IF_2?: + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Scheduler_IF_assms)?) +qed + + +hide_fact Scheduler_IF_2.globals_equiv_scheduler_inv' +requalify_facts AARCH64.globals_equiv_scheduler_inv' + +end diff --git a/proof/infoflow/AARCH64/ArchSyscall_IF.thy b/proof/infoflow/AARCH64/ArchSyscall_IF.thy new file mode 100644 index 0000000000..32965aafdc --- /dev/null +++ b/proof/infoflow/AARCH64/ArchSyscall_IF.thy @@ -0,0 +1,210 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchSyscall_IF +imports Syscall_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Syscall_IF_assms + +lemma globals_equiv_irq_state_update[Syscall_IF_assms, simp]: + "globals_equiv st (s\machine_state := + machine_state s \irq_state := f (irq_state (machine_state s))\\) = + globals_equiv st s" + by (auto simp: globals_equiv_def idle_equiv_def) + +lemma thread_set_globals_equiv'[Syscall_IF_assms]: + "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv s\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + apply simp + apply (fastforce simp: obj_at_def get_tcb_def valid_arch_state_def + dest: valid_global_arch_objs_pt_at) + done + +lemma sts_authorised_for_globals_inv[Syscall_IF_assms]: + "set_thread_state d f \authorised_for_globals_inv oper\" + unfolding authorised_for_globals_inv_def authorised_for_globals_arch_inv_def + authorised_for_globals_page_table_inv_def authorised_for_globals_page_inv_def + apply (case_tac oper) + apply (wp | simp)+ + apply (rename_tac arch_invocation) + apply (case_tac arch_invocation) + apply simp + apply (rename_tac page_table_invocation) + apply (case_tac page_table_invocation) + apply wpsimp+ + apply (rename_tac page_invocation) + apply (case_tac page_invocation) + apply (simp | wp hoare_vcg_ex_lift)+ + done + +lemma dmo_maskInterrupt_globals_equiv[Syscall_IF_assms, wp]: + "do_machine_op (maskInterrupt b irq) \globals_equiv s\" + unfolding maskInterrupt_def + apply (rule dmo_no_mem_globals_equiv) + apply (wp modify_wp | simp)+ + done + +lemma dmo_ackInterrupt_globals_equiv[Syscall_IF_assms, wp]: + "do_machine_op (ackInterrupt irq) \globals_equiv s\" + unfolding ackInterrupt_def by wpsimp + +lemma dmo_resetTimer_globals_equiv[Syscall_IF_assms, wp]: + "do_machine_op resetTimer \globals_equiv s\" + unfolding resetTimer_def by (rule dmo_mol_globals_equiv) + +lemma arch_mask_irq_signal_globals_equiv[Syscall_IF_assms, wp]: + "arch_mask_irq_signal irq \globals_equiv st\" + by wpsimp + +lemma handle_reserved_irq_globals_equiv[Syscall_IF_assms, wp]: + "handle_reserved_irq irq \globals_equiv st\" + unfolding handle_reserved_irq_def by wpsimp + +lemma handle_vm_fault_reads_respects[Syscall_IF_assms]: + "reads_respects aag l (K (is_subject aag thread)) (handle_vm_fault thread vmfault_type)" + unfolding handle_vm_fault_def + by (cases vmfault_type; wpsimp wp: dmo_read_stval_reads_respects) + +lemma handle_hypervisor_fault_reads_respects[Syscall_IF_assms]: + "reads_respects aag l \ (handle_hypervisor_fault thread hypfault_type)" + by (cases hypfault_type; wpsimp) + +lemma handle_vm_fault_globals_equiv[Syscall_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ + handle_vm_fault thread vmfault_type + \\r. globals_equiv st\" + unfolding handle_vm_fault_def + by (cases vmfault_type; wpsimp wp: dmo_no_mem_globals_equiv) + +lemma handle_hypervisor_fault_globals_equiv[Syscall_IF_assms]: + "handle_hypervisor_fault thread hypfault_type \globals_equiv st\" + by (cases hypfault_type; wpsimp) + +crunch arch_activate_idle_thread, handle_spurious_irq + for globals_equiv[Syscall_IF_assms, wp]: "globals_equiv st" + +lemma select_f_setNextPC_reads_respects[Syscall_IF_assms, wp]: + "reads_respects aag l \ (select_f (setNextPC a b))" + unfolding setNextPC_def setRegister_def + by (wpsimp simp: select_f_returns) + +lemma select_f_getRestartPC_reads_respects[Syscall_IF_assms, wp]: + "reads_respects aag l \ (select_f (getRestartPC a))" + unfolding getRestartPC_def getRegister_def + by (wpsimp simp: select_f_returns) + +lemma arch_activate_idle_thread_reads_respects[Syscall_IF_assms, wp]: + "reads_respects aag l \ (arch_activate_idle_thread t)" + unfolding arch_activate_idle_thread_def by wpsimp + +lemma decode_asid_pool_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_asid_pool_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def decode_asid_pool_invocation_def + apply (simp add: split_def Let_def cong: if_cong split del: if_split) + apply wpsimp + done + +lemma decode_asid_control_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_asid_control_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def decode_asid_control_invocation_def + apply (simp add: split_def Let_def cong: if_cong split del: if_split) + apply wpsimp + done + +lemma decode_frame_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_frame_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def authorised_for_globals_page_inv_def + decode_frame_invocation_def decode_fr_inv_map_def + apply (simp add: split_def Let_def cong: arch_cap.case_cong if_cong split del: if_split) + apply (wpsimp wp: check_vp_wpR) + apply (subgoal_tac + "(\a b. cte_wp_at (parent_for_refs (make_user_pte (addrFromPPtr x) + (attribs_from_word (msg ! 2)) + (mask_vm_rights xa + (data_to_rights (msg ! Suc 0))), + ba)) (a, b) s)", clarsimp) + apply (clarsimp simp: parent_for_refs_def cte_wp_at_caps_of_state) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac vptr="msg ! 0" in pt_lookup_slot_cap_to) + apply fastforce + apply (fastforce elim: vs_lookup_table_is_aligned) + apply (drule not_le_imp_less) + apply (frule order.strict_implies_order[where b=user_vtop]) + apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) + apply (drule canonical_below_pptr_base_user) + apply (erule below_user_vtop_canonical) + apply (clarsimp simp: vmsz_aligned_def) + apply (drule is_aligned_no_overflow_mask) + apply (clarsimp simp: user_region_def) + apply (erule (1) dual_order.trans) + apply assumption + apply (fastforce simp: is_pt_cap_def is_PageTableCap_def split: option.splits) + done + +lemma decode_page_table_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_page_table_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def authorised_for_globals_page_table_inv_def + decode_page_table_invocation_def decode_pt_inv_map_def + apply (simp add: split_def Let_def cong: arch_cap.case_cong if_cong split del: if_split) + apply (wpsimp cong: if_cong wp: hoare_vcg_if_lift2) + apply (clarsimp simp: pt_lookup_slot_from_level_def pt_lookup_slot_def) + apply (frule (1) pt_lookup_vs_lookupI, clarsimp) + apply (drule vs_lookup_level) + apply (frule pt_walk_max_level) + apply (subgoal_tac "msg ! 0 \ user_region") + apply (frule reachable_page_table_not_global; clarsimp?) + apply (frule vs_lookup_table_is_aligned; clarsimp?) + apply (fastforce dest: global_pt_in_global_refs invs_arch_state simp: valid_arch_state_def) + apply (drule not_le_imp_less) + apply (frule order.strict_implies_order[where b=user_vtop]) + apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) + apply (drule canonical_below_pptr_base_user) + apply (erule below_user_vtop_canonical) + apply clarsimp + done + +lemma decode_arch_invocation_authorised_for_globals[Syscall_IF_assms]: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + arch_decode_invocation label msg x_slot slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding arch_decode_invocation_def + by (wpsimp wp: decode_asid_pool_invocation_authorised_for_globals + decode_asid_control_invocation_authorised_for_globals + decode_frame_invocation_authorised_for_globals + decode_page_table_invocation_authorised_for_globals, fastforce) + +declare arch_prepare_set_domain_inv[Syscall_IF_assms] + +end + + +global_interpretation Syscall_IF_1?: Syscall_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Syscall_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchTcb_IF.thy b/proof/infoflow/AARCH64/ArchTcb_IF.thy new file mode 100644 index 0000000000..a25532587f --- /dev/null +++ b/proof/infoflow/AARCH64/ArchTcb_IF.thy @@ -0,0 +1,269 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchTcb_IF +imports Tcb_IF +begin + +context Arch begin global_naming AARCH64 + +named_theorems Tcb_IF_assms + +crunch set_irq_state, suspend + for arm_us_global_vspace[wp]: "\s. P (arm_us_global_vspace (arch_state s))" + (wp: mapM_x_wp select_inv hoare_vcg_if_lift2 hoare_drop_imps dxo_wp_weak + simp: unless_def + ignore: empty_slot_ext reschedule_required) + +crunch as_user, restart + for arm_us_global_vspace[wp]: "\s. P (arm_us_global_vspace (arch_state s))" (wp: dxo_wp_weak) + +lemma cap_ne_global_pt: + "\ ex_nonz_cap_to word s; valid_global_refs s; valid_global_arch_objs s \ + \ word \ arm_us_global_vspace (arch_state s)" + unfolding ex_nonz_cap_to_def + apply (simp only: cte_wp_at_caps_of_state zobj_refs_to_obj_refs) + apply (elim exE conjE) + apply (drule valid_global_refsD2,simp) + apply (unfold global_refs_def) + apply clarsimp + apply (unfold cap_range_def) + apply (drule valid_global_arch_objs_global_ptD) + apply blast + done + +lemma valid_arch_caps_vs_lookup[Tcb_IF_assms]: + "valid_arch_caps s \ valid_vs_lookup s" + by (simp add: valid_arch_caps_def) + +lemma no_cap_to_idle_thread'[Tcb_IF_assms]: + "valid_global_refs s \ \ ex_nonz_cap_to (idle_thread s) s" + apply (clarsimp simp add: ex_nonz_cap_to_def valid_global_refs_def valid_refs_def) + apply (drule_tac x=a in spec) + apply (drule_tac x=b in spec) + apply (clarsimp simp: cte_wp_at_def global_refs_def cap_range_def) + apply (case_tac cap,simp_all) + done + +lemma no_cap_to_idle_thread''[Tcb_IF_assms]: + "valid_global_refs s \ caps_of_state s ref \ Some (ThreadCap (idle_thread s))" + apply (clarsimp simp add: valid_global_refs_def valid_refs_def cte_wp_at_caps_of_state) + apply (drule_tac x="fst ref" in spec) + apply (drule_tac x="snd ref" in spec) + apply (simp add: cap_range_def global_refs_def) + done + +crunch arch_post_modify_registers + for globals_equiv[Tcb_IF_assms, wp]: "globals_equiv st" + and valid_arch_state[Tcb_IF_assms, wp]: valid_arch_state + +lemma arch_post_modify_registers_reads_respects_f[Tcb_IF_assms, wp]: + "reads_respects_f aag l \ (arch_post_modify_registers cur t)" + by wpsimp + +lemma arch_get_sanitise_register_info_reads_respects_f[Tcb_IF_assms, wp]: + "reads_respects_f aag l \ (arch_get_sanitise_register_info rv)" + by wpsimp + +end + + +global_interpretation Tcb_IF_1?: Tcb_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Tcb_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma valid_ipc_buffer_cap_is_nondevice_page_cap: + "\valid_ipc_buffer_cap cap ptr; cap \ NullCap\ \ is_nondevice_page_cap cap" + by (clarsimp simp: valid_ipc_buffer_cap_def split: cap.splits arch_cap.splits) + +lemma is_valid_vtable_root_def2: + "is_valid_vtable_root c = (\r a. c = ArchObjectCap (PageTableCap r (Some a)))" + by (auto simp: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits) + +(* FIXME: Pretty general. Probably belongs somewhere else *) +lemma invoke_tcb_thread_preservation[Tcb_IF_assms]: + notes is_nondevice_page_cap_simps[simp del] + assumes cap_delete_P: "\slot. \invs and P and emptyable slot\ cap_delete slot \\_. P\" + assumes cap_insert_P: "\new_cap src dest. \invs and P\ cap_insert new_cap src dest \\_. P\" + assumes thread_set_P: "\f ptr. \invs and P\ thread_set (tcb_ipc_buffer_update f) ptr \\_. P\" + assumes thread_set_P': "\f ptr. \invs and P\ thread_set (tcb_fault_handler_update f) ptr \\_. P\" + assumes set_mcpriority_P: "\mcp ptr. \invs and P\ set_mcpriority ptr mcp \\_.P\" + assumes set_priority_P: "\prio ptr. \invs and P\ set_priority ptr prio \\_.P\" + assumes reschedule_required_P: "reschedule_required \P\" + assumes P_trans[simp]: "\f s. P (trans_state f s) = P s" + shows + "\P and invs and tcb_inv_wf (tcb_invocation.ThreadControl t sl ep mcp prio croot vroot buf)\ + invoke_tcb (tcb_invocation.ThreadControl t sl ep mcp prio croot vroot buf) + \\rv s :: det_state. P s\" (is "\?pre\ _ \_\") + apply (simp add: split_def cong: option.case_cong) + apply (rule hoare_weaken_pre) + apply (rule_tac P="case ep of Some v \ length v = word_bits | _ \ True" + in hoare_gen_asm) + apply wp + apply (wpsimp wp: set_priority_P) + apply (rule_tac Q'="\_. invs and P" and E'="\_. P" in hoare_post_impE; clarsimp) + apply ((simp add: conj_comms(1, 2) + | rule wp_split_const_if wp_split_const_if_R hoare_vcg_all_liftE_R + hoare_vcg_conj_elimE hoare_vcg_const_imp_liftE_R hoare_vcg_conj_liftE_R + | (wp check_cap_inv2[where Q="\_ s. t \ idle_thread s"] + out_invs_trivial case_option_wpE cap_delete_deletes + cap_delete_valid_cap cap_insert_valid_cap out_cte_at + cap_insert_cte_at cap_delete_cte_at out_valid_cap out_tcb_valid + hoare_vcg_const_imp_liftE_R hoare_vcg_all_liftE_R + thread_set_tcb_ipc_buffer_cap_cleared_invs + thread_set_invs_trivial[OF ball_tcb_cap_casesI] + hoare_vcg_all_lift thread_set_valid_cap out_emptyable + check_cap_inv [where P="valid_cap c" for c] + check_cap_inv [where P="tcb_cap_valid c p" for c p] + check_cap_inv[where P="cte_at p0" for p0] + check_cap_inv[where P="tcb_at p0" for p0] + thread_set_cte_at thread_set_no_cap_to_trivial[OF ball_tcb_cap_casesI] + checked_insert_no_cap_to + thread_set_cte_wp_at_trivial[where Q="\x. x", OF ball_tcb_cap_casesI] + out_no_cap_to_trivial[OF ball_tcb_cap_casesI] thread_set_ipc_tcb_cap_valid + check_cap_inv2[where Q="\_. P"] cap_delete_P cap_insert_P + thread_set_P thread_set_P' set_mcpriority_P set_mcpriority_idle_thread + reschedule_required_P dxo_wp_weak hoare_weak_lift_imp) + | simp add: ran_tcb_cap_cases dom_tcb_cap_cases[simplified] emptyable_def + | wpc + | strengthen use_no_cap_to_obj_asid_strg[simplified conj_comms] + tcb_cap_always_valid_strg[where p="tcb_cnode_index 0"] + tcb_cap_always_valid_strg[where p="tcb_cnode_index (Suc 0)"])+) (*slow*) + apply (unfold option_update_thread_def) + apply (wp itr_wps thread_set_P thread_set_P' + | simp add: emptyable_def | wpc)+ (*also slow*) + apply clarsimp + by (clarsimp simp: tcb_at_cte_at_0 tcb_at_cte_at_1[simplified] + is_cap_simps is_valid_vtable_root_def2 + is_cnode_or_valid_arch_def tcb_cap_valid_def + tcb_at_st_tcb_at[symmetric] invs_valid_objs + cap_asid_def vs_cap_ref_def + clas_no_asid cli_no_irqs no_cap_to_idle_thread + valid_ipc_buffer_cap_is_nondevice_page_cap + split: option.split_asm) + +lemma tc_reads_respects_f[Tcb_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + and tc[simp]: "ti = ThreadControl x41 x42 x43 x44 x45 x46 x47 x48" + notes validE_valid[wp del] hoare_weak_lift_imp [wp] + shows + "reads_respects_f aag l + (silc_inv aag st and only_timer_irq_inv irq st' and einvs and simple_sched_action + and pas_refined aag and pas_cur_domain aag and tcb_inv_wf ti + and is_subject aag \ cur_thread + and K (authorised_tcb_inv aag ti \ authorised_tcb_inv_extra aag ti)) + (invoke_tcb ti)" + apply (simp add: split_def cong: option.case_cong) + apply (wpsimp wp: set_priority_reads_respects[THEN reads_respects_f[where st=st and Q=\]]) + apply (wpsimp wp: hoare_vcg_const_imp_liftE_R simp: when_def | wpc)+ + apply (rule conjI) + apply ((wpsimp wp: reschedule_required_reads_respects_f)+)[4] + apply ((wp reads_respects_f[OF cap_insert_reads_respects, where st=st] + reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\"] + set_priority_reads_respects[THEN + reads_respects_f[where aag=aag and st=st and Q=\]] + set_mcpriority_reads_respects[THEN + reads_respects_f[where aag=aag and st=st and Q=\]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_list]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_sched]] + check_cap_inv[OF check_cap_inv[OF cap_insert_schedact]] + check_cap_inv[OF check_cap_inv[OF cap_insert_cur_domain]] + check_cap_inv[OF check_cap_inv[OF cap_insert_ct]] + get_thread_state_rev[THEN + reads_respects_f[where aag=aag and st=st and Q=\]] + hoare_vcg_all_liftE_R hoare_vcg_all_lift + cap_delete_reads_respects[where st=st] checked_insert_pas_refined + thread_set_pas_refined + reads_respects_f[OF checked_insert_reads_respects, where st=st] + checked_cap_insert_silc_inv[where st=st] + cap_delete_silc_inv_not_transferable[where st=st] + checked_cap_insert_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_only_timer_irq_inv[where st=st' and irq=irq] + set_priority_only_timer_irq_inv[where st=st' and irq=irq] + set_mcpriority_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_deletes cap_delete_valid_cap cap_delete_cte_at + cap_delete_pas_refined' itr_wps(12) itr_wps(14) cap_insert_cte_at + checked_insert_no_cap_to hoare_vcg_const_imp_liftE_R hoare_vcg_conj_lift + as_user_reads_respects_f thread_set_mdb cap_delete_invs + thread_set_valid_arch_state + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def + tcb_at_st_tcb_at when_def + | strengthen use_no_cap_to_obj_asid_strg invs_mdb + | solves auto)+)[7] + apply ((simp add: conj_comms, strengthen imp_consequent[where Q="x = None" for x] + , simp cong: conj_cong) + | wp reads_respects_f[OF cap_insert_reads_respects, where st=st] + reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\"] + set_priority_reads_respects[THEN reads_respects_f[where st=st and Q=\]] + set_mcpriority_reads_respects[THEN reads_respects_f[where st=st and Q=\]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_list]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_sched]] + check_cap_inv[OF check_cap_inv[OF cap_insert_schedact]] + check_cap_inv[OF check_cap_inv[OF cap_insert_cur_domain]] + check_cap_inv[OF check_cap_inv[OF cap_insert_ct]] + get_thread_state_rev[THEN reads_respects_f[where st=st and Q=\]] + hoare_vcg_all_liftE_R hoare_vcg_all_lift + cap_delete_reads_respects[where st=st] checked_insert_pas_refined + thread_set_pas_refined reads_respects_f[OF checked_insert_reads_respects] + checked_cap_insert_silc_inv[where st=st] + cap_delete_silc_inv_not_transferable[where st=st] + checked_cap_insert_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_only_timer_irq_inv[where st=st' and irq=irq] + set_priority_only_timer_irq_inv[where st=st' and irq=irq] + set_mcpriority_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_deletes cap_delete_valid_cap cap_delete_cte_at + cap_delete_pas_refined' itr_wps(12) itr_wps(14) cap_insert_cte_at + checked_insert_no_cap_to hoare_vcg_const_imp_liftE_R + as_user_reads_respects_f cap_delete_invs + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def when_def st_tcb_at_triv + | strengthen use_no_cap_to_obj_asid_strg invs_mdb + | wp (once) hoare_drop_imp)+ + apply (simp add: option_update_thread_def tcb_cap_cases_def + | wp hoare_weak_lift_imp hoare_weak_lift_imp_conj thread_set_pas_refined + reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\"] + thread_set_valid_arch_state + | wpc)+ + apply (wp hoare_vcg_all_lift thread_set_tcb_fault_handler_update_invs + thread_set_tcb_fault_handler_update_silc_inv + thread_set_not_state_valid_sched + thread_set_pas_refined thread_set_emptyable thread_set_valid_cap + thread_set_cte_at thread_set_no_cap_to_trivial + thread_set_tcb_fault_handler_update_only_timer_irq_inv + thread_set_valid_arch_state + | simp add: tcb_cap_cases_def | wpc | wp (once) hoare_drop_imp)+ + apply (clarsimp simp: authorised_tcb_inv_def authorised_tcb_inv_extra_def emptyable_def) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI) + (* slow *) + by (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def + det_setRegister option.disc_eq_case[symmetric] + split: cap.splits arch_cap.splits option.split)+ + +lemma arch_post_set_flags_reads_respects_f[Tcb_IF_assms]: + "reads_respects_f aag l \ (arch_post_set_flags t flags)" + unfolding arch_post_set_flags_def by wpsimp + +declare arch_post_set_flags_inv[Tcb_IF_assms] + +end + + +global_interpretation Tcb_IF_2?: Tcb_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Tcb_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchUserOp_IF.thy b/proof/infoflow/AARCH64/ArchUserOp_IF.thy new file mode 100644 index 0000000000..546aa12c2b --- /dev/null +++ b/proof/infoflow/AARCH64/ArchUserOp_IF.thy @@ -0,0 +1,850 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchUserOp_IF +imports UserOp_IF +begin + +context Arch begin global_naming AARCH64 + +definition ptable_lift_s where + "ptable_lift_s s \ ptable_lift (cur_thread s) s" + +definition ptable_rights_s where + "ptable_rights_s s \ ptable_rights (cur_thread s) s" + +(* FIXME: move to ADT_AI.thy *) +definition ptable_attrs :: "obj_ref \ 's :: state_ext state \ obj_ref \ vm_attributes" where + "ptable_attrs tcb s \ + \addr. case_option {} (fst o snd o snd) + (get_page_info (aobjs_of s) (get_vspace_of_thread (kheap s) (arch_state s) tcb) addr)" + +definition ptable_attrs_s :: "'s :: state_ext state \ obj_ref \ vm_attributes" where + "ptable_attrs_s s \ ptable_attrs (cur_thread s) s" + +definition ptable_xn_s where + "ptable_xn_s s \ \addr. Execute \ ptable_attrs_s s addr" + + +type_synonym user_state_if = "user_context \ user_mem \ device_state" + +text \ + A user transition gives back a possible event that is the next + event the user wants to perform +\ +type_synonym user_transition_if = + "obj_ref \ vm_mapping \ mem_rights \ (obj_ref \ bool) \ + user_state_if \ (event option \ user_state_if) set" + + +definition do_user_op_if :: + "user_transition_if \ user_context \ (event option \ user_context,'z::state_ext) s_monad" where + "do_user_op_if uop tc = + do + \ \Get the page rights of each address (ReadOnly, ReadWrite, None, etc).\ + pr \ gets ptable_rights_s; + + \ \Fetch the execute bits of the current thread's page mappings.\ + pxn \ gets (\s x. pr x \ {} \ ptable_xn_s s x); + + \ \Get the mapping from virtual to physical addresses.\ + pl \ gets (\s. restrict_map (ptable_lift_s s) {x. pr x \ {}}); + + allow_read \ return {y. EX x. pl x = Some y \ AllowRead \ pr x}; + allow_write \ return {y. EX x. pl x = Some y \ AllowWrite \ pr x}; + + \ \Get the current thread.\ + t \ gets cur_thread; + + \ \Generate user memory by throwing away anything from global + memory that the user doesn't have access to. (The user must + have both (1) a mapping to the page; (2) that mapping has the + AllowRead right.\ + um \ gets (\s. (user_mem s) \ ptrFromPAddr); + dm \ gets (\s. (device_mem s) \ ptrFromPAddr); + ds \ gets (device_state \ machine_state); + + \ \Non-deterministically execute one of the user's operations.\ + u \ return (uop t pl pr pxn (tc, um|`allow_read, (ds \ ptrFromPAddr)|` allow_read)); + assert (u \ {}); + (e,(tc',um',ds')) \ select u; + + \ \Update the changes the user made to memory into our model. + We ignore changes that took place where they didn't have + write permissions. (uop shouldn't be doing that --- if it is, + uop isn't correctly modelling real hardware.)\ + do_machine_op (user_memory_update (((um' |` allow_write) \ addrFromPPtr) |` (-(dom ds)))); + + do_machine_op (device_memory_update (((ds' |` allow_write) \ addrFromPPtr) |` (dom ds))); + + return (e,tc') + od" + + +named_theorems UserOp_IF_assms + +lemma arch_globals_equiv_underlying_memory_update[UserOp_IF_assms, simp]: + "arch_globals_equiv ct it kh kh' as as' (underlying_memory_update f ms) ms' = + arch_globals_equiv ct it kh kh' as as' ms ms'" + "arch_globals_equiv ct it kh kh' as as' ms (underlying_memory_update f ms') = + arch_globals_equiv ct it kh kh' as as' ms ms'" + by auto + +lemma arch_globals_equiv_device_state_update[UserOp_IF_assms, simp]: + "arch_globals_equiv ct it kh kh' as as' (device_state_update f ms) ms' = + arch_globals_equiv ct it kh kh' as as' ms ms'" + "arch_globals_equiv ct it kh kh' as as' ms (device_state_update f ms') = + arch_globals_equiv ct it kh kh' as as' ms ms'" + by auto + +end + + +requalify_types AARCH64.user_transition_if + +global_interpretation UserOp_IF_1?: UserOp_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact UserOp_IF_assms)?) +qed + + +context Arch begin global_naming AARCH64 + +lemma requiv_get_pt_of_thread_eq: + "\ reads_equiv aag s s'; pas_refined aag s; is_subject aag (cur_thread s); + pt_ref \ arm_us_global_vspace (arch_state s); pt_ref' \ arm_us_global_vspace (arch_state s'); + get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = pt_ref; + get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = pt_ref' \ + \ pt_ref = pt_ref'" + apply (erule reads_equivE) + apply (erule equiv_forE) + apply (subgoal_tac "aag_can_read aag (cur_thread s)") + apply (clarsimp simp: get_vspace_of_thread_eq) + apply simp + done + +lemma requiv_get_pt_entry_eq: + "\ reads_equiv aag s t; invs s; pas_refined aag s; is_subject aag pt; vref \ user_region; + \asid vref. vs_lookup_table max_pt_level asid vref s = Some (max_pt_level, pt) \ + \ pt_lookup_slot pt vref (ptes_of s) = pt_lookup_slot pt vref (ptes_of t)" + apply (clarsimp simp: pt_lookup_slot_def) + apply (clarsimp simp: pt_lookup_slot_from_level_def) + apply (frule_tac pt=pt and vptr=vref in pt_walk_reads_equiv[where bot_level=0]) + apply clarsimp+ + apply (fastforce simp: reads_equiv_f_def) + apply (fastforce elim: vs_lookup_table_vref_independent) + apply (clarsimp simp: obind_def split: option.splits) + done + +lemma requiv_get_page_info_eq: + "\ reads_equiv aag s s'; pas_refined aag s; invs s; is_subject aag pt; x \ kernel_mappings; + \asid. vs_lookup_table max_pt_level asid x s = Some (max_pt_level, pt) \ + \ get_page_info (aobjs_of s) pt x = get_page_info (aobjs_of s') pt x" + apply (clarsimp simp: get_page_info_def obind_def) + apply (subgoal_tac "pt_lookup_slot pt x (ptes_of s) = pt_lookup_slot pt x (ptes_of s')") + apply (clarsimp split: option.splits) + apply (case_tac "pt_lookup_slot pt x (ptes_of s') = Some (a, b)"; clarsimp) + apply (frule_tac ptr=b in ptes_of_reads_equiv[rotated]) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (prop_tac "ba = bb", clarsimp simp: pt_slot_offset_def) + apply (frule pt_walk_is_aligned) + apply (erule vs_lookup_table_is_aligned; clarsimp simp: canonical_not_kernel_is_user) + apply (erule pt_walk_is_subject, (fastforce simp: canonical_not_kernel_is_user)+) + apply (rule requiv_get_pt_entry_eq; fastforce simp: canonical_not_kernel_is_user) + done + +lemma requiv_vspace_of_thread_global_pt: + "\ reads_equiv aag s s'; is_subject aag (cur_thread s); invs s; pas_refined aag s; + get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = global_pt s \ + \ get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = global_pt s'" + apply (erule reads_equivE) + apply (erule equiv_forE) + apply (prop_tac "aag_can_read aag (cur_thread s)", simp) + apply (clarsimp simp: get_vspace_of_thread_def + split: option.split kernel_object.splits cap.splits arch_cap.splits) + apply (rename_tac tcb word word' word'') + apply (subgoal_tac "aag_can_read_asid aag word'") + apply (subgoal_tac "s \ ArchObjectCap (PageTableCap word (Some (word',word'')))") + apply (clarsimp simp: equiv_asids_def equiv_asid_def valid_cap_def obind_def + vspace_for_asid_def vspace_for_pool_def pool_for_asid_def) + apply (clarsimp simp: word_gt_0 typ_at_eq_kheap_obj) + apply (drule_tac x=word' in spec) + apply (case_tac "word' = 0"; clarsimp) + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def asid_low_bits_of_def opt_map_def + split: option.splits) + apply (frule valid_global_arch_objs_global_ptD[OF invs_valid_global_arch_objs]) + apply (drule invs_valid_global_refs) + apply (drule_tac ptr="((cur_thread s), tcb_cnode_index 1)" in valid_global_refsD2[rotated]) + apply (subst caps_of_state_tcb_cap_cases) + apply (simp add: get_tcb_def) + apply (simp add: dom_tcb_cap_cases[simplified]) + apply simp + apply (simp add: cap_range_def global_refs_def) + apply (cut_tac s=s and t="cur_thread s" and tcb=tcb in objs_valid_tcb_vtable) + apply (fastforce simp: invs_valid_objs get_tcb_def)+ + apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag word') + \ state_asids_to_policy aag s") + apply (frule pas_refined_Control_into_is_subject_asid) + apply (fastforce simp: pas_refined_def) + apply simp + apply (cut_tac aag=aag and ptr="(cur_thread s, tcb_cnode_index 1)" in sata_asid) + prefer 3 + apply (simp add: caps_of_state_tcb_cap_cases get_tcb_def dom_tcb_cap_cases[simplified])+ + done + +lemma vspace_for_asid_get_vspace_of_thread: + "get_vspace_of_thread (kheap s) (arch_state s) ct \ global_pt s + \ \asid. vspace_for_asid asid s = Some (get_vspace_of_thread (kheap s) (arch_state s) ct)" + by (fastforce simp: get_vspace_of_thread_def + split: option.splits kernel_object.splits cap.splits arch_cap.splits) + +lemma pt_of_thread_same_agent: + "\ pas_refined aag s; is_subject aag tcb_ptr; + get_vspace_of_thread (kheap s) (arch_state s) tcb_ptr = pt; pt \ global_pt s \ + \ pasObjectAbs aag tcb_ptr = pasObjectAbs aag pt" + apply (rule_tac aag="pasPolicy aag" in aag_wellformed_Control[rotated]) + apply (fastforce simp: pas_refined_def) + apply (rule pas_refined_mem[rotated], simp) + apply (clarsimp simp: get_vspace_of_thread_eq) + apply (cut_tac ptr="(tcb_ptr, tcb_cnode_index 1)" in sbta_caps) + prefer 4 + apply (simp add: state_objs_to_policy_def) + apply (subst caps_of_state_tcb_cap_cases) + apply (simp add: get_tcb_def) + apply (simp add: dom_tcb_cap_cases[simplified]) + apply simp + apply (simp add: obj_refs_def) + apply (simp add: cap_auth_conferred_def arch_cap_auth_conferred_def) + done + +lemma requiv_ptable_rights_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; + is_subject aag (cur_thread s); invs s; invs s' \ + \ ptable_rights_s s = ptable_rights_s s'" + apply (simp add: ptable_rights_s_def) + apply (rule ext) + apply (case_tac "x \ kernel_mappings") + apply (clarsimp simp: ptable_rights_def split: option.splits) + apply (rule conjI; clarsimp) + apply (frule some_get_page_info_kmapsD; + fastforce dest: invs_arch_state vspace_for_asid_get_vspace_of_thread + simp: valid_arch_state_def kernel_mappings_canonical) + apply (frule some_get_page_info_kmapsD) + apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread + simp: valid_arch_state_def kernel_mappings_canonical)[12] + apply (frule_tac r=b in some_get_page_info_kmapsD) + apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread + simp: valid_arch_state_def kernel_mappings_canonical)[12] + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = + arm_us_global_vspace (arch_state s)") + apply (frule requiv_vspace_of_thread_global_pt) + apply (auto)[4] + apply (fastforce dest: get_page_info_gpd_kmaps[rotated, rotated] + simp: ptable_rights_def invs_valid_global_objs invs_arch_state + split: option.splits)+ + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = + arm_us_global_vspace (arch_state s')") + apply (drule reads_equiv_sym) + apply (frule requiv_vspace_of_thread_global_pt; fastforce simp: reads_equiv_def) + apply (simp add: ptable_rights_def) + apply (frule requiv_get_pt_of_thread_eq) + apply (auto)[6] + apply (frule pt_of_thread_same_agent, simp+) + apply (subst requiv_get_page_info_eq, simp+) + apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp) + apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+ + done + +lemma requiv_ptable_attrs_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; + is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \ {} \ + \ ptable_attrs_s s x = ptable_attrs_s s' x" + apply (simp add: ptable_attrs_s_def ptable_rights_s_def) + apply (case_tac "x \ kernel_mappings") + apply (clarsimp simp: ptable_attrs_def split: option.splits) + apply (rule conjI) + apply clarsimp + apply (frule some_get_page_info_kmapsD) + apply (auto simp: vspace_for_asid_get_vspace_of_thread ptable_rights_def)[12] + apply clarsimp + apply (frule some_get_page_info_kmapsD) + apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread + simp: valid_arch_state_def kernel_mappings_canonical ptable_rights_def)[12] + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = + arm_us_global_vspace (arch_state s)") + apply (frule requiv_vspace_of_thread_global_pt) + apply (fastforce+)[4] + apply (clarsimp simp: ptable_attrs_def split: option.splits) + apply (rule conjI) + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply clarsimp + apply (rule conjI) + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = + arm_us_global_vspace (arch_state s')") + apply (drule reads_equiv_sym) + apply (frule requiv_vspace_of_thread_global_pt) + apply ((fastforce simp: reads_equiv_def)+)[5] + apply (simp add: ptable_attrs_def) + apply (frule requiv_get_pt_of_thread_eq, simp+)[1] + apply (frule pt_of_thread_same_agent, simp+)[1] + apply (subst requiv_get_page_info_eq, simp+) + apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp) + apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+ + done + +lemma requiv_ptable_lift_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; invs s; + invs s'; is_subject aag (cur_thread s); ptable_rights_s s x \ {} \ + \ ptable_lift_s s x = ptable_lift_s s' x" + apply (simp add: ptable_lift_s_def ptable_rights_s_def) + apply (case_tac "x \ kernel_mappings") + apply (clarsimp simp: ptable_lift_def split: option.splits) + apply (rule conjI) + apply clarsimp + apply (frule some_get_page_info_kmapsD) + apply (auto simp: vspace_for_asid_get_vspace_of_thread ptable_rights_def)[12] + apply clarsimp + apply (frule some_get_page_info_kmapsD) + apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread + simp: valid_arch_state_def kernel_mappings_canonical ptable_rights_def)[12] + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = + arm_us_global_vspace (arch_state s)") + apply (frule requiv_vspace_of_thread_global_pt) + apply (fastforce+)[4] + apply (clarsimp simp: ptable_lift_def split: option.splits) + apply (rule conjI) + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply clarsimp + apply (rule conjI) + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = + arm_us_global_vspace (arch_state s')") + apply (drule reads_equiv_sym) + apply (frule requiv_vspace_of_thread_global_pt) + apply ((fastforce simp: reads_equiv_def)+)[5] + apply (simp add: ptable_lift_def) + apply (frule requiv_get_pt_of_thread_eq, simp+)[1] + apply (frule pt_of_thread_same_agent, simp+)[1] + apply (subst requiv_get_page_info_eq, simp+) + apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp) + apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+ + done + +lemma requiv_ptable_xn_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; + is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \ {} \ + \ ptable_xn_s s x = ptable_xn_s s' x" + by (simp add: ptable_xn_s_def requiv_ptable_attrs_eq) + +lemma data_at_obj_range: + "\ data_at sz ptr s; pspace_aligned s; valid_objs s \ + \ ptr + (offset && mask (pageBitsForSize sz)) \ obj_range ptr (ArchObj (DataPage dev sz))" + apply (clarsimp simp: data_at_def) + apply (elim disjE) + apply (clarsimp simp: obj_at_def) + apply (drule (2) ptr_in_obj_range) + apply (clarsimp simp: obj_bits_def obj_range_def) + apply fastforce + apply (clarsimp simp: obj_at_def) + apply (drule (2) ptr_in_obj_range) + apply (clarsimp simp: obj_bits_def obj_range_def) + apply fastforce + done + +lemma obj_range_data_for_cong: + "obj_range ptr (ArchObj (DataPage dev sz')) = obj_range ptr (ArchObj (DataPage False sz'))" + by (simp add: obj_range_def) + +lemma pspace_distinct_def': + "pspace_distinct \ + \s. \x y ko ko'. kheap s x = Some ko \ kheap s y = Some ko' \ x \ y + \ obj_range x ko \ obj_range y ko' = {}" + by (auto simp: pspace_distinct_def obj_range_def field_simps) + +lemma data_at_disjoint_equiv: + "\ ptr' \ ptr;data_at sz' ptr' s; data_at sz ptr s; valid_objs s; pspace_aligned s; + pspace_distinct s; ptr' \ obj_range ptr (ArchObj (DataPage dev sz)) \ + \ False" + apply (frule (2) data_at_obj_range[where offset = 0,simplified]) + apply (clarsimp simp: data_at_def obj_at_def) + apply (elim disjE) + by (clarsimp dest!: spec simp: obj_at_def pspace_distinct_def' + , erule impE, erule conjI2[OF conjI2], (fastforce+)[2] + , fastforce cong: obj_range_data_for_cong)+ + +lemma is_aligned_pptrBaseOffset: + "is_aligned pptrBaseOffset (pageBitsForSize sz)" + by (case_tac sz, simp_all add: pptrBaseOffset_def paddrBase_def pageBits_def canonical_bit_def + ptTranslationBits_def pptrBase_def is_aligned_def) + +lemma ptrFromPAddr_mask_simp: + "ptrFromPAddr z && ~~ mask (pageBitsForSize l) = + ptrFromPAddr (z && ~~ mask (pageBitsForSize l))" + apply (simp add: ptrFromPAddr_def field_simps) + apply (subst mask_out_add_aligned[OF is_aligned_pptrBaseOffset]) + apply simp + done + +lemma pageBitsForSize_le_canonical_bit: + "pageBitsForSize sz \ canonical_bit" + by (cases sz, simp_all add: pageBits_def ptTranslationBits_def canonical_bit_def) + +lemma data_at_same_size: + assumes dat_sz': + "data_at sz' (ptrFromPAddr base) s" + and dat_sz: + "data_at sz + (ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz)) s" + and vs: + "pspace_distinct s" "pspace_aligned s" "valid_objs s" + shows "sz' = sz" +proof - + from dat_sz' and dat_sz + have trivial: + "sz' \ sz + \ ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz) \ + ptrFromPAddr base" + by (auto simp: data_at_def obj_at_def) + have sz_equiv: "(pageBitsForSize sz = pageBitsForSize sz') = (sz' = sz)" + by (clarsimp simp: pageBitsForSize_def ptTranslationBits_def split: vmpage_size.splits) + show ?thesis + apply (rule sz_equiv[THEN iffD1]) + apply (rule ccontr) + apply (drule neq_iff[THEN iffD1]) + using dat_sz' dat_sz vs + apply (cut_tac trivial) prefer 2 + apply (fastforce simp: sz_equiv) + apply (frule(1) data_at_aligned) + apply (elim disjE) + apply (erule(5) data_at_disjoint_equiv) + apply (unfold obj_range_def) + apply (rule mask_in_range[THEN iffD1]) + apply (simp add: obj_bits_def)+ + apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp) + apply (rule arg_cong[where f = ptrFromPAddr]) + apply (subst (asm) is_aligned_ptrFromPAddr_n_eq[OF pageBitsForSize_le_canonical_bit]) + apply (subst neg_mask_add_aligned[OF _ and_mask_less']) + apply simp + apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) + apply (simp add: is_aligned_neg_mask_eq) + apply (drule not_sym) + apply (erule(5) data_at_disjoint_equiv) + apply (unfold obj_range_def) + apply (rule mask_in_range[THEN iffD1]) + apply (simp add: obj_bits_def is_aligned_neg_mask)+ + apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp) + apply (rule arg_cong[where f = ptrFromPAddr]) + apply (subst (asm) is_aligned_ptrFromPAddr_n_eq[OF pageBitsForSize_le_canonical_bit]) + apply (rule sym) + apply (subst mask_lower_twice[symmetric]) + apply (erule less_imp_le_nat) + apply (rule arg_cong[where f = "\x. x && ~~ mask z" for z]) + apply (subst neg_mask_add_aligned[OF _ and_mask_less']) + apply simp + apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) + apply simp + done +qed + +lemma level_le_2_cases: + "(level :: vm_level) \ 2 \ level = 0 \ level = 1 \ level = 2" + apply clarsimp + apply (erule_tac P="level=2" in swap) + apply (subst (asm) order.order_iff_strict) + apply (erule disjE_R) + apply (clarsimp simp: order.strict_implies_not_eq) + apply (induct level; clarsimp) + apply (drule meta_mp) + apply (erule order.strict_implies_not_eq) + apply (drule meta_mp) + apply (rule bit0.minus_one_leq_less) + apply (erule order.strict_implies_order) + apply (erule bit0.zero_least) + apply clarsimp + apply clarsimp + done + +lemma ptable_lift_data_consistant: + assumes vs: "valid_state s" + and pt_lift: "ptable_lift t s x = Some ptr" + and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s" + and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \ arm_us_global_vspace (arch_state s)" + "x \ kernel_mappings" + shows "ptable_lift t s (x && ~~ mask (pageBitsForSize sz)) = + Some (ptr && ~~ mask (pageBitsForSize sz))" +proof - + have vs': "valid_objs s \ valid_arch_state s \ valid_vspace_objs s + \ pspace_distinct s \ pspace_aligned s" + using vs by (simp add: valid_state_def valid_pspace_def) + thus ?thesis + using pt_lift dat vs' + apply (clarsimp simp: ptable_lift_def split: option.splits) + apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits) + apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]]) + apply (rename_tac level pt pde asid) + apply (case_tac pde; clarsimp simp: pte_info_def) + apply (frule pt_lookup_slot_max_pt_level) + apply (frule vspace_for_asid_vs_lookup) + apply (frule canonical_not_kernel_is_user[OF misc(2)]) + apply (frule_tac level=level in valid_vspace_objs_pte) + apply clarsimp + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] + dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI + intro: vs_lookup_level) + apply (erule disjE[OF _ _ FalseE]) + prefer 2 + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) + apply (clarsimp split: if_splits) + apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2) + apply (subst (asm) table_index_max_level_slots; clarsimp?) + apply (fastforce dest: vs_lookup_table_is_aligned valid_arch_state_asid_table) + apply (clarsimp simp: valid_pte_def) + apply (frule data_at_same_size; simp?) + apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t) + (vref_for_level x level) (ptes_of s) = Some (level, pt)") + apply (case_tac "level = max_pt_level"; clarsimp) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) + apply (subst (asm) pt_lookup_vs_lookup_eq) + apply clarsimp + apply (clarsimp simp: vspace_for_asid_def) + apply (clarsimp simp: pt_walk.simps) + apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2 in_omonad) + apply (fold vref_for_level_def) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) + apply (rule exI) + apply (subst pt_walk_vref_for_level_eq[where vref'=x]) + apply (fastforce dest: level_le_2_cases le_neq_trans simp: max_pt_level_def2 max_def) + apply clarsimp + apply fastforce + apply (fastforce simp: vref_for_level_def is_aligned_mask_out_add_eq mask_AND_NOT_mask + pt_bits_left_le_canonical is_aligned_ptrFromPAddr_n_eq + elim: canonical_vref_for_levelI[unfolded vref_for_level_def] + dest: data_at_aligned) + done +qed + +lemma ptable_rights_data_consistant: + assumes vs: "valid_state s" + and pt_lift: "ptable_lift t s x = Some ptr" + and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s" + and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \ + arm_us_global_vspace (arch_state s)" "x \ kernel_mappings" + shows "ptable_rights t s (x && ~~ mask (pageBitsForSize sz)) = ptable_rights t s x" +proof - + have vs': "valid_objs s \ valid_arch_state s \ valid_vspace_objs s + \ pspace_distinct s \ pspace_aligned s" + using vs by (simp add: valid_state_def valid_pspace_def) + thus ?thesis + using pt_lift dat vs' + apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits) + apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits) + apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]]) + apply (rename_tac level pt pde asid) + apply (case_tac pde; clarsimp simp: pte_info_def) + apply (frule pt_lookup_slot_max_pt_level) + apply (frule vspace_for_asid_vs_lookup) + apply (frule canonical_not_kernel_is_user[OF misc(2)]) + apply (frule_tac level=level in valid_vspace_objs_pte) + apply clarsimp + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] + dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI + intro: vs_lookup_level) + apply (erule disjE[OF _ _ FalseE]) + prefer 2 + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) + apply (clarsimp split: if_splits) + apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2) + apply (subst (asm) table_index_max_level_slots; clarsimp?) + apply (fastforce dest: vs_lookup_table_is_aligned valid_arch_state_asid_table) + apply (clarsimp simp: valid_pte_def) + apply (frule data_at_same_size; simp?) + apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t) + (vref_for_level x level) (ptes_of s) = Some (level, pt)") + apply (case_tac "level = max_pt_level"; clarsimp) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) + apply (subst (asm) pt_lookup_vs_lookup_eq) + apply clarsimp + apply (clarsimp simp: vspace_for_asid_def) + apply (clarsimp simp: pt_walk.simps) + apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2 in_omonad) + apply (fold vref_for_level_def) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) + apply (rule exI) + apply (subst pt_walk_vref_for_level_eq[where vref'=x]) + apply (fastforce dest: level_le_2_cases le_neq_trans simp: max_pt_level_def2 max_def) + apply clarsimp + apply fastforce + apply (clarsimp simp: vref_for_level_def) + apply (fastforce dest: canonical_vref_for_levelI[unfolded vref_for_level_def] + simp: pt_bits_left_le_canonical ) + done +qed + + +lemma user_op_access_data_at: + "\ invs s; pas_refined aag s; is_subject aag tcb; ptable_lift tcb s x = Some ptr; + data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s; + auth \ vspace_cap_rights_to_auth (ptable_rights tcb s x) \ + \ (pasObjectAbs aag tcb, auth, + pasObjectAbs aag (ptrFromPAddr (ptr && ~~ mask (pageBitsForSize sz)))) \ pasPolicy aag" + apply (case_tac "x \ kernel_mappings") + apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits) + apply (frule some_get_page_info_kmapsD) + apply (fastforce dest: invs_arch_state invs_equal_kernel_mappings + simp: valid_arch_state_def vspace_for_asid_get_vspace_of_thread + kernel_mappings_canonical vspace_cap_rights_to_auth_def)+ + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) tcb = arm_us_global_vspace (arch_state s)") + apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits) + apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply (fastforce simp: invs_valid_global_objs invs_arch_state)+ + apply (frule (2) ptable_lift_data_consistant[rotated 2]) + apply fastforce + apply fastforce + apply (frule (2) ptable_rights_data_consistant[rotated 2]) + apply fastforce + apply fastforce + apply (erule (3) user_op_access) + apply simp + done + +lemma user_frame_at_equiv: + "\ typ_at (AArch (AUserData sz)) p s; equiv_for P kheap s s'; P p \ + \ typ_at (AArch (AUserData sz)) p s'" + by (clarsimp simp: equiv_for_def obj_at_def) + +lemma device_frame_at_equiv: + "\ typ_at (AArch (ADeviceData sz)) p s; equiv_for P kheap s s'; P p \ + \ typ_at (AArch (ADeviceData sz)) p s'" + by (clarsimp simp: equiv_for_def obj_at_def) + +lemma typ_at_user_data_at: + "typ_at (AArch (AUserData sz)) p s \ data_at sz p s" + by (simp add: data_at_def) + +lemma typ_at_device_data_at: + "typ_at (AArch (ADeviceData sz)) p s \ data_at sz p s" + by (simp add: data_at_def) + +lemma requiv_device_mem_eq: + "\ reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; + is_subject aag (cur_thread s); AllowRead \ ptable_rights_s s x; + ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \ + \ device_mem s (ptrFromPAddr y) = device_mem s' (ptrFromPAddr y)" + apply (simp add: device_mem_def) + apply (rule conjI) + apply (erule reads_equivE) + apply (clarsimp simp: in_device_frame_def) + apply (rule exI) + apply (rule device_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (frule_tac auth=Read in user_op_access_data_at[where s=s]) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_device_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + apply clarsimp + apply (frule requiv_ptable_rights_eq, fastforce+) + apply (frule requiv_ptable_lift_eq, fastforce+) + apply (clarsimp simp: globals_equiv_def) + apply (erule notE) + apply (erule reads_equivE) + apply (clarsimp simp: in_device_frame_def) + apply (rule exI) + apply (rule device_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (erule equiv_symmetric[THEN iffD1]) + apply (frule_tac auth=Read in user_op_access_data_at[where s=s']) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_device_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + done + +lemma requiv_user_mem_eq: + "\ reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; + is_subject aag (cur_thread s); AllowRead \ ptable_rights_s s x; + ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \ + \ user_mem s (ptrFromPAddr y) = user_mem s' (ptrFromPAddr y)" + apply (simp add: user_mem_def) + apply (rule conjI) + apply clarsimp + apply (rule context_conjI') + apply (erule reads_equivE) + apply (clarsimp simp: in_user_frame_def) + apply (rule exI) + apply (rule user_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (frule_tac auth=Read in user_op_access_data_at[where s = s]) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_user_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + apply clarsimp + apply (subgoal_tac "aag_can_read aag (ptrFromPAddr y)") + apply (erule reads_equivE) + apply clarsimp + apply (erule_tac f="underlying_memory" in equiv_forE) + apply simp + apply (frule_tac auth=Read in user_op_access) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+ + apply (rule reads_read) + apply simp + apply (frule requiv_ptable_rights_eq, fastforce+) + apply (frule requiv_ptable_lift_eq, fastforce+) + apply (clarsimp simp: globals_equiv_def) + apply (erule notE) + apply (erule reads_equivE) + apply (clarsimp simp: in_user_frame_def) + apply (rule exI) + apply (rule user_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (erule equiv_symmetric[THEN iffD1]) + apply (frule_tac auth=Read in user_op_access_data_at[where s=s']) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_user_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + done + +lemma ptable_rights_imp_frameD: + "\ ptable_lift t s x = Some y;valid_state s;ptable_rights t s x \ {} \ + \ \sz. data_at sz (ptrFromPAddr y && ~~ mask (pageBitsForSize sz)) s" + apply (subst (asm) addrFromPPtr_ptrFromPAddr_id[symmetric]) + apply (drule ptable_rights_imp_frame) + apply simp+ + apply (rule addrFromPPtr_ptrFromPAddr_id[symmetric]) + apply (auto simp: in_user_frame_def in_device_frame_def + dest!: spec typ_at_user_data_at typ_at_device_data_at) + done + +lemma requiv_user_device_eq: + "\ reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; + is_subject aag (cur_thread s); AllowRead \ ptable_rights_s s x; + ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \ + \ device_state (machine_state s) (ptrFromPAddr y) = + device_state (machine_state s') (ptrFromPAddr y)" + apply (simp add: ptable_lift_s_def) + apply (frule ptable_rights_imp_frameD) + apply fastforce + apply (fastforce simp: ptable_rights_s_def) + apply (erule reads_equivE) + apply clarsimp + apply (erule_tac f="device_state" in equiv_forD) + apply (frule_tac auth=Read in user_op_access_data_at[where s = s]) + apply ((fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_user_data_at)+)[6] + apply (rule reads_read) + apply (frule_tac auth=Read in user_op_access) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+ + done + + +definition context_matches_state where + "context_matches_state pl pr pxn ms s \ case ms of (um, ds) \ + pl = ptable_lift_s s |` {x. pr x \ {}} \ + pr = ptable_rights_s s \ + pxn = (\x. pr x \ {} \ ptable_xn_s s x) \ + um = (user_mem s \ ptrFromPAddr) |` {y. \x. pl x = Some y \ AllowRead \ pr x} \ + ds = (device_state (machine_state s) \ ptrFromPAddr) |` + {y. \x. pl x = Some y \ AllowRead \ pr x}" + + +lemma do_user_op_reads_respects_g: + notes split_paired_All[simp del] + shows + "(\pl pr pxn tc ms s. P tc s \ context_matches_state pl pr pxn ms s + \ (\x. uop (cur_thread s) pl pr pxn (tc, ms) = {x})) + \ reads_respects_g aag l (pas_refined aag and invs and is_subject aag \ cur_thread + and (\s. cur_thread s \ idle_thread s) and P tc) + (do_user_op_if uop tc)" + apply (simp add: do_user_op_if_def) + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_add_asm) + apply (rule spec_equiv_valid_add_rel[OF _ reads_equiv_g_refl]) + apply (rule spec_equiv_valid_add_rel'[OF _ affects_equiv_refl]) + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (clarsimp simp: reads_equiv_g_def) + apply (rule requiv_ptable_rights_eq,simp+)[1] + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (rule ext) + apply (clarsimp simp: reads_equiv_g_def) + apply (case_tac "ptable_rights_s st x = {}", simp) + apply simp + apply (rule requiv_ptable_xn_eq,simp+)[1] + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (subst expand_restrict_map_eq,clarsimp) + apply (clarsimp simp: reads_equiv_g_def) + apply (rule requiv_ptable_lift_eq,simp+)[1] + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (clarsimp simp: reads_equiv_g_def) + apply (rule requiv_cur_thread_eq,fastforce) + apply (rule spec_equiv_valid_inv_gets_more[where proj="\m. dom m \ cw" + and projsnd="\m. m |` cr" for cr and cw]) + apply (rule context_conjI') + apply (subst expand_restrict_map_eq) + apply (clarsimp simp: reads_equiv_g_def restrict_map_def) + apply (rule requiv_user_mem_eq) + apply simp+ + apply fastforce + apply (rule spec_equiv_valid_inv_gets[where proj = "\x. ()", simplified]) + apply (rule spec_equiv_valid_inv_gets_more[where proj = "\m. (m \ ptrFromPAddr) |` cr" for cr]) + apply (rule conjI) + apply (subst expand_restrict_map_eq) + apply (clarsimp simp: restrict_map_def reads_equiv_g_def) + apply (rule requiv_user_device_eq) + apply simp+ + apply (clarsimp simp: globals_equiv_def reads_equiv_g_def) + apply (rule spec_equiv_valid_guard_imp) + apply (wpsimp wp: dmo_user_memory_update_reads_respects_g dmo_device_state_update_reads_respects_g + dmo_device_state_update_reads_respects_g select_ev dmo_wp) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply (drule spec)+ + apply (erule impE) + prefer 2 + apply assumption + apply (clarsimp simp: context_matches_state_def comp_def reads_equiv_g_def globals_equiv_def) + apply (clarsimp simp: reads_equiv_g_def globals_equiv_def) + done + +definition valid_vspace_objs_if where + "valid_vspace_objs_if \ \" + +declare valid_vspace_objs_if_def[simp] + +end + +requalify_consts + AARCH64.do_user_op_if + AARCH64.valid_vspace_objs_if + AARCH64.context_matches_state + +requalify_facts + AARCH64.do_user_op_reads_respects_g + +end diff --git a/proof/infoflow/AARCH64/Example_Valid_State.thy b/proof/infoflow/AARCH64/Example_Valid_State.thy new file mode 100644 index 0000000000..d9c7e5fc94 --- /dev/null +++ b/proof/infoflow/AARCH64/Example_Valid_State.thy @@ -0,0 +1,1942 @@ +(* + * Copyright 2023, Proofcraft Pty Ltd + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory Example_Valid_State +imports + "ArchNoninterference" + "Lib.Distinct_Cmd" + "AInvs.KernelInit_AI" +begin + +section \Example\ + +(* This example is a classic 'one way information flow' + example, where information is allowed to flow from Low to High, + but not the reverse. We consider a typical scenario where + shared memory and an notification for notifications are used to + implement a ring-buffer. We consider the NTFN to be in the domain of High, + and the shared memory to be in the domain of Low. *) + +(* basic machine-level declarations that need to happen outside the locale *) + +consts s0_context :: user_context + +(* define the irqs to come regularly every 10 *) + +axiomatization where + irq_oracle_def: "AARCH64.irq_oracle \ \pos. if pos mod 10 = 0 then 10 else 0" + +context begin interpretation Arch . (*FIXME: arch-split*) + +subsection \We show that the authority graph does not let information flow from High to Low\ + +datatype auth_graph_label = High | Low | IRQ0 + +abbreviation partition_label where + "partition_label x \ OrdinaryLabel x" + +definition Sys1AuthGraph :: "(auth_graph_label subject_label) auth_graph" where + "Sys1AuthGraph \ + {(partition_label High, Read, partition_label Low), + (partition_label Low, Notify, partition_label High), + (partition_label Low, Reset, partition_label High), + (SilcLabel, Read, partition_label Low), + (SilcLabel, Notify, partition_label High), + (SilcLabel, Reset, partition_label High)} + \ {(x, a, y). x = y}" + +lemma subjectReads_Low: + "subjectReads Sys1AuthGraph (partition_label Low) = {partition_label Low}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectReads.induct, (fastforce simp: Sys1AuthGraph_def)+) + done + +lemma Low_in_subjectReads_High: + "partition_label Low \ subjectReads Sys1AuthGraph (partition_label High)" + by (simp add: Sys1AuthGraph_def reads_read) + +lemma subjectReads_High: + "subjectReads Sys1AuthGraph (partition_label High) = {partition_label High, partition_label Low}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectReads.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: Low_in_subjectReads_High) + done + +lemma subjectReads_IRQ0: + "subjectReads Sys1AuthGraph (partition_label IRQ0) = {partition_label IRQ0}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectReads.induct, (fastforce simp: Sys1AuthGraph_def)+) + done + +lemma High_in_subjectAffects_Low: + "partition_label High \ subjectAffects Sys1AuthGraph (partition_label Low)" + apply (rule affects_ep) + apply (simp add: Sys1AuthGraph_def) + apply (rule disjI1, simp+) + done + +lemma subjectAffects_Low: + "subjectAffects Sys1AuthGraph (partition_label Low) = {partition_label Low, partition_label High}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectAffects.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: affects_lrefl High_in_subjectAffects_Low) + done + +lemma subjectAffects_High: + "subjectAffects Sys1AuthGraph (partition_label High) = {partition_label High}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectAffects.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: affects_lrefl) + done + +lemma subjectAffects_IRQ0: + "subjectAffects Sys1AuthGraph (partition_label IRQ0) = {partition_label IRQ0}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectAffects.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: affects_lrefl) + done + +lemmas subjectReads = subjectReads_High subjectReads_Low subjectReads_IRQ0 + +lemma partsSubjectAffects_Low: + "partsSubjectAffects Sys1AuthGraph Low = {Partition Low, Partition High}" + by (auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def + subjectReads subjectAffects_Low | case_tac xa, rename_tac xa)+ + +lemma partsSubjectAffects_High: + "partsSubjectAffects Sys1AuthGraph High = {Partition High}" + by (auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def + subjectReads subjectAffects_High | rename_tac xa, case_tac xa)+ + +lemma partsSubjectAffects_IRQ0: + "partsSubjectAffects Sys1AuthGraph IRQ0 = {Partition IRQ0}" + by (auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def + subjectReads subjectAffects_IRQ0 | rename_tac xa, case_tac xa)+ + +lemmas partsSubjectAffects = + partsSubjectAffects_High partsSubjectAffects_Low partsSubjectAffects_IRQ0 + +definition example_policy where + "example_policy \ + {(PSched, d) | d. True} \ {(d,e). d = e} \ {(Partition Low, Partition High)}" + +lemma "policyFlows Sys1AuthGraph = example_policy" + apply (rule equalityI) + apply (rule subsetI) + apply (clarsimp simp: example_policy_def) + apply (erule policyFlows.cases) + apply (case_tac l, auto simp: partsSubjectAffects)[1] + apply assumption + apply (rule subsetI) + apply (clarsimp simp: example_policy_def) + apply (elim disjE) + apply (fastforce simp: partsSubjectAffects intro: policy_affects) + apply (fastforce intro: policy_scheduler) + apply (fastforce intro: policyFlows_refl refl_onD) + done + + +subsection \We show there exists a valid initial state associated to the + above authority graph\ + +text \ + +This example (modified from ../access-control/ExampleSystem) is a system Sys1 made +of 2 main components Low and High, connected through an notification NTFN. +Both Low and High contains: + + . one TCB + . one vspace made up of one top-level page table + - one asid pool with a single entry for the corresponding vspace + . each top-level pt contains a single page table, with access to a shared page in memory + Low can read/write to this page, High can only read + . one cspace made up of one cnode + . each cspace contains 4 caps: + one to the tcb + one to the cnode itself + one to the top level page table + one to the asid pool + one to the shared page + one to the second level page table + one to the ntfn + +Low can send to the ntfn while High can receive from it. + +Attempt to ASCII art: + + -------- ---- ---- -------- + | | | | | | | | + V | | V S R | V | V +Low_tcb(3079)-->Low_cnode(6)--->ntfn(9)<---High_cnode(7)<--High_tcb(3080) + | | | | + V | | V +Low_pd(3063)<---------Low_pool High_pool------------> High_pd(3065) + | | + V R/W R V +Low_pt(3072)---------------->shared_page<-----------------High_pt(3077) + + +(the references are derived from the dump of the SAC system) + + +The aim is to be able to prove + + valid_initial_state s0_internal Sys1PAS timer_irq utf + +where Sys1PAS is the label graph defining the AC policy for Sys1 using +the authority graph defined above and s0 is the state of Sys1 described above. + +\ + +subsubsection \Defining the State\ + +definition "ntfn_ptr \ pptr_base + 0x20" + +definition "Low_tcb_ptr \ pptr_base + 0x400" +definition "High_tcb_ptr = pptr_base + 0x800" +definition "idle_tcb_ptr = pptr_base + 0x1000" + +definition "Low_pt_ptr = pptr_base + 0x4000" +definition "High_pt_ptr = pptr_base + 0x5000" + +definition "Low_pd_ptr = pptr_base + 0x7000" +definition "High_pd_ptr = pptr_base + 0x8000" + +definition "Low_pool_ptr = pptr_base + 0x9000" +definition "High_pool_ptr = pptr_base + 0xA000" + +definition "Low_cnode_ptr = pptr_base + 0x10000" +definition "High_cnode_ptr = pptr_base + 0x18000" +definition "Silc_cnode_ptr = pptr_base + 0x20000" +definition "irq_cnode_ptr = pptr_base + 0x28000" + +definition "shared_page_ptr_virt = pptr_base + 0x200000" +definition "shared_page_ptr_phys = addrFromPPtr shared_page_ptr_virt" + +definition "timer_irq \ 10" (* not sure exactly how this fits in *) + +definition "Low_mcp \ 5 :: priority" +definition "Low_prio \ 5 :: priority" +definition "High_mcp \ 5 :: priority" +definition "High_prio \ 5 :: priority" +definition "Low_time_slice \ 0 :: nat" +definition "High_time_slice \ 5 :: nat" +definition "Low_domain \ 0 :: domain" +definition "High_domain \ 1 :: domain" + +lemmas s0_ptr_defs = + Low_pool_ptr_def High_pool_ptr_def Low_cnode_ptr_def High_cnode_ptr_def Silc_cnode_ptr_def + ntfn_ptr_def irq_cnode_ptr_def Low_pd_ptr_def High_pd_ptr_def Low_pt_ptr_def High_pt_ptr_def + Low_tcb_ptr_def High_tcb_ptr_def idle_tcb_ptr_def timer_irq_def Low_prio_def High_prio_def + Low_time_slice_def Low_domain_def High_domain_def init_irq_node_ptr_def arm_global_pt_ptr_def + pptr_base_def pptrBase_def canonical_bit_def shared_page_ptr_virt_def + +(* Distinctness proof of kernel pointers. *) + +distinct ptrs_distinct[simp]: + Low_tcb_ptr High_tcb_ptr idle_tcb_ptr ntfn_ptr + Low_pt_ptr High_pt_ptr shared_page_ptr_virt Low_pd_ptr High_pd_ptr + Low_cnode_ptr High_cnode_ptr Low_pool_ptr High_pool_ptr + Silc_cnode_ptr irq_cnode_ptr arm_global_pt_ptr + by (auto simp: s0_ptr_defs) + + +text \We need to define the asids of each pd and pt to ensure that +the object is included in the right ASID-label\ + +definition Low_asid :: asid where + "Low_asid \ 1 << asid_low_bits" + +definition High_asid :: asid where + "High_asid \ 2 << asid_low_bits" + +definition Silc_asid :: asid where + "Silc_asid \ 3 << asid_low_bits" + +distinct asid_high_bits_distinct[simp]: + "asid_high_bits_of Low_asid" + "asid_high_bits_of High_asid" + "asid_high_bits_of Silc_asid" + by (auto simp: asid_high_bits_of_def asid_low_bits_def Low_asid_def High_asid_def Silc_asid_def) + +distinct asids_distinct[simp]: + High_asid Low_asid Silc_asid + by (auto simp: Low_asid_def High_asid_def Silc_asid_def asid_low_bits_def) + + +text \converting a nat to a bool list of size 10 - for the cnodes\ + +definition nat_to_bl :: "nat \ nat \ bool list option" where + "nat_to_bl bits n \ + if n \ 2^bits then None + else Some $ bin_to_bl bits (of_nat n)" + +lemma nat_to_bl_id [simp]: "nat_to_bl (size (x :: (('a::len) word))) (unat x) = Some (to_bl x)" + by (clarsimp simp: nat_to_bl_def to_bl_def le_def word_size) + +definition the_nat_to_bl :: "nat \ nat \ bool list" where + "the_nat_to_bl sz n \ the (nat_to_bl sz (n mod 2^sz))" + +abbreviation (input) the_nat_to_bl_10 :: "nat \ bool list" where + "the_nat_to_bl_10 n \ the_nat_to_bl 10 n" + +lemma len_the_nat_to_bl[simp]: + "length (the_nat_to_bl x y) = x" + apply (clarsimp simp: the_nat_to_bl_def nat_to_bl_def) + apply safe + apply (metis le_def mod_less_divisor nat_zero_less_power_iff zero_less_numeral) + apply (clarsimp simp: size_bin_to_bl_aux not_le) + done + +lemma tcb_cnode_index_nat_to_bl [simp]: + "the_nat_to_bl_10 n \ tcb_cnode_index n" + by (clarsimp simp: tcb_cnode_index_def intro!: length_neq) + +lemma mod_less_self [simp]: + "a \ b mod a \ ((a :: nat) = 0)" + by (metis mod_less_divisor nat_neq_iff not_less not_less0) + +lemma split_div_mod: + "a = (b::nat) \ (a div k = b div k \ a mod k = b mod k)" + by (metis mult_div_mod_eq) + +lemma nat_to_bl_eq: + assumes "a < 2 ^ n \ b < 2 ^ n" + shows "nat_to_bl n a = nat_to_bl n b \ a = b" + using assms + apply - + apply (erule disjE_R) + apply (clarsimp simp: nat_to_bl_def) + apply (case_tac "a \ 2 ^ n") + apply (clarsimp simp: nat_to_bl_def) + apply (clarsimp simp: not_le) + apply (induct n arbitrary: a b) + apply (clarsimp simp: nat_to_bl_def) + apply atomize + apply (clarsimp simp: nat_to_bl_def) + apply (erule_tac x="a div 2" in allE) + apply (erule_tac x="b div 2" in allE) + apply (erule impE) + apply (metis power_commutes td_gal_lt zero_less_numeral) + apply (clarsimp simp: bin_last_def zdiv_int) + apply (rule iffI [rotated], clarsimp) + apply (subst (asm) (1 2 3 4) bin_to_bl_aux_alt) + apply (clarsimp simp: mod_eq_dvd_iff) + apply (subst split_div_mod [where k=2]) + apply clarsimp + apply presburger + done + +lemma nat_to_bl_mod_n_eq[simp]: + "nat_to_bl n a = nat_to_bl n b \ ((a = b \ a < 2 ^ n) \ (a \ 2 ^ n \ b \ 2 ^ n))" + apply (rule iffI) + apply (clarsimp simp: not_le) + apply (subst (asm) nat_to_bl_eq, simp) + apply clarsimp + apply (erule disjE) + apply clarsimp + apply (clarsimp simp: nat_to_bl_def) + done + +lemma the_the_eq: + "\ x \ None; y \ None \ \ (the x = the y) = (x = y)" + by auto + +lemma the_nat_to_bl_eq [simp]: + "(the_nat_to_bl n a = the_nat_to_bl m b) \ (n = m \ (a mod 2 ^ n = b mod 2 ^ n))" + apply (case_tac "n = m") + apply (clarsimp simp: the_nat_to_bl_def) + apply (subst the_the_eq) + apply (clarsimp simp: nat_to_bl_def) + apply (clarsimp simp: nat_to_bl_def) + apply simp + apply simp + apply (metis len_the_nat_to_bl) + done + +lemma empty_cnode_eq_Some[simp]: + "(empty_cnode n x = Some y) = (length x = n \ y = NullCap)" + by (clarsimp simp: empty_cnode_def, metis) + +lemma empty_cnode_eq_None[simp]: + "(empty_cnode n x = None) = (length x \ n)" + by (clarsimp simp: empty_cnode_def) + + +text \Low's CSpace\ + +definition Low_caps :: cnode_contents where + "Low_caps \ + (empty_cnode 10) + ((the_nat_to_bl_10 1) + \ ThreadCap Low_tcb_ptr, + (the_nat_to_bl_10 2) + \ CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0))), + (the_nat_to_bl_10 4) + \ ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid), + (the_nat_to_bl_10 5) + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid,0))), + (the_nat_to_bl_10 6) + \ ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0))), + (the_nat_to_bl_10 318) + \ NotificationCap ntfn_ptr 0 {AllowSend})" + +definition Low_cnode :: kernel_object where + "Low_cnode \ CNode 10 Low_caps" + +lemma ran_empty_cnode[simp]: + "ran (empty_cnode C) = {NullCap}" + by (auto simp: empty_cnode_def ran_def Ex_list_of_length intro: set_eqI) + +lemma empty_cnode_app[simp]: + "length x = n \ empty_cnode n x = Some NullCap" + by (auto simp: empty_cnode_def) + +lemma in_ran_If[simp]: + "(x \ ran (\n. if P n then A n else B n)) \ + (\n. P n \ A n = Some x) \ (\n. \ P n \ B n = Some x)" + by (auto simp: ran_def) + +lemma Low_caps_ran: + "ran Low_caps = + {ThreadCap Low_tcb_ptr, + CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), + ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0))), + ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0))), + ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid,0))), + NotificationCap ntfn_ptr 0 {AllowSend}, + NullCap}" + apply (rule equalityI) + apply (clarsimp simp: Low_caps_def fun_upd_def empty_cnode_def split: if_split_asm) + apply (clarsimp simp: Low_caps_def fun_upd_def empty_cnode_def split: if_split_asm cong: conj_cong) + apply (rule exI[where x="the_nat_to_bl_10 0"]) + apply simp + done + + +text \High's Cspace\ + +definition High_caps :: cnode_contents where + "High_caps \ + (empty_cnode 10) + ((the_nat_to_bl_10 1) + \ ThreadCap High_tcb_ptr, + (the_nat_to_bl_10 2) + \ CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2), + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0))), + (the_nat_to_bl_10 4) + \ ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid), + (the_nat_to_bl_10 5) + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid,0))), + (the_nat_to_bl_10 6) + \ ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0))), + (the_nat_to_bl_10 318) + \ NotificationCap ntfn_ptr 0 {AllowRecv}) " + +definition High_cnode :: kernel_object where + "High_cnode \ CNode 10 High_caps" + +lemma High_caps_ran: + "ran High_caps = + {ThreadCap High_tcb_ptr, + CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2), + ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0))), + ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0))), + ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid,0))), + NotificationCap ntfn_ptr 0 {AllowRecv}, + NullCap}" + apply (rule equalityI) + apply (clarsimp simp: High_caps_def ran_def empty_cnode_def split: if_split_asm) + apply (clarsimp simp: High_caps_def ran_def empty_cnode_def split: if_split_asm cong: conj_cong) + apply (rule exI [where x="the_nat_to_bl_10 0"]) + apply simp + done + + +text \We need a copy of boundary crossing caps owned by SilcLabel\ + +definition Silc_caps :: cnode_contents where + "Silc_caps \ + (empty_cnode 10) + ((the_nat_to_bl_10 2) + \ CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2), + (the_nat_to_bl_10 5) + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0))), + (the_nat_to_bl_10 318) + \ NotificationCap ntfn_ptr 0 {AllowSend} )" + +definition Silc_cnode :: kernel_object where + "Silc_cnode \ CNode 10 Silc_caps" + +lemma Silc_caps_ran: + "ran Silc_caps = + {CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0))), + NotificationCap ntfn_ptr 0 {AllowSend}, + NullCap}" + apply (rule equalityI) + apply (clarsimp simp: Silc_caps_def ran_def empty_cnode_def) + apply (clarsimp simp: ran_def Silc_caps_def empty_cnode_def cong: conj_cong) + apply (rule_tac x="the_nat_to_bl_10 0" in exI) + apply simp + done + + +text \notification between Low and High\ + +definition ntfn :: kernel_object where + "ntfn \ Notification \ntfn_obj = WaitingNtfn [High_tcb_ptr], ntfn_bound_tcb=None\" + + +text \global page table is mapped into the top-level page tables of each vspace\ + +abbreviation init_global_pt' where + "init_global_pt' \ (\idx. if idx \ kernel_mapping_slots then global_pte idx else InvalidPTE)" + + +text \Low's VSpace (PageDirectory)\ + +abbreviation ppn_from_addr :: "paddr \ pte_ppn" where + "ppn_from_addr addr \ ucast (addr >> pt_bits)" + +abbreviation Low_pt' :: pt where + "Low_pt' \ + (\_. InvalidPTE) + (0 := PagePTE (ppn_from_addr shared_page_ptr_phys) {} vm_read_write)" + +definition Low_pt :: kernel_object where + "Low_pt \ ArchObj (PageTable Low_pt')" + +abbreviation Low_pd' :: pt where + "Low_pd' \ + init_global_pt' + (0 := PageTablePTE (ppn_from_addr (addrFromPPtr Low_pt_ptr)) {})" + +definition Low_pd :: kernel_object where + "Low_pd \ ArchObj (PageTable Low_pd')" + + +text \High's VSpace (PageDirectory)\ + +abbreviation High_pt' :: pt where + "High_pt' \ + (\_. InvalidPTE) + (0 := PagePTE (ppn_from_addr shared_page_ptr_phys) {} vm_read_only)" + +definition High_pt :: kernel_object where + "High_pt \ ArchObj (PageTable High_pt')" + +abbreviation High_pd' :: pt where + "High_pd' \ + init_global_pt' + (0 := PageTablePTE (ppn_from_addr (addrFromPPtr High_pt_ptr)) {})" + +definition High_pd :: kernel_object where + "High_pd \ ArchObj (PageTable High_pd')" + + +text \Low's tcb\ + +definition Low_tcb :: kernel_object where + "Low_tcb \ TCB \tcb_ctable = CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), + tcb_vtable = ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0))), + tcb_reply = ReplyCap Low_tcb_ptr True {AllowGrant, AllowWrite}, + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = Running, + tcb_fault_handler = replicate word_bits False, + tcb_ipc_buffer = 0, + tcb_fault = None, + tcb_bound_notification = None, + tcb_mcpriority = Low_mcp, + tcb_priority = Low_prio, + tcb_time_slice = Low_time_slice, + tcb_domain = Low_domain, + tcb_flags = {}, + tcb_arch = \tcb_context = undefined\\" + + +text \High's tcb\ + +definition High_tcb :: kernel_object where + "High_tcb \ TCB \tcb_ctable = CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2) , + tcb_vtable = ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0))), + tcb_reply = ReplyCap High_tcb_ptr True {AllowGrant, AllowWrite}, + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = BlockedOnNotification ntfn_ptr, + tcb_fault_handler = replicate word_bits False, + tcb_ipc_buffer = 0, + tcb_fault = None, + tcb_bound_notification = None, + tcb_mcpriority = High_mcp, + tcb_priority = High_prio, + tcb_time_slice = High_time_slice, + tcb_domain = High_domain, + tcb_flags = {}, + tcb_arch = \tcb_context = undefined\\" + + +text \idle's tcb\ + +definition idle_tcb :: kernel_object where + "idle_tcb \ TCB \tcb_ctable = NullCap, + tcb_vtable = NullCap, + tcb_reply = NullCap, + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = IdleThreadState, + tcb_fault_handler = replicate word_bits False, + tcb_ipc_buffer = 0, + tcb_fault = None, + tcb_bound_notification = None, + tcb_mcpriority = default_priority, + tcb_priority = default_priority, + tcb_time_slice = timeSlice, + tcb_domain = default_domain, + tcb_flags = {}, + tcb_arch = \tcb_context = empty_context\\" + +definition + "irq_cnode \ CNode 0 (Map.empty([] \ cap.NullCap))" + +abbreviation + "Low_pool' \ \idx. if idx = asid_low_bits_of Low_asid then Some Low_pd_ptr else None" + +definition + "Low_pool \ ArchObj (ASIDPool Low_pool')" + +abbreviation + "High_pool' \ \idx. if idx = asid_low_bits_of High_asid then Some High_pd_ptr else None" + +definition + "High_pool \ ArchObj (ASIDPool High_pool')" + +definition + "shared_page \ ArchObj (DataPage False RISCVLargePage)" + +definition kh0 :: kheap where + "kh0 \ (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some (CNode 0 (empty_cnode 0)) + else None) + (Low_cnode_ptr \ Low_cnode, + High_cnode_ptr \ High_cnode, + Low_pool_ptr \ Low_pool, + High_pool_ptr \ High_pool, + Silc_cnode_ptr \ Silc_cnode, + ntfn_ptr \ ntfn, + irq_cnode_ptr \ irq_cnode, + Low_pd_ptr \ Low_pd, + High_pd_ptr \ High_pd, + Low_pt_ptr \ Low_pt, + High_pt_ptr \ High_pt, + Low_tcb_ptr \ Low_tcb, + High_tcb_ptr \ High_tcb, + idle_tcb_ptr \ idle_tcb, + shared_page_ptr_virt \ shared_page, + arm_global_pt_ptr \ init_global_pt)" + +lemma irq_node_offs_min: + "init_irq_node_ptr \ init_irq_node_ptr + (ucast (irq :: irq) << 5)" + apply (rule_tac sz=59 in machine_word_plus_mono_right_split) + apply (simp add: unat_word_ariths mask_def shiftl_t2n s0_ptr_defs) + apply (cut_tac x=irq and 'a=64 in ucast_less) + apply simp + apply (simp add: word_less_nat_alt) + apply (simp add: word_bits_def) + done + +lemma irq_node_offs_max: + "init_irq_node_ptr + (ucast (irq:: irq) << 5) < init_irq_node_ptr + 0x7E1" + apply (simp add: s0_ptr_defs shiftl_t2n) + apply (cut_tac x=irq and 'a=64 in ucast_less) + apply simp + apply (simp add: word_less_nat_alt unat_word_ariths) + done + +definition irq_node_offs_range where + "irq_node_offs_range \ {x. init_irq_node_ptr \ x \ x < init_irq_node_ptr + 0x7E1} + \ {x. is_aligned x 5}" + +lemma irq_node_offs_in_range: + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ irq_node_offs_range" + apply (clarsimp simp: irq_node_offs_min irq_node_offs_max irq_node_offs_range_def) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (simp add: is_aligned_def s0_ptr_defs) + done + +lemma irq_node_offs_range_correct: + "x \ irq_node_offs_range + \ \irq. x = init_irq_node_ptr + (ucast (irq:: irq) << 5)" + apply (clarsimp simp: irq_node_offs_min irq_node_offs_max irq_node_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast ((x - 0xFFFFFFC000003000) >> 5)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (simp add: is_aligned_def) + apply simp + apply simp + apply (rule_tac n=11 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (simp add: diff_conv_add_uminus del: add_uminus_conv_diff) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply simp + apply (simp add: diff_conv_add_uminus del: add_uminus_conv_diff) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="0xFFFFFFC0000037E0" and n=14 in neg_mask_mono_le) + apply (force dest: word_less_sub_1) + apply (drule_tac n=11 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (simp add: mask_def is_aligned_mask) + apply word_bitwise + apply fastforce + done + +lemma irq_node_offs_range_distinct[simp]: + "Low_cnode_ptr \ irq_node_offs_range" + "High_cnode_ptr \ irq_node_offs_range" + "Low_pool_ptr \ irq_node_offs_range" + "High_pool_ptr \ irq_node_offs_range" + "Silc_cnode_ptr \ irq_node_offs_range" + "ntfn_ptr \ irq_node_offs_range" + "irq_cnode_ptr \ irq_node_offs_range" + "Low_pd_ptr \ irq_node_offs_range" + "High_pd_ptr \ irq_node_offs_range" + "Low_pt_ptr \ irq_node_offs_range" + "High_pt_ptr \ irq_node_offs_range" + "Low_tcb_ptr \ irq_node_offs_range" + "High_tcb_ptr \ irq_node_offs_range" + "idle_tcb_ptr \ irq_node_offs_range" + "arm_global_pt_ptr \ irq_node_offs_range" + "shared_page_ptr_virt \ irq_node_offs_range" + by(simp add:irq_node_offs_range_def s0_ptr_defs)+ + +lemma irq_node_offs_distinct[simp]: + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_pool_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_pool_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Silc_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ ntfn_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ irq_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_pd_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_pd_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_pt_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_pt_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_tcb_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_tcb_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ idle_tcb_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ arm_global_pt_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ shared_page_ptr_virt" + by (simp add:not_inD[symmetric, OF _ irq_node_offs_in_range])+ + +lemma kh0_dom: + "dom kh0 = {shared_page_ptr_virt, arm_global_pt_ptr, idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, + High_pt_ptr, Low_pt_ptr, High_pd_ptr, Low_pd_ptr, irq_cnode_ptr, ntfn_ptr, + Silc_cnode_ptr, High_pool_ptr, Low_pool_ptr, High_cnode_ptr, Low_cnode_ptr} + \ irq_node_offs_range" + apply (rule equalityI) + apply (simp add: kh0_def dom_def) + apply (clarsimp simp: irq_node_offs_in_range) + apply (clarsimp simp: dom_def) + apply (rule conjI, clarsimp simp: kh0_def)+ + apply (force simp: kh0_def dest: irq_node_offs_range_correct) + done + +lemmas kh0_SomeD' = set_mp[OF equalityD1[OF kh0_dom[simplified dom_def]], OF CollectI, simplified, OF exI] + +lemma kh0_SomeD: + "kh0 x = Some y \ + x = shared_page_ptr_virt \ y = shared_page \ + x = arm_global_pt_ptr \ y = init_global_pt \ + x = idle_tcb_ptr \ y = idle_tcb \ + x = High_tcb_ptr \ y = High_tcb \ + x = Low_tcb_ptr \ y = Low_tcb \ + x = High_pt_ptr \ y = High_pt \ + x = Low_pt_ptr \ y = Low_pt \ + x = High_pd_ptr \ y = High_pd \ + x = Low_pd_ptr \ y = Low_pd \ + x = irq_cnode_ptr \ y = irq_cnode \ + x = ntfn_ptr \ y = ntfn \ + x = Silc_cnode_ptr \ y = Silc_cnode \ + x = High_pool_ptr \ y = High_pool \ + x = Low_pool_ptr \ y = Low_pool \ + x = High_cnode_ptr \ y = High_cnode \ + x = Low_cnode_ptr \ y = Low_cnode \ + x \ irq_node_offs_range \ y = CNode 0 (empty_cnode 0)" + apply (frule kh0_SomeD') + apply (erule disjE, simp add: kh0_def | force simp: kh0_def split: if_split_asm)+ + done + +lemmas kh0_obj_def = + Low_cnode_def High_cnode_def Silc_cnode_def Low_pool_def High_pool_def Low_pd_def High_pd_def + Low_pt_def High_pt_def Low_tcb_def High_tcb_def idle_tcb_def irq_cnode_def ntfn_def + init_global_pt_def global_pte_def vm_kernel_only_def shared_page_def + + +definition exst0 :: "det_ext" where + "exst0 \ \work_units_completed_internal = undefined, + cdt_list_internal = const []\" + +definition machine_state0 :: "machine_state" where + "machine_state0 \ \irq_masks = (\irq. if irq = timer_irq then False else True), + irq_state = 0, + underlying_memory = const 0, + device_state = Map.empty, + machine_state_rest = undefined\" + +definition arch_state0 :: "arch_state" where + "arch_state0 \ \ + arm_asid_table = [asid_high_bits_of Low_asid \ Low_pool_ptr, + asid_high_bits_of High_asid \ High_pool_ptr], + arm_kernel_vspace = (\level. if level = max_pt_level then {arm_global_pt_ptr} else {}), + riscv_kernel_vspace = init_vspace_uses + \" + +definition s0_internal :: "det_ext state" where + "s0_internal \ \ + kheap = kh0, + cdt = Map.empty, + is_original_cap = (\_. False) ((Low_tcb_ptr, tcb_cnode_index 2) := True, + (High_tcb_ptr, tcb_cnode_index 2) := True), + cur_thread = Low_tcb_ptr, + idle_thread = idle_tcb_ptr, + scheduler_action = resume_cur_thread, + domain_list = [(0, 10), (1, 10)], + domain_index = 0, + cur_domain = 0, + domain_time = 5, + ready_queues = (const (const [])), + machine_state = machine_state0, + interrupt_irq_node = (\irq. init_irq_node_ptr + (ucast irq << 5)), + interrupt_states = (\_. irq_state.IRQInactive) (timer_irq := irq_state.IRQTimer), + arch_state = arch_state0, + exst = exst0 + \" + +lemma kh_s0_def: + "(kheap s0_internal x = Some y) = ( + x = shared_page_ptr_virt \ y = shared_page \ + x = arm_global_pt_ptr \ y = init_global_pt \ + x = idle_tcb_ptr \ y = idle_tcb \ + x = High_tcb_ptr \ y = High_tcb \ + x = Low_tcb_ptr \ y = Low_tcb \ + x = High_pt_ptr \ y = High_pt \ + x = Low_pt_ptr \ y = Low_pt \ + x = High_pd_ptr \ y = High_pd \ + x = Low_pd_ptr \ y = Low_pd \ + x = irq_cnode_ptr \ y = irq_cnode \ + x = ntfn_ptr \ y = ntfn \ + x = Silc_cnode_ptr \ y = Silc_cnode \ + x = High_pool_ptr \ y = High_pool \ + x = Low_pool_ptr \ y = Low_pool \ + x = High_cnode_ptr \ y = High_cnode \ + x = Low_cnode_ptr \ y = Low_cnode \ + x \ irq_node_offs_range \ y = CNode 0 (empty_cnode 0))" + apply (clarsimp simp: s0_internal_def kh0_def) + apply (auto simp: irq_node_offs_in_range dest: irq_node_offs_range_correct) + done + + +subsubsection \Defining the policy graph\ + +definition Sys1AgentMap :: "(auth_graph_label subject_label) agent_map" where + "Sys1AgentMap \ + \ \set the range of the shared_page to Low, default everything else to IRQ0\ + (\p. if p \ ptr_range shared_page_ptr_virt (pageBitsForSize RISCVLargePage) + then partition_label Low + else partition_label IRQ0) + (Low_cnode_ptr := partition_label Low, + High_cnode_ptr := partition_label High, + Low_pool_ptr := partition_label Low, + High_pool_ptr := partition_label High, + ntfn_ptr := partition_label High, + irq_cnode_ptr := partition_label IRQ0, + Silc_cnode_ptr := SilcLabel, + Low_pd_ptr := partition_label Low, + High_pd_ptr := partition_label High, + Low_pt_ptr := partition_label Low, + High_pt_ptr := partition_label High, + Low_tcb_ptr := partition_label Low, + High_tcb_ptr := partition_label High, + idle_tcb_ptr := partition_label Low)" + +lemma Sys1AgentMap_simps: + "Sys1AgentMap Low_cnode_ptr = partition_label Low" + "Sys1AgentMap High_cnode_ptr = partition_label High" + "Sys1AgentMap Low_pool_ptr = partition_label Low" + "Sys1AgentMap High_pool_ptr = partition_label High" + "Sys1AgentMap ntfn_ptr = partition_label High" + "Sys1AgentMap irq_cnode_ptr = partition_label IRQ0" + "Sys1AgentMap Silc_cnode_ptr = SilcLabel" + "Sys1AgentMap Low_pd_ptr = partition_label Low" + "Sys1AgentMap High_pd_ptr = partition_label High" + "Sys1AgentMap Low_pt_ptr = partition_label Low" + "Sys1AgentMap High_pt_ptr = partition_label High" + "Sys1AgentMap Low_tcb_ptr = partition_label Low" + "Sys1AgentMap High_tcb_ptr = partition_label High" + "Sys1AgentMap idle_tcb_ptr = partition_label Low" + "\p. p \ ptr_range shared_page_ptr_virt (pageBitsForSize RISCVLargePage) + \ Sys1AgentMap p = partition_label Low" + unfolding Sys1AgentMap_def + apply simp_all + by (auto simp: s0_ptr_defs ptr_range_def) + +definition Sys1ASIDMap :: "(auth_graph_label subject_label) agent_asid_map" where + "Sys1ASIDMap \ + (\x. if asid_high_bits_of x = asid_high_bits_of Low_asid + then partition_label Low + else if asid_high_bits_of x = asid_high_bits_of High_asid + then partition_label High + else if asid_high_bits_of x = asid_high_bits_of Silc_asid + then SilcLabel + else undefined)" + +(* We include 2 domains, Low is associated to domain 0, High to domain 1, + we default the rest of the possible domains to High *) + +definition Sys1PAS :: "(auth_graph_label subject_label) PAS" where + "Sys1PAS \ + \pasObjectAbs = Sys1AgentMap, + pasASIDAbs = Sys1ASIDMap, + pasIRQAbs = (\_. partition_label IRQ0), + pasPolicy = Sys1AuthGraph, + pasSubject = partition_label Low, + pasMayActivate = True, + pasMayEditReadyQueues = True, pasMaySendIrqs = False, + pasDomainAbs = ((\_. {partition_label High})(0 := {partition_label Low}))\" + + +subsubsection \Proof of pas_refined for Sys1\ + +lemma High_caps_well_formed: "well_formed_cnode_n 10 High_caps" + by (auto simp: High_caps_def well_formed_cnode_n_def split: if_split_asm) + +lemma Low_caps_well_formed: "well_formed_cnode_n 10 Low_caps" + by (auto simp: Low_caps_def well_formed_cnode_n_def split: if_split_asm) + +lemma Silc_caps_well_formed: "well_formed_cnode_n 10 Silc_caps" + by (auto simp: Silc_caps_def well_formed_cnode_n_def split: if_split_asm) + +lemma s0_caps_of_state : + "caps_of_state s0_internal p = Some cap \ + cap = NullCap \ + (p,cap) \ + { ((Low_cnode_ptr,(the_nat_to_bl_10 1)), ThreadCap Low_tcb_ptr), + ((Low_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((Low_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 4)), ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid)), + ((Low_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid, 0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowSend}), + ((High_cnode_ptr,(the_nat_to_bl_10 1)), ThreadCap High_tcb_ptr), + ((High_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((High_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 4)), ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid)), + ((High_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid, 0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowRecv}) , + ((Silc_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((Silc_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid, 0)))), + ((Silc_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowSend}), + ((Low_tcb_ptr,(tcb_cnode_index 0)), CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((Low_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0)))), + ((Low_tcb_ptr,(tcb_cnode_index 2)), ReplyCap Low_tcb_ptr True {AllowGrant, AllowWrite}), + ((Low_tcb_ptr,(tcb_cnode_index 3)), NullCap), + ((Low_tcb_ptr,(tcb_cnode_index 4)), NullCap), + ((High_tcb_ptr,(tcb_cnode_index 0)), CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((High_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0)))), + ((High_tcb_ptr,(tcb_cnode_index 2)), ReplyCap High_tcb_ptr True {AllowGrant, AllowWrite}), + ((High_tcb_ptr,(tcb_cnode_index 3)), NullCap), + ((High_tcb_ptr,(tcb_cnode_index 4)), NullCap)} " + supply if_cong[cong] + apply (insert High_caps_well_formed) + apply (insert Low_caps_well_formed) + apply (insert Silc_caps_well_formed) + apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac p, clarsimp) + apply (clarsimp split: if_splits) + apply (clarsimp simp: cte_wp_at_cases tcb_cap_cases_def split: if_split_asm)+ + apply (clarsimp simp: Silc_caps_def split: if_splits) + apply (clarsimp simp: High_caps_def split: if_splits) + apply (clarsimp simp: Low_caps_def split: if_splits) + done + +lemma tcb_states_of_state_s0: + "tcb_states_of_state s0_internal = [High_tcb_ptr \ thread_state.BlockedOnNotification ntfn_ptr, + Low_tcb_ptr \ thread_state.Running, + idle_tcb_ptr \ thread_state.IdleThreadState ]" + unfolding s0_internal_def tcb_states_of_state_def + by (auto simp: get_tcb_def kh0_def kh0_obj_def) + +lemma thread_bounds_of_state_s0: + "thread_bound_ntfns s0_internal = Map.empty" + unfolding s0_internal_def thread_bound_ntfns_def + by (auto simp: get_tcb_def kh0_def kh0_obj_def) + +lemma Sys1_wellformed': + "policy_wellformed (pasPolicy Sys1PAS) False irqs x" + by (clarsimp simp: Sys1PAS_def Sys1AgentMap_simps Sys1AuthGraph_def policy_wellformed_def) + +corollary Sys1_wellformed: + "x \ range (pasObjectAbs Sys1PAS) \ \(range (pasDomainAbs Sys1PAS)) - {SilcLabel} + \ policy_wellformed (pasPolicy Sys1PAS) False irqs x" + by (rule Sys1_wellformed') + +lemma Sys1_pas_wellformed: + "pas_wellformed Sys1PAS" + by (clarsimp simp: Sys1PAS_def Sys1AgentMap_simps Sys1AuthGraph_def policy_wellformed_def) + +lemma domains_of_state_s0[simp]: + "domains_of_state s0_internal = {(High_tcb_ptr, High_domain), + (Low_tcb_ptr, Low_domain), + (idle_tcb_ptr, default_domain)}" + apply (rule equalityI) + apply (rule subsetI) + apply clarsimp + apply (erule domains_of_state_aux.cases) + apply (clarsimp simp: s0_internal_def etcbs_of'_def kh0_def kh0_obj_def split: if_split_asm) + apply (force simp: s0_internal_def etcbs_of'_def kh0_def kh0_obj_def intro: domains_of_state_aux.domtcbs)+ + done + +lemma pool_for_asid_s0: + "pool_for_asid asid s0_internal = (if asid_high_bits_of asid = asid_high_bits_of High_asid + then Some High_pool_ptr + else if asid_high_bits_of asid = asid_high_bits_of Low_asid + then Some Low_pool_ptr + else None)" + by (clarsimp simp: pool_for_asid_def s0_internal_def arch_state0_def) + +lemma asid_pools_of_s0: + "asid_pools_of s0_internal = [Low_pool_ptr \ Low_pool', High_pool_ptr \ High_pool']" + by (auto simp: asid_pools_of_ko_at obj_at_def s0_internal_def opt_map_def kh0_def kh0_obj_def + split: option.splits) + +lemma pts_of_s0: + "pts_of s0_internal = [Low_pd_ptr \ Low_pd', + High_pd_ptr \ High_pd', + Low_pt_ptr \ Low_pt', + High_pt_ptr \ High_pt', + arm_global_pt_ptr \ init_global_pt']" + by (auto simp: opt_map_def s0_internal_def kh0_def kh0_obj_def + split: option.splits if_splits)+ + + +lemma ptes_of_s0_PageTablePTE: + "\ ptes_of s0_internal ptr = Some pte; is_PageTablePTE pte \ + \ table_base ptr = Low_pd_ptr \ pte = PageTablePTE (ppn_from_addr (addrFromPPtr Low_pt_ptr)) {} + \ table_base ptr = High_pd_ptr \ pte = PageTablePTE (ppn_from_addr (addrFromPPtr High_pt_ptr)) {}" + by (auto simp: ptes_of_def pts_of_s0 obind_def kh0_obj_def split: option.splits if_splits) + +lemma Low_pt_is_aligned[simp]: + "is_aligned Low_pt_ptr pt_bits" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma High_pt_is_aligned[simp]: + "is_aligned High_pt_ptr pt_bits" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma Low_pd_is_aligned[simp]: + "is_aligned Low_pd_ptr pt_bits" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma High_pd_is_aligned[simp]: + "is_aligned High_pd_ptr pt_bits" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma shared_page_ptr_is_aligned[simp]: + "is_aligned shared_page_ptr_virt pt_bits" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma vs_lookup_s0_SomeD: + "vs_lookup_table lvl asid vref s0_internal = Some (lvl', p) + \ (asid_high_bits_of asid = asid_high_bits_of High_asid \ lvl' = asid_pool_level \ p = High_pool_ptr + \ asid_high_bits_of asid = asid_high_bits_of Low_asid \ lvl' = asid_pool_level \ p = Low_pool_ptr + \ asid = High_asid \ lvl' = max_pt_level \ p = High_pd_ptr + \ asid = Low_asid \ lvl' = max_pt_level \ p = Low_pd_ptr + \ asid = High_asid \ lvl' = max_pt_level - 1 \ p = High_pt_ptr + \ asid = Low_asid \ lvl' = max_pt_level - 1 \ p = Low_pt_ptr)" + apply (clarsimp simp: vs_lookup_table_def obind_def split: option.splits if_splits) + apply (clarsimp simp: pool_for_asid_s0 split: if_splits) + apply (case_tac "lvl = max_pt_level") + apply (clarsimp simp: asid_pools_of_s0 pool_for_asid_s0 asid_high_low vspace_for_pool_def + split: if_splits) + apply (case_tac "lvl = max_pt_level - 1") + apply (clarsimp simp: pt_walk.simps split: if_splits) + apply (drule (1) ptes_of_s0_PageTablePTE) + apply (auto simp: pptr_from_pte_def ptrFromPAddr_addr_from_ppn' ptes_of_def asid_high_low + kh0_obj_def pts_of_s0 pool_for_asid_s0 asid_pools_of_s0 vspace_for_pool_def + split: if_splits)[2] + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp split: if_splits) + apply (drule (1) ptes_of_s0_PageTablePTE) + apply (erule disjE; clarsimp) + by (clarsimp simp: pptr_from_pte_def ptrFromPAddr_addr_from_ppn' kh0_obj_def + pt_walk.simps ptes_of_def pts_of_s0 asid_high_low + pool_for_asid_s0 asid_pools_of_s0 vspace_for_pool_def + split: if_splits)+ + +lemma pt_bits_left_max_minus_1_pageBitsForSize: + "pt_bits_left (max_pt_level - 1) = pageBitsForSize RISCVLargePage" + apply (clarsimp simp: pt_bits_left_def max_pt_level_def2) + done + +lemma Sys1_pas_refined: + "pas_refined Sys1PAS s0_internal" + apply (clarsimp simp: pas_refined_def) + apply (intro conjI) + apply (simp add: Sys1_pas_wellformed) + apply (clarsimp simp: irq_map_wellformed_aux_def s0_internal_def Sys1AgentMap_def Sys1PAS_def) + apply (clarsimp simp: s0_ptr_defs ptr_range_def) + apply word_bitwise + apply (clarsimp simp: tcb_domain_map_wellformed_aux_def minBound_word High_domain_def Low_domain_def + Sys1PAS_def Sys1AgentMap_def default_domain_def) + apply (clarsimp simp: auth_graph_map_def Sys1PAS_def state_objs_to_policy_def state_bits_to_policy_def) + apply (erule state_bits_to_policyp.cases; clarsimp) + apply (drule s0_caps_of_state, clarsimp) + apply (simp add: Sys1AuthGraph_def) + apply (elim disjE; clarsimp simp: Sys1AgentMap_simps cap_auth_conferred_def ptr_range_def + arch_cap_auth_conferred_def vspace_cap_rights_to_auth_def + vm_read_write_def vm_read_only_def cap_rights_to_auth_def) + apply (drule s0_caps_of_state, clarsimp) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: state_refs_of_def thread_st_auth_def tcb_states_of_state_s0 + Sys1AuthGraph_def Sys1AgentMap_simps split: if_splits) + apply (clarsimp simp: state_refs_of_def thread_st_auth_def thread_bounds_of_state_s0) + apply (simp add: s0_internal_def) (* this is OK because cdt is empty..*) + apply (simp add: s0_internal_def) (* this is OK because cdt is empty..*) + apply (clarsimp simp: state_vrefs_def) + apply (drule vs_lookup_s0_SomeD) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: s0_internal_def kh0_obj_def opt_map_def vs_refs_aux_def + vm_read_only_def vspace_cap_rights_to_auth_def pte_ref2_def + Sys1AuthGraph_def Sys1AgentMap_simps graph_of_def ptrFromPAddr_addr_from_ppn' + shared_page_ptr_phys_def pt_bits_left_max_minus_1_pageBitsForSize + dest!: kh0_SomeD split: option.splits if_splits)+)[6] + apply (rule subsetI, clarsimp) + apply (erule state_asids_to_policy_aux.cases) + apply (drule s0_caps_of_state, clarsimp) + apply (fastforce simp: Sys1AuthGraph_def Sys1PAS_def Sys1ASIDMap_def Sys1AgentMap_def + Low_asid_def High_asid_def Silc_asid_def + asid_low_bits_def asid_high_bits_of_def) + apply (clarsimp simp: state_vrefs_def) + apply (drule vs_lookup_s0_SomeD) + apply (clarsimp simp: vs_refs_aux_def s0_internal_def arch_state0_def kh0_def kh0_obj_def + Sys1PAS_def Sys1ASIDMap_def Sys1AgentMap_simps Sys1AuthGraph_def + opt_map_def graph_of_def split: if_splits) + apply (clarsimp simp: Sys1PAS_def Sys1ASIDMap_def Sys1AgentMap_simps Sys1AuthGraph_def + s0_internal_def arch_state0_def split: if_splits) + apply (fastforce elim: state_irqs_to_policy_aux.cases dest: s0_caps_of_state) + done + +lemma Sys1_pas_cur_domain: + "pas_cur_domain Sys1PAS s0_internal" + by (simp add: s0_internal_def exst0_def Sys1PAS_def) + +lemma Sys1_current_subject_idemp: + "Sys1PAS\pasSubject := the_elem (pasDomainAbs Sys1PAS (cur_domain s0_internal))\ = Sys1PAS" + by (simp add: Sys1PAS_def s0_internal_def exst0_def) + +lemma pasMaySendIrqs_Sys1PAS[simp]: + "pasMaySendIrqs Sys1PAS = False" + by(auto simp: Sys1PAS_def) + +lemma Sys1_pas_domains_distinct: + "pas_domains_distinct Sys1PAS" + by (clarsimp simp: Sys1PAS_def pas_domains_distinct_def) + +lemma Sys1_pas_wellformed_noninterference: + "pas_wellformed_noninterference Sys1PAS" + apply (simp add: pas_wellformed_noninterference_def) + apply (intro conjI ballI allI) + apply (blast intro: Sys1_wellformed) + apply (clarsimp simp: Sys1PAS_def policy_wellformed_def Sys1AuthGraph_def) + apply (rule Sys1_pas_domains_distinct) + done + +lemma Sys1AgentMap_shared_page_ptr: + "Sys1AgentMap shared_page_ptr_virt = partition_label Low" + by (clarsimp simp: Sys1AgentMap_def s0_ptr_defs ptr_range_def bit_simps) + +lemma silc_inv_s0: + "silc_inv Sys1PAS s0_internal s0_internal" + apply (clarsimp simp: silc_inv_def) + apply (rule conjI, simp add: Sys1PAS_def) + apply (rule conjI) + apply (clarsimp simp: Sys1PAS_def Sys1AgentMap_def s0_internal_def kh0_def obj_at_def kh0_obj_def + is_cap_table_def Silc_caps_well_formed split: if_split_asm) + apply (rule conjI) + apply (clarsimp simp: Sys1PAS_def Sys1AuthGraph_def) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Silc_cnode_ptr in exI) + apply (rule conjI) + apply (subgoal_tac "(Silc_cnode_ptr,the_nat_to_bl_10 318) \ slots_holding_overlapping_caps cap s0_internal + \ (Silc_cnode_ptr, the_nat_to_bl_10 5) \ slots_holding_overlapping_caps cap s0_internal") + apply fastforce + apply clarsimp + apply (clarsimp simp: slots_holding_overlapping_caps_def2) + apply (case_tac "cap = NullCap") + apply clarsimp + apply (simp add: cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac a, clarsimp) + apply (clarsimp split: if_splits) + apply ((clarsimp simp: intra_label_cap_def cte_wp_at_cases tcb_cap_cases_def + cap_points_to_label_def split: if_split_asm)+)[8] + apply (clarsimp simp: intra_label_cap_def cap_points_to_label_def) + apply (drule cte_wp_at_caps_of_state' s0_caps_of_state)+ + apply ((erule disjE | + clarsimp simp: Sys1PAS_def Sys1AgentMap_simps + the_nat_to_bl_def nat_to_bl_def ctes_wp_at_def cte_wp_at_cases + s0_internal_def kh0_def kh0_obj_def Silc_caps_well_formed obj_refs_def + | simp add: Silc_caps_def)+)[1] + apply (clarsimp simp: Sys1PAS_def Sys1AgentMap_def) + apply (intro conjI) + apply (clarsimp simp: all_children_def s0_internal_def silc_dom_equiv_def equiv_for_refl) + apply (clarsimp simp: all_children_def s0_internal_def silc_dom_equiv_def equiv_for_refl) + apply (clarsimp simp: Invariants_AI.cte_wp_at_caps_of_state ) + by (auto simp:is_transferable.simps dest:s0_caps_of_state) + + +lemma only_timer_irq_s0: + "only_timer_irq timer_irq s0_internal" + apply (clarsimp simp: only_timer_irq_def s0_internal_def irq_is_recurring_def is_irq_at_def + irq_at_def Let_def irq_oracle_def machine_state0_def timer_irq_def) + apply presburger + done + +lemma domain_sep_inv_s0: + "domain_sep_inv False s0_internal s0_internal" + apply (clarsimp simp: domain_sep_inv_def) + apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state + | rule conjI allI | clarsimp simp: s0_internal_def)+ + done + +lemma only_timer_irq_inv_s0: + "only_timer_irq_inv timer_irq s0_internal s0_internal" + by (simp add: only_timer_irq_inv_def only_timer_irq_s0 domain_sep_inv_s0) + +lemma Sys1_guarded_pas_domain: + "guarded_pas_domain Sys1PAS s0_internal" + by (clarsimp simp: guarded_pas_domain_def Sys1PAS_def s0_internal_def exst0_def Sys1AgentMap_simps) + +lemma s0_valid_domain_list: + "valid_domain_list s0_internal" + by (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + +definition + "s0 \ ((if ct_idle s0_internal then idle_context s0_internal else s0_context,s0_internal),KernelExit)" + + +subsubsection \einvs\ + +lemma well_formed_cnode_n_s0_caps[simp]: + "well_formed_cnode_n 10 High_caps" + "well_formed_cnode_n 10 Low_caps" + "well_formed_cnode_n 10 Silc_caps" + "\ well_formed_cnode_n 10 [[] \ NullCap]" + apply (simp add: High_caps_well_formed Low_caps_well_formed Silc_caps_well_formed)+ + apply (fastforce simp: well_formed_cnode_n_def dest: eqset_imp_iff[where x="[]"]) + done + +lemma valid_caps_s0[simp]: + "s0_internal \ ThreadCap Low_tcb_ptr" + "s0_internal \ ThreadCap High_tcb_ptr" + "s0_internal \ CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)" + "s0_internal \ CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)" + "s0_internal \ CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2)" + "s0_internal \ ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid)" + "s0_internal \ ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid)" + "s0_internal \ ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0)))" + "s0_internal \ NotificationCap ntfn_ptr 0 {AllowWrite}" + "s0_internal \ NotificationCap ntfn_ptr 0 {AllowRead}" + "s0_internal \ ReplyCap Low_tcb_ptr True {AllowGrant,AllowWrite}" + "s0_internal \ ReplyCap High_tcb_ptr True {AllowGrant,AllowWrite}" + by (auto simp: s0_internal_def s0_ptr_defs kh0_def kh0_obj_def bit_simps word_bits_def + valid_cap_def cap_aligned_def is_aligned_def obj_at_def cte_level_bits_def + is_ntfn_def is_tcb_def is_cap_table_def a_type_def the_nat_to_bl_def nat_to_bl_def + Low_asid_def High_asid_def Silc_asid_def asid_low_bits_def asid_bits_def + wellformed_mapdata_def valid_vm_rights_def vmsz_aligned_def) + +lemma valid_obj_s0[simp]: + "valid_obj Low_cnode_ptr Low_cnode s0_internal" + "valid_obj High_cnode_ptr High_cnode s0_internal" + "valid_obj High_pool_ptr High_pool s0_internal" + "valid_obj Low_pool_ptr Low_pool s0_internal" + "valid_obj Silc_cnode_ptr Silc_cnode s0_internal" + "valid_obj ntfn_ptr ntfn s0_internal" + "valid_obj irq_cnode_ptr irq_cnode s0_internal" + "valid_obj Low_pd_ptr Low_pd s0_internal" + "valid_obj High_pd_ptr High_pd s0_internal" + "valid_obj Low_pt_ptr Low_pt s0_internal" + "valid_obj High_pt_ptr High_pt s0_internal" + "valid_obj Low_tcb_ptr Low_tcb s0_internal" + "valid_obj High_tcb_ptr High_tcb s0_internal" + "valid_obj idle_tcb_ptr idle_tcb s0_internal" + "valid_obj arm_global_pt_ptr init_global_pt s0_internal" + "valid_obj shared_page_ptr_virt shared_page s0_internal" + apply (simp_all add: valid_obj_def kh0_obj_def) + apply (simp add: valid_cs_def Low_caps_ran High_caps_ran Silc_caps_ran + valid_cs_size_def word_bits_def cte_level_bits_def)+ + apply (simp add: valid_ntfn_def obj_at_def s0_internal_def kh0_def High_tcb_def is_tcb_def) + apply (simp add: valid_cs_def valid_cs_size_def word_bits_def + cte_level_bits_def well_formed_cnode_n_def) + apply (clarsimp simp: valid_tcb_def tcb_cap_cases_def valid_tcb_state_def valid_arch_tcb_def + is_valid_vtable_root_def is_master_reply_cap_def is_ntfn_def obj_at_def + wellformed_pte_def valid_vm_rights_def vm_kernel_only_def + | fastforce simp: s0_internal_def kh0_def kh0_obj_def)+ + done + +lemma valid_objs_s0: + "valid_objs s0_internal" + apply (clarsimp simp: valid_objs_def) + apply (subst (asm) s0_internal_def, clarsimp) + apply (drule kh0_SomeD) + apply (elim disjE; clarsimp) + apply (fastforce simp: valid_obj_def valid_cs_def valid_cs_size_def + cte_level_bits_def word_bits_def well_formed_cnode_n_def) + done + +lemma pspace_aligned_s0: + "pspace_aligned s0_internal" + apply (clarsimp simp: pspace_aligned_def s0_internal_def) + apply (drule kh0_SomeD) + apply (auto simp: cte_level_bits_def irq_node_offs_range_def + is_aligned_def s0_ptr_defs kh0_obj_def bit_simps) + done + +lemma pspace_distinct_s0: + "pspace_distinct s0_internal" + apply (clarsimp simp: pspace_distinct_def s0_internal_def) + apply (drule kh0_SomeD)+ + apply (case_tac "x \ irq_node_offs_range \ y \ irq_node_offs_range") + apply clarsimp + apply (drule irq_node_offs_range_correct)+ + apply clarsimp + apply (clarsimp simp: s0_ptr_defs cte_level_bits_def) + apply word_bitwise + apply auto[1] + apply (elim disjE) + (* slow *) + by (simp | clarsimp simp: kh0_obj_def cte_level_bits_def s0_ptr_defs pte_bits_def bit_simps + | fastforce + | clarsimp simp: irq_node_offs_range_def s0_ptr_defs, + drule_tac x="0x1F" in word_plus_strict_mono_right, simp, simp add: add.commute, + drule(1) notE[rotated, OF less_trans, OF _ _ leD, rotated 2] + | drule(1) notE[rotated, OF le_less_trans, OF _ _ leD, rotated 2], simp, assumption)+ + +lemma valid_pspace_s0[simp]: + "valid_pspace s0_internal" + apply (simp add: valid_pspace_def pspace_distinct_s0 pspace_aligned_s0 valid_objs_s0) + apply (rule conjI) + apply (clarsimp simp: if_live_then_nonz_cap_def) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: ex_nonz_cap_to_def live_def arch_tcb_live_def + hyp_live_def obj_at_def kh0_def kh0_obj_def + split: if_splits) + apply (rule_tac x="High_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 1" in exI) + apply (force simp: s0_internal_def kh0_def kh0_obj_def High_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (rule_tac x="Low_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 1" in exI) + apply (force simp: s0_internal_def kh0_def kh0_obj_def Low_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (rule_tac x="High_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 318" in exI) + apply (force simp: s0_internal_def kh0_def kh0_obj_def High_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (intro conjI) + apply (force dest: s0_caps_of_state simp: cte_wp_at_caps_of_state zombies_final_def is_zombie_def) + apply (clarsimp simp: sym_refs_def state_refs_of_def state_hyp_refs_of_def + refs_of_def s0_internal_def kh0_def kh0_obj_def) + apply (clarsimp simp: sym_refs_def state_hyp_refs_of_def s0_internal_def kh0_def) + done + +lemma descendants_s0[simp]: + "descendants_of (a, b) (cdt s0_internal) = {}" + apply (rule set_eqI) + apply clarsimp + apply (drule descendants_of_NoneD[rotated]) + apply (simp add: s0_internal_def)+ + done + +lemma valid_mdb_s0[simp]: + "valid_mdb s0_internal" + apply (simp add: valid_mdb_def reply_mdb_def) + apply (intro conjI) + apply (clarsimp simp: mdb_cte_at_def s0_internal_def) + apply (force dest: s0_caps_of_state simp: untyped_mdb_def) + apply (clarsimp simp: descendants_inc_def) + apply (clarsimp simp: no_mloop_def s0_internal_def cdt_parent_defs) + apply (clarsimp simp: untyped_inc_def) + apply (drule s0_caps_of_state)+ + apply ((simp | erule disjE)+)[1] + apply (force dest: s0_caps_of_state simp: ut_revocable_def) + apply (force dest: s0_caps_of_state simp: irq_revocable_def) + apply (clarsimp simp: reply_master_revocable_def) + apply (drule s0_caps_of_state) + apply ((simp add: is_master_reply_cap_def s0_internal_def s0_ptr_defs | erule disjE)+)[1] + apply (force dest: s0_caps_of_state simp: reply_caps_mdb_def) + apply (clarsimp simp: reply_masters_mdb_def) + apply (simp add: s0_internal_def) + apply (clarsimp simp: valid_arch_mdb_def) + done + +lemma valid_ioc_s0[simp]: + "valid_ioc s0_internal" + by (clarsimp simp: cte_wp_at_cases valid_ioc_def s0_internal_def kh0_def kh0_obj_def) + +lemma valid_idle_s0[simp]: + "valid_idle s0_internal" + by (clarsimp simp: valid_idle_def valid_arch_idle_def pred_tcb_at_def obj_at_def + idle_thread_ptr_def idle_tcb_def kh0_def s0_ptr_defs s0_internal_def) + +lemma only_idle_s0[simp]: + "only_idle s0_internal" + apply (clarsimp simp: only_idle_def st_tcb_at_tcb_states_of_state_eq + identity_eq[symmetric] tcb_states_of_state_s0) + apply (simp add: s0_ptr_defs s0_internal_def) + done + +lemma if_unsafe_then_cap_s0[simp]: + "if_unsafe_then_cap s0_internal" + apply (clarsimp simp: if_unsafe_then_cap_def ex_cte_cap_wp_to_def) + apply (drule s0_caps_of_state) + apply (case_tac "a=Low_cnode_ptr") + apply (rule_tac x=Low_tcb_ptr in exI, rule_tac x="tcb_cnode_index 0" in exI) + apply (fastforce simp: cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac "a=High_cnode_ptr") + apply (rule_tac x=High_tcb_ptr in exI, rule_tac x="tcb_cnode_index 0" in exI) + apply (fastforce simp: cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac "a=Low_tcb_ptr") + apply (rule_tac x=Low_cnode_ptr in exI, rule_tac x="the_nat_to_bl_10 1" in exI) + apply (fastforce simp: s0_internal_def kh0_def kh0_obj_def Low_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (case_tac "a=High_tcb_ptr") + apply (rule_tac x=High_cnode_ptr in exI, rule_tac x="the_nat_to_bl_10 1" in exI) + apply (fastforce simp: s0_internal_def kh0_def kh0_obj_def High_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (rule_tac x=Silc_cnode_ptr in exI, rule_tac x="the_nat_to_bl_10 2" in exI) + apply (fastforce simp: s0_internal_def kh0_def kh0_obj_def Silc_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + done + +lemma valid_reply_caps_s0[simp]: + "valid_reply_caps s0_internal" + apply (clarsimp simp: valid_reply_caps_def) + apply (rule conjI) + apply (force dest: s0_caps_of_state + simp: cte_wp_at_caps_of_state has_reply_cap_def is_reply_cap_to_def) + apply (clarsimp simp: unique_reply_caps_def) + apply (drule s0_caps_of_state)+ + apply (erule disjE | simp add: is_reply_cap_def)+ + done + +lemma valid_reply_masters_s0[simp]: + "valid_reply_masters s0_internal" + apply (clarsimp simp: valid_reply_masters_def) + apply (force dest: s0_caps_of_state simp: cte_wp_at_caps_of_state is_master_reply_cap_to_def) + done + +lemma valid_global_refs_s0[simp]: + "valid_global_refs s0_internal" + apply (clarsimp simp: valid_global_refs_def valid_refs_def cte_wp_at_caps_of_state) + apply (drule s0_caps_of_state) + apply (clarsimp simp: global_refs_def s0_internal_def arch_state0_def) + apply (erule disjE | simp add: cap_range_def + | clarsimp simp: irq_node_offs_distinct[symmetric] + | simp only: s0_ptr_defs, force)+ + done + +lemma valid_arch_state_s0[simp]: + "valid_arch_state s0_internal" + apply (clarsimp simp: valid_arch_state_def s0_internal_def arch_state0_def) + apply (intro conjI) + apply (auto simp: valid_asid_table_def kh0_def kh0_obj_def opt_map_def split: option.splits)[1] + apply (fastforce simp: valid_global_arch_objs_def obj_at_def kh0_def a_type_def + init_global_pt_def max_pt_level_not_asid_pool_level[symmetric]) + apply (clarsimp simp: valid_global_tables_def pt_walk.simps obind_def) + apply (fastforce dest: pt_walk_max_level + simp: obind_def opt_map_def asid_pool_level_eq geq_max_pt_level pte_of_def kh0_def + kh0_obj_def pte_rights_of_def + split: if_splits) + done + +lemma valid_irq_node_s0[simp]: + "valid_irq_node s0_internal" + apply (clarsimp simp: valid_irq_node_def) + apply (rule conjI) + apply (simp add: s0_internal_def) + apply (rule injI) + apply simp + apply (rule ccontr) + apply (rule_tac bnd="0x40" and 'a=64 in shift_distinct_helper[rotated 3]) + apply assumption + apply simp + apply simp + apply (rule ucast_less[where 'b=6, simplified]) + apply simp + apply (rule ucast_less[where 'b=6, simplified]) + apply simp + apply (rule notI) + apply (drule ucast_up_inj) + apply simp + apply simp + apply (clarsimp simp: obj_at_def s0_internal_def) + apply (force simp: kh0_def is_cap_table_def well_formed_cnode_n_def dom_empty_cnode) + done + +lemma valid_irq_handlers_s0[simp]: + "valid_irq_handlers s0_internal" + apply (clarsimp simp: valid_irq_handlers_def ran_def) + apply (force dest: s0_caps_of_state) + done + +lemma valid_irq_state_s0[simp]: + "valid_irq_states s0_internal" + by (clarsimp simp: valid_irq_states_def valid_irq_masks_def s0_internal_def machine_state0_def) + +lemma valid_machine_state_s0[simp]: + "valid_machine_state s0_internal" + by (clarsimp simp: valid_machine_state_def s0_internal_def const_def + machine_state0_def in_user_frame_def obj_at_def) + +lemma valid_arch_objs_s0[simp]: + "valid_vspace_objs s0_internal" + apply (clarsimp simp: valid_vspace_objs_def obj_at_def) + apply (drule vs_lookup_s0_SomeD) + apply (auto simp: aobjs_of_Some kh_s0_def kh0_obj_def data_at_def obj_at_def + ptrFromPAddr_addr_from_ppn' vmpage_size_of_level_def max_pt_level_def2 + shared_page_ptr_phys_def) + done + +lemma valid_vs_lookup_s0_internal: + "valid_vs_lookup s0_internal" + supply pt_simps = pt_slot_offset_def pt_bits_left_def pt_index_def max_pt_level_def2 + supply user_region_simps = user_region_def canonical_user_def + supply caps_of_state_simps = caps_of_state_def get_cap_def gets_def get_def get_object_def + assert_def assert_opt_def fail_def return_def bind_def + apply (clarsimp simp: valid_vs_lookup_def vs_lookup_target_def vs_lookup_slot_def split: if_splits) + \ \asid pool level\ + apply (drule vs_lookup_level) + apply (clarsimp simp: pool_for_asid_vs_lookup pool_for_asid_s0 asid_pools_of_s0 + vspace_for_pool_def user_region_def vref_for_level_asid_pool + dest!: asid_high_low split: if_splits) + \ \High asid\ + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (rule_tac x=High_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 3)" in exI) + apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_def get_cap_def get_object_def + gets_def get_def assert_def assert_opt_def fail_def return_def bind_def + s0_internal_def kh0_def well_formed_cnode_n_def) + \ \Low asid\ + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 3)" in exI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_def get_cap_def get_object_def + gets_def get_def assert_def assert_opt_def fail_def return_def bind_def + s0_internal_def kh0_def well_formed_cnode_n_def) + \ \below asid pool level\ + apply (clarsimp simp: vs_lookup_table_def split: if_splits) + apply (clarsimp simp: pt_walk.simps) + apply (case_tac "bot_level < max_pt_level"; clarsimp) + + prefer 2 + \ \bot level = max pt level\ + + apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 + dest!: asid_high_low split: if_splits) + \ \High asid\ + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (rule_tac x=High_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 6)" in exI) + apply (rule_tac x="ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0)))" in exI) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: in_omonad ptes_of_def High_pd_def ptrFromPAddr_addr_from_ppn' + dest!: kh0_SomeD split: if_splits) + apply (intro conjI) + apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (word_bitwise, fastforce) + apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + \ \Low asid\ + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 6)" in exI) + apply (rule_tac x="ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0)))" in exI) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: in_omonad ptes_of_def Low_pd_def ptrFromPAddr_addr_from_ppn' + dest!: kh0_SomeD split: if_splits) + apply (intro conjI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (word_bitwise, fastforce) + apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + \ \bot level < max pt level\ + apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 + dest!: asid_high_low split: if_splits) + \ \High asid\ + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def ptrFromPAddr_addr_from_ppn' + split: if_splits) + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level High_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, High_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def ptrFromPAddr_addr_from_ppn' + split: if_splits) + apply (rule_tac x=High_cnode_ptr in exI) + apply (rule_tac x="the_nat_to_bl_10 5" in exI) + apply (rule exI, intro conjI) + apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply clarsimp + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (word_bitwise, fastforce) + \ \Low asid\ + prefer 2 + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def ptrFromPAddr_addr_from_ppn' + split: if_splits) + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level Low_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, Low_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def ptrFromPAddr_addr_from_ppn' + split: if_splits) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="the_nat_to_bl_10 5" in exI) + apply (rule exI, intro conjI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply clarsimp + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (word_bitwise, fastforce) + \ \No lookups to other ptes\ + apply (clarsimp simp: in_omonad ptes_of_def pts_of_s0 split: if_splits) + apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + apply (clarsimp simp: in_omonad ptes_of_def pts_of_s0 split: if_splits) + apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) + apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + done + +lemma valid_arch_caps_s0[simp]: + "valid_arch_caps s0_internal" + supply if_split[split del] + supply caps_of_state_simps = caps_of_state_def get_cap_def gets_def get_def get_object_def + assert_def assert_opt_def fail_def return_def bind_def + apply (clarsimp simp: valid_arch_caps_def) + apply (intro conjI) + apply (simp add: valid_vs_lookup_s0_internal) + apply (clarsimp simp: valid_asid_pool_caps_def s0_internal_def arch_state0_def) + apply (clarsimp split: if_splits) + apply (rule_tac x="High_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 4" in exI) + apply (force simp: caps_of_state_simps well_formed_cnode_n_def s0_internal_def kh0_obj_def + kh0_def High_caps_def High_asid_def asid_high_bits_of_def asid_low_bits_def + split: if_splits) + apply (rule_tac x="Low_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 4" in exI) + apply (force simp: caps_of_state_simps well_formed_cnode_n_def s0_internal_def kh0_obj_def + kh0_def Low_caps_def Low_asid_def asid_high_bits_of_def asid_low_bits_def + split: if_splits) + apply (clarsimp simp: valid_table_caps_def) + apply (fastforce simp: caps_of_state_simps pts_of_s0 s0_internal_def kh0_obj_def + tcb_cnode_map_def Silc_caps_def High_caps_def Low_caps_def + dest!: kh0_SomeD split: if_splits kernel_object.splits option.splits) + apply (clarsimp simp: unique_table_caps_def) + apply (clarsimp simp: caps_of_state_simps split: if_splits kernel_object.splits option.splits) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: kh0_def kh0_obj_def Silc_caps_def High_caps_def Low_caps_def + split: if_splits) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: kh0_def kh0_obj_def Silc_caps_def High_caps_def Low_caps_def + split: if_splits) + apply (clarsimp simp: s0_internal_def kh0_def kh0_obj_def split: if_splits; + clarsimp simp: tcb_cnode_map_def split: if_splits) + apply (clarsimp simp: s0_internal_def kh0_def kh0_obj_def split: if_splits; + clarsimp simp: tcb_cnode_map_def split: if_splits) + apply (clarsimp simp: unique_table_refs_def) + apply (drule s0_caps_of_state)+ + apply clarsimp + apply (elim disjE; clarsimp) + done + +lemma valid_global_objs_s0[simp]: + "valid_global_objs s0_internal" + by (clarsimp simp: valid_global_objs_def s0_internal_def arch_state0_def) + +lemma valid_kernel_mappings_s0[simp]: + "valid_kernel_mappings s0_internal" + by (clarsimp simp: valid_kernel_mappings_def s0_internal_def ran_def + split: kernel_object.splits arch_kernel_obj.splits) + +lemma equal_kernel_mappings_s0[simp]: + "equal_kernel_mappings s0_internal" + supply misc = vref_for_level_def pt_bits_left_def asid_pool_level_size + pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 + apply (clarsimp simp: equal_kernel_mappings_def obj_at_def vspace_for_asid_def + vspace_for_pool_def pool_for_asid_s0 asid_pools_of_s0) + apply (clarsimp simp: obind_def pts_of_s0) + apply (clarsimp simp: has_kernel_mappings_def split: if_splits) + apply (rule conjI; clarsimp) + apply (clarsimp simp: kernel_mapping_slots_def s0_ptr_defs misc) + apply (fastforce simp: pts_of_s0 s0_internal_def arch_state0_def + kh0_obj_def opt_map_def riscv_global_pt_def + dest!: kh0_SomeD split: if_splits option.splits) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: s0_internal_def riscv_global_pt_def arch_state0_def kh0_obj_def + kernel_mapping_slots_def s0_ptr_defs misc elf_index_value)+ + done + +lemma valid_asid_map_s0[simp]: + "valid_asid_map s0_internal" + by (clarsimp simp: valid_asid_map_def s0_internal_def arch_state0_def) + +lemma valid_global_pd_mappings_s0_helper: + "\ pptr_base \ vref; vref < pptr_base + (1 << kernel_window_bits) \ + \ \a b. pt_lookup_target 0 arm_global_pt_ptr vref (ptes_of s0_internal) = Some (a, b) \ + is_aligned b (pt_bits_left a) \ + addrFromPPtr b + (vref && mask (pt_bits_left a)) = addrFromPPtr vref" + supply misc = vref_for_level_def pt_bits_left_def asid_pool_level_size + pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 + apply (clarsimp simp: pt_lookup_target_def obind_def split: option.splits) + apply (prop_tac "pt_lookup_slot_from_level max_pt_level 0 arm_global_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level, pt_slot_offset max_pt_level arm_global_pt_ptr vref)") + apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) + apply (fastforce simp: ptes_of_def in_omonad s0_internal_def kh0_def init_global_pt_def + global_pte_def is_aligned_pt_slot_offset_pte) + apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) + apply (rule conjI; clarsimp dest!: pt_walk_max_level simp: max_pt_level_def2 split: if_splits) + apply (rule conjI; clarsimp) + apply (clarsimp simp: ptes_of_def pts_of_s0 global_pte_def kernel_window_bits_def + table_index_offset_pt_bits_left is_aligned_pt_slot_offset_pte + split: if_splits) + apply (clarsimp simp: misc s0_ptr_defs) + apply (word_bitwise, fastforce) + apply (clarsimp simp: misc s0_ptr_defs kernel_mapping_slots_def) + apply (word_bitwise, fastforce) + apply (clarsimp simp: ptes_of_def pts_of_s0 is_aligned_pt_slot_offset_pte global_pte_def + split: if_splits) + apply (clarsimp simp: addr_from_ppn_def ptrFromPAddr_def addrFromPPtr_def bit_simps + mask_def s0_ptr_defs pt_bits_left_def max_pt_level_def2 + pptrBaseOffset_def paddrBase_def is_aligned_def kernel_window_bits_def) + apply (word_bitwise, fastforce) + apply (clarsimp simp: addr_from_ppn_def ptrFromPAddr_def addrFromPPtr_def bit_simps is_aligned_def + s0_ptr_defs pt_bits_left_def max_pt_level_def2 kernel_mapping_slots_def + mask_def pt_slot_offset_def pt_index_def pptrBaseOffset_def paddrBase_def + toplevel_bits_value elf_index_value kernel_window_bits_def) + apply (word_bitwise, fastforce) + done + +lemma ptes_of_elf_window: + "\kernel_elf_base \ vref; vref < kernel_elf_base + 2 ^ pageBits\ + \ ptes_of s0_internal (pt_slot_offset max_pt_level arm_global_pt_ptr vref) + = Some (global_pte elf_index)" + unfolding ptes_of_def pts_of_s0 + apply (clarsimp simp: obind_def elf_window_4k is_aligned_pt_slot_offset_pte) + done + +lemma valid_global_pd_mappings_s0_helper': + "\ kernel_elf_base \ vref; vref < kernel_elf_base + (1 << pageBits) \ + \ \a b. pt_lookup_target 0 arm_global_pt_ptr vref (ptes_of s0_internal) = Some (a, b) \ + is_aligned b (pt_bits_left a) \ + addrFromPPtr b + (vref && mask (pt_bits_left a)) = addrFromKPPtr vref" + supply misc = vref_for_level_def pt_bits_left_def asid_pool_level_size + pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 + apply (clarsimp simp: pt_lookup_target_def obind_def split: option.splits) + apply (prop_tac "pt_lookup_slot_from_level max_pt_level 0 arm_global_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level, pt_slot_offset max_pt_level arm_global_pt_ptr vref)") + apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) + apply (fastforce simp: ptes_of_def in_omonad s0_internal_def kh0_def init_global_pt_def + global_pte_def is_aligned_pt_slot_offset_pte) + apply (rule conjI; clarsimp) + apply (rule conjI; clarsimp) + apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) + apply (rule conjI; clarsimp) + apply (clarsimp simp: ptes_of_elf_window global_pte_def split: if_splits) + apply (clarsimp simp: ptes_of_elf_window global_pte_def elf_index_value) + apply (clarsimp simp: is_aligned_ptrFromPAddr_kernelELFPAddrBase kernelELFPAddrBase_addrFromKPPtr) + done + +lemma valid_global_pd_mappings_s0[simp]: + "valid_global_vspace_mappings s0_internal" + unfolding valid_global_vspace_mappings_def Let_def + apply (intro conjI) + apply (simp add: s0_internal_def arch_state0_def riscv_global_pt_def) + apply (fastforce simp: s0_internal_def arch_state0_def in_omonad kernel_window_def + init_vspace_uses_def translate_address_def riscv_global_pt_def + dest!: valid_global_pd_mappings_s0_helper split: if_splits) + apply (fastforce simp: translate_address_def in_omonad s0_internal_def arch_state0_def + riscv_global_pt_def kernel_elf_window_def init_vspace_uses_def + dest!: valid_global_pd_mappings_s0_helper' split: if_splits) + done + +lemma pspace_in_kernel_window_s0[simp]: + "pspace_in_kernel_window s0_internal" + apply (clarsimp simp: pspace_in_kernel_window_def kernel_window_def + init_vspace_uses_def s0_internal_def arch_state0_def) + apply (subgoal_tac "x \ {pptr_base.. obj_refs cap = {}") + apply (fastforce dest: s0_caps_of_state) + apply (rule Int_emptyI, clarsimp) + apply (erule swap, clarsimp) + apply (drule s0_caps_of_state) + apply (clarsimp simp: kernel_window_def init_vspace_uses_def s0_internal_def arch_state0_def) + apply (subgoal_tac "x \ {pptr_base..Haskell state\ + +text \One invariant we need on s0 is that there exists + an associated Haskell state satisfying the invariants. + This does not yet exist.\ + +lemma Sys1_valid_initial_state_noenabled: + assumes extras_s0: "step_restrict s0" + assumes utf_det: "\pl pr pxn tc ms s. det_inv InUserMode tc s \ einvs s \ + context_matches_state pl pr pxn ms s \ ct_running s + \ (\x. utf (cur_thread s) pl pr pxn (tc, ms) = {x})" + assumes utf_non_empty: "\t pl pr pxn tc ms. utf t pl pr pxn (tc, ms) \ {}" + assumes utf_non_interrupt: "\t pl pr pxn tc ms e f g. (e,f,g) \ utf t pl pr pxn (tc, ms) + \ e \ Some Interrupt" + assumes det_inv_invariant: "invariant_over_ADT_if det_inv utf" + assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" + shows "valid_initial_state_noenabled det_inv utf s0_internal Sys1PAS timer_irq s0_context" + apply (unfold_locales, simp_all only: pasMaySendIrqs_Sys1PAS) + apply (insert det_inv_invariant)[9] + apply (erule(2) invariant_over_ADT_if.det_inv_abs_state) + apply ((erule invariant_over_ADT_if.det_inv_abs_state + invariant_over_ADT_if.check_active_irq_if_Idle_det_inv + invariant_over_ADT_if.check_active_irq_if_User_det_inv + invariant_over_ADT_if.do_user_op_if_det_inv + invariant_over_ADT_if.handle_preemption_if_det_inv + invariant_over_ADT_if.kernel_entry_if_Interrupt_det_inv + invariant_over_ADT_if.kernel_entry_if_det_inv + invariant_over_ADT_if.kernel_exit_if_det_inv + invariant_over_ADT_if.schedule_if_det_inv)+)[8] + apply (rule Sys1_pas_cur_domain) + apply (rule Sys1_pas_wellformed_noninterference) + apply (simp only: einvs_s0) + apply (simp add: Sys1_current_subject_idemp) + apply (simp add: only_timer_irq_inv_s0 silc_inv_s0 Sys1_pas_cur_domain + domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain + idle_equiv_refl) + apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + apply (simp add: det_inv_s0) + apply (simp add: s0_internal_def exst0_def) + apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq + identity_eq[symmetric] tcb_states_of_state_s0) + apply (simp add: s0_ptr_defs s0_internal_def) + apply (simp add: s0_internal_def exst0_def) + apply (rule utf_det) + apply (rule utf_non_empty) + apply (rule utf_non_interrupt) + apply (simp add: extras_s0[simplified s0_def]) + done + +text \the extra assumptions in valid_initial_state of being enabled, + and a serial system, follow from ADT_IF_Refine\ + +end + +end diff --git a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy new file mode 100644 index 0000000000..3fd515bd2c --- /dev/null +++ b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy @@ -0,0 +1,398 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchADT_IF_Refine +imports ADT_IF_Refine +begin + +context Arch begin global_naming RISCV64 + +named_theorems ADT_IF_Refine_assms + +defs arch_extras_def: + "arch_extras \ \s. True" + +declare arch_extras_def[simp] + +lemma kernelEntry_invs'[ADT_IF_Refine_assms, wp]: + "\invs' and (\s. e \ Interrupt \ ct_running' s) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and arch_extras\ + kernelEntry_if e tc + \\_. invs'\" + apply (simp add: kernelEntry_if_def) + apply (wp threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp + | wp (once) hoare_drop_imps + | clarsimp)+ + done + +lemma kernelEntry_arch_extras[ADT_IF_Refine_assms, wp]: + "\invs' and (\s. e \ Interrupt \ ct_running' s) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and arch_extras\ + kernelEntry_if e tc + \\_. arch_extras\" + apply (simp add: kernelEntry_if_def) + apply (wp threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp + | wp (once) hoare_drop_imps + | clarsimp)+ + done + +crunch threadSet + for arch_extras[ADT_IF_Refine_assms, wp]: "arch_extras" + +lemma arch_tcb_context_set_tcb_relation[ADT_IF_Refine_assms]: + "tcb_relation tcb tcb' + \ tcb_relation (tcb\tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\) + (tcbArch_update (atcbContextSet tc) tcb')" + by (simp add: tcb_relation_def arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) + +lemma arch_tcb_context_get_atcbContextGet[ADT_IF_Refine_assms]: + "tcb_relation tcb tcb' + \ (arch_tcb_context_get \ tcb_arch) tcb = (atcbContextGet \ tcbArch) tcb'" + by (simp add: tcb_relation_def arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) + +definition + "ptable_attrs_s' s \ ptable_attrs (ksCurThread s) (absKState s)" + +definition + "ptable_xn_s' s \ \addr. Execute \ ptable_attrs_s' s addr" + +definition doUserOp_if :: + "user_transition_if \ user_context \ (event option \ user_context) kernel" where + "doUserOp_if uop tc \ + do pr \ gets ptable_rights_s'; + pxn \ gets (\s x. pr x \ {} \ ptable_xn_s' s x); + pl \ gets (\s. ptable_lift_s' s |` {x. pr x \ {}}); + allow_read \ return {y. \x. pl x = Some y \ AllowRead \ pr x}; + allow_write \ return {y. \x. pl x = Some y \ AllowWrite \ pr x}; + t \ getCurThread; + um \ gets (\s. (user_mem' s \ ptrFromPAddr)); + dm \ gets (\s. (device_mem' s \ ptrFromPAddr)); + ds \ gets (device_state \ ksMachineState); + assert (dom (um \ addrFromPPtr) \ - dom ds); + assert (dom (dm \ addrFromPPtr) \ dom ds); + u \ + return + (uop t pl pr pxn + (tc, um |` allow_read, + (ds \ ptrFromPAddr) |` allow_read)); + assert (u \ {}); + (e, tc', um',ds') \ select u; + doMachineOp + (user_memory_update + ((um' |` allow_write \ addrFromPPtr) |` (- (dom ds)))); + doMachineOp + (device_memory_update + ((ds' |` allow_write \ addrFromPPtr) |` dom ds)); + return (e, tc') + od" + +lemma ptable_attrs_abs_state[simp]: + "ptable_attrs thread (abs_state s) = ptable_attrs thread s" + by (simp add: ptable_attrs_def abs_state_def) + +lemma doUserOp_if_empty_fail[ADT_IF_Refine_assms]: + "empty_fail (doUserOp_if uop tc)" + apply (simp add: doUserOp_if_def) + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (subst bind_assoc[symmetric]) + apply (rule empty_fail_bind) + apply (rule empty_fail_select_bind) + apply (wp | wpc)+ + done + +lemma do_user_op_if_corres[ADT_IF_Refine_assms]: + "corres (=) (einvs and ct_running and (\_. \t pl pr pxn tcu. f t pl pr pxn tcu \ {})) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running') + (do_user_op_if f tc) (doUserOp_if f tc)" + apply (rule corres_gen_asm) + apply (simp add: do_user_op_if_def doUserOp_if_def) + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_rights_s_def ptable_rights_s'_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_attrs_s'_def ptable_attrs_s_def ptable_xn_s'_def ptable_xn_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: absArchState_correct curthread_relation ptable_lift_s'_def + ptable_lift_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (simp add: getCurThread_def) + apply (rule corres_gets_same) + apply (simp add: curthread_relation) + apply simp + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ - device_region s"]) + apply (clarsimp simp add: user_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply fastforce + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ device_region s"]) + apply (clarsimp simp add: device_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply fastforce + apply (rule corres_gets_same[where R ="\r s. dom r = device_region s"]) + apply (clarsimp simp: state_relation_def) + apply simp + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="(=)"]) + apply (clarsimp simp: select_def corres_underlying_def) + apply clarsimp + apply (rule corres_split[OF corres_machine_op,where r'="(=)"]) + apply (rule corres_underlying_trivial) + apply (clarsimp simp: user_memory_update_def) + apply (rule no_fail_modify) + apply (rule corres_split[OF corres_machine_op,where r'="(=)"]) + apply (rule corres_underlying_trivial) + apply wp + apply (rule corres_trivial, clarsimp) + apply (wp hoare_TrueI[where P = \] | simp)+ + done + +lemma doUserOp_if_invs'[ADT_IF_Refine_assms, wp]: + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and ex_abs (einvs)\ + doUserOp_if f tc + \\_. invs'\" + apply (simp add: doUserOp_if_def split_def ex_abs_def) + apply (wp device_update_invs' dmo_invs' | simp)+ + apply (clarsimp simp add: no_irq_modify user_memory_update_def) + apply wpsimp + apply wp+ + apply (clarsimp simp: user_memory_update_def simpler_modify_def + restrict_map_def + split: option.splits) + apply (auto dest: ptable_rights_imp_UserData[rotated 2] + simp: ptable_rights_s'_def ptable_lift_s'_def) + done + +lemma doUserOp_valid_duplicates[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \arch_extras\" + apply (simp add: doUserOp_if_def split_def) + apply (wp dmo_invs' | simp)+ + done + +lemma doUserOp_if_schedact[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \\s. P (ksSchedulerAction s)\" + apply (simp add: doUserOp_if_def) + apply (wp | wpc | simp)+ + done + +lemma doUserOp_if_st_tcb_at[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \st_tcb_at' st t\" + apply (simp add: doUserOp_if_def) + apply (wp | wpc | simp)+ + done + +lemma doUserOp_if_cur_thread[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \\s. P (ksCurThread s)\" + apply (simp add: doUserOp_if_def) + apply (wp | wpc | simp)+ + done + +lemma do_user_op_if_corres'[ADT_IF_Refine_assms]: + "corres_underlying state_relation nf False (=) (einvs and ct_running) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running') + (do_user_op_if f tc) (doUserOp_if f tc)" + apply (simp add: do_user_op_if_def doUserOp_if_def) + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_rights_s_def ptable_rights_s'_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_attrs_s'_def ptable_attrs_s_def ptable_xn_s'_def ptable_xn_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: absArchState_correct curthread_relation ptable_lift_s'_def + ptable_lift_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (simp add: getCurThread_def) + apply (rule corres_gets_same) + apply (simp add: curthread_relation) + apply simp + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ - device_region s"]) + apply (clarsimp simp add: user_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply fastforce + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ device_region s"]) + apply (clarsimp simp add: device_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def dom_def) + apply (rule corres_gets_same[where R ="\r s. dom r = device_region s"]) + apply (clarsimp simp: state_relation_def) + apply simp + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="dc"]) + apply (rule corres_assert') + apply simp + apply (rule corres_split[where r'="(=)"]) + apply (clarsimp simp: select_def corres_underlying_def) + apply clarsimp + apply (rule corres_split[OF corres_machine_op',where r'="(=)"]) + apply (rule corres_underlying_trivial, clarsimp) + apply (rule corres_split[OF corres_machine_op', where r'="(=)"]) + apply (rule corres_underlying_trivial, clarsimp) + apply (rule corres_trivial, clarsimp) + apply (wp hoare_TrueI[where P = \] | simp)+ + apply force + apply force + done + +lemma getActiveIRQ_nf: + "no_fail (\_. True) (getActiveIRQ in_kernel)" + apply (simp add: getActiveIRQ_def) + apply (rule no_fail_pre) + apply (rule no_fail_gets no_fail_modify + no_fail_return | rule no_fail_bind | simp + | intro impI conjI)+ + apply (wp del: no_irq | simp)+ + done + +lemma dmo_getActiveIRQ_corres[ADT_IF_Refine_assms]: + "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel'))" + apply (rule SubMonad_R.corres_machine_op) + apply (rule corres_Id) + apply (simp add: getActiveIRQ_def non_kernel_IRQs_def) + apply simp + apply (rule getActiveIRQ_nf) + done + +lemma dmo'_getActiveIRQ_wp[ADT_IF_Refine_assms]: + "\\s. P (irq_at (irq_state (ksMachineState s) + 1) (irq_masks (ksMachineState s))) + (s\ksMachineState := (ksMachineState s\irq_state := irq_state (ksMachineState s) + 1\)\)\ + doMachineOp (getActiveIRQ in_kernel) + \P\" + apply(simp add: doMachineOp_def getActiveIRQ_def non_kernel_IRQs_def) + apply(wp modify_wp | wpc)+ + apply clarsimp + apply(erule use_valid) + apply (wp modify_wp) + apply(auto simp: irq_at_def) + done + +lemma scheduler_if'_arch_extras[ADT_IF_Refine_assms, wp]: + "\invs' and arch_extras\ + schedule'_if tc + \\_. arch_extras\" + apply (simp add: schedule'_if_def) + apply (wp hoare_drop_imps | simp)+ + done + +lemma handlePreemption_if_arch_extras[ADT_IF_Refine_assms, wp]: + "handlePreemption_if tc \arch_extras\" + apply (simp add: handlePreemption_if_def) + apply (wp dmo'_getActiveIRQ_wp hoare_drop_imps) + done + +crunch doUserOp_if + for ksDomainTime_inv[ADT_IF_Refine_assms, wp]: "\s. P (ksDomainTime s)" + and ksDomSchedule_inv[ADT_IF_Refine_assms, wp]: "\s. P (ksDomSchedule s)" + +crunch checkActiveIRQ_if + for arch_extras[ADT_IF_Refine_assms, wp]: arch_extras + +lemma valid_device_abs_state_eq[ADT_IF_Refine_assms]: + "valid_machine_state s \ abs_state s = s" + apply (simp add: abs_state_def observable_memory_def) + apply (case_tac s) + apply clarsimp + apply (case_tac machine_state) + apply clarsimp + apply (rule ext) + apply (fastforce simp: user_mem_def option_to_0_def valid_machine_state_def) + done + +lemma doUserOp_if_no_interrupt[ADT_IF_Refine_assms]: + "\K (uop_sane uop)\ + doUserOp_if uop tc + \\r s. (fst r) \ Some Interrupt\" + apply (simp add: doUserOp_if_def del: split_paired_All) + apply (wp | wpc)+ + apply (clarsimp simp: uop_sane_def simp del: split_paired_All) + done + +lemma handleEvent_corres_arch_extras[ADT_IF_Refine_assms]: + "corres (dc \ dc) + (einvs and (\s. event \ Interrupt \ ct_running s) and schact_is_rct) + (invs' and (\s. event \ Interrupt \ ct_running' s) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and arch_extras) + (handle_event event) (handleEvent event)" + by (fastforce intro: corres_guard2_imp[OF handleEvent_corres]) + +lemma getActiveIRQ_corres_True_False: + "corres_underlying Id False True (=) \ \ (getActiveIRQ True) (getActiveIRQ False)" + unfolding getActiveIRQ_def + by (corres simp: non_kernel_IRQs_def) + +lemma maybeHandleInterrupt_corres_True_False[ADT_IF_Refine_assms]: + "corres dc einvs invs' (maybe_handle_interrupt True) (maybeHandleInterrupt False)" + unfolding maybe_handle_interrupt_def maybeHandleInterrupt_def + apply (corres corres: corres_machine_op getActiveIRQ_corres_True_False + handleInterrupt_corres[@lift_corres_args] + simp: irq_state_independent_def + | corres_cases_both)+ + apply (wpsimp wp: hoare_drop_imps) + apply clarsimp + apply (strengthen contract_all_imp_strg[where P'=True, simplified]) + apply (wpsimp wp: doMachineOp_getActiveIRQ_IRQ_active' hoare_vcg_all_lift) + apply clarsimp + apply (clarsimp simp: invs'_def valid_state'_def) + done + +end + +requalify_consts + RISCV64.doUserOp_if + + +global_interpretation ADT_IF_Refine_1?: ADT_IF_Refine_1 doUserOp_if +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_Refine_assms)?) +qed + + +sublocale valid_initial_state_noenabled \ valid_initial_state_noenabled?: + ADT_valid_initial_state_noenabled doUserOp_if .. + +sublocale valid_initial_state_noenabled \ valid_initial_state .. + +end diff --git a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy new file mode 100644 index 0000000000..d45cb057a3 --- /dev/null +++ b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy @@ -0,0 +1,237 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchADT_IF_Refine_C +imports ADT_IF_Refine_C +begin + +context kernel_m begin + +named_theorems ADT_IF_Refine_assms + +lemma handleInterrupt_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs') + (UNIV) + [] + (handleEvent Interrupt) + (handleInterruptEntry_C_body_if)" + apply (rule ccorres_guard_imp2) + apply (simp add: handleEvent_def minus_one_norm handleInterruptEntry_C_body_if_def) + apply (rule ccorres_add_return2) + apply (ctac (no_vcg) add: checkInterrupt_ccorres) + apply (rule_tac R="\_. rv = Inr ()" in ccorres_return[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (clarsimp simp: return_def) + apply (simp add: liftE_def) + apply wpsimp + apply clarsimp + done + +lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_active' and sch_act_simple) + (UNIV \ {s. isCall_' s = from_bool isCall} + \ {s. isBlocking_' s = from_bool isBlocking}) [] + (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" + apply (simp only: arch_extras_def pred_top_right_neutral) + apply (rule handleInvocation_ccorres) + done + +definition + "ptable_rights_s'' s \ ptable_rights (cur_thread (cstate_to_A s)) (cstate_to_A s)" + +definition + "ptable_lift_s'' s \ ptable_lift (cur_thread (cstate_to_A s)) (cstate_to_A s)" + +definition + "ptable_attrs_s'' s \ ptable_attrs (cur_thread (cstate_to_A s)) (cstate_to_A s)" + +definition + "ptable_xn_s'' s \ \addr. Execute \ ptable_attrs_s'' s addr" + +definition + doMachineOp_C :: "(machine_state, 'a) nondet_monad \ (cstate, 'a) nondet_monad" +where + "doMachineOp_C mop \ + do + ms \ gets (\s. phantom_machine_state_' (globals s)); + (r, ms') \ select_f (mop ms); + modify (\s. s \globals := globals s \ phantom_machine_state_' := ms' \\); + return r + od" + +definition doUserOp_C_if + :: "user_transition_if \ user_context \ (cstate, (event option \ user_context)) nondet_monad" + where + "doUserOp_C_if uop tc \ + do + pr \ gets ptable_rights_s''; + pxn \ gets (\s x. pr x \ {} \ ptable_xn_s'' s x); + pl \ gets (\s. restrict_map (ptable_lift_s'' s) {x. pr x \ {}}); + allow_read \ return {y. \x. pl x = Some y \ AllowRead \ pr x}; + allow_write \ return {y. \x. pl x = Some y \ AllowWrite \ pr x}; + t \ gets (\s. cur_thread (cstate_to_A s)); + um \ gets (\s. user_mem_C (globals s) \ ptrFromPAddr); + dm \ gets (\s. device_mem_C (globals s) \ ptrFromPAddr); + ds \ gets (\s. device_state (phantom_machine_state_' (globals s))); + assert (dom (um \ addrFromPPtr) \ - dom ds); + assert (dom (dm \ addrFromPPtr) \ dom ds); + u \ return (uop t pl pr pxn (tc, um |` allow_read, (ds \ ptrFromPAddr)|` allow_read)); + assert (u \ {}); + (e,(tc',um',ds')) \ select u; + setUserMem_C ((um' |` allow_write \ addrFromPPtr) |` (- dom ds)); + setDeviceState_C ((ds' |` allow_write \ addrFromPPtr) |` dom ds); + return (e,tc') + od" + +lemma corres_underlying_split4: + "(\a b c d. corres_underlying srel nf nf' rrel (Q a b c d) (Q' a b c d) (f a b c d) (f' a b c d)) + \ corres_underlying srel nf nf' rrel (case x of (a,b,c,d) \ Q a b c d) + (case x of (a,b,c,d) \ Q' a b c d) + (case x of (a,b,c,d) \ f a b c d) + (case x of (a,b,c,d) \ f' a b c d)" + by (cases x; simp) + +lemma do_user_op_if_C_corres[ADT_IF_Refine_assms]: + "corres_underlying rf_sr False False (=) + (invs' and ex_abs einvs and (\_. uop_nonempty f)) \ + (doUserOp_if f tc) (doUserOp_C_if f tc)" + apply (rule corres_gen_asm) + apply (simp add: doUserOp_if_def doUserOp_C_if_def uop_nonempty_def del: split_paired_All) + apply (rule corres_gets_same) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: absKState_crelation ptable_rights_s'_def ptable_rights_s''_def + rf_sr_def cstate_relation_def Let_def cstate_to_H_correct) + apply simp + apply (rule corres_gets_same) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: ptable_xn_s'_def ptable_xn_s''_def ptable_attrs_s_def + absKState_crelation ptable_attrs_s'_def ptable_attrs_s''_def rf_sr_def) + apply simp + apply (rule corres_gets_same) + apply clarsimp + apply (frule ex_abs_ksReadyQueues_asrt) + apply (clarsimp simp: absKState_crelation curthread_relation ptable_lift_s'_def ptable_lift_s''_def + ptable_lift_s_def rf_sr_def) + apply simp + apply (simp add: getCurThread_def) + apply (rule corres_gets_same) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt simp: absKState_crelation rf_sr_def) + apply simp + apply (rule corres_gets_same) + apply (rule fun_cong[where x=ptrFromPAddr]) + apply (rule_tac f=comp in arg_cong) + apply (rule user_mem_C_relation[symmetric]) + apply (simp add: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) + apply fastforce + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def) + apply (drule device_mem_C_relation[symmetric]) + apply fastforce + apply (simp add: comp_def) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: cstate_relation_def rf_sr_def + Let_def cmachine_state_relation_def) + apply simp + apply (rule corres_guard_imp) + apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) + apply (clarsimp simp add: corres_underlying_def fail_def + assert_def return_def + split: if_splits) + apply simp + apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) + apply (clarsimp simp add: corres_underlying_def fail_def + assert_def return_def + split: if_splits) + apply simp + apply (rule_tac r'="(=)" in corres_split[OF corres_select]) + apply clarsimp + apply simp + apply (rule corres_underlying_split4) + apply (rule corres_split[OF user_memory_update_corres_C]) + apply (rule corres_split[OF device_update_corres_C]) + apply (wp | simp)+ + apply (clarsimp simp: ex_abs_def restrict_map_def invs_pspace_aligned' + invs_pspace_distinct' ptable_lift_s'_def ptable_rights_s'_def + split: if_splits) + apply (drule ptable_rights_imp_UserData[rotated -1]) + apply ((fastforce | intro conjI)+)[4] + apply (clarsimp simp: user_mem'_def device_mem'_def dom_def split: if_splits) + apply fastforce + apply (clarsimp simp add: invs'_def valid_state'_def valid_pspace'_def ex_abs_def) + done + +lemma check_active_irq_corres_C[ADT_IF_Refine_assms]: + "corres_underlying rf_sr False False (=) \ \ + (checkActiveIRQ_if tc) (checkActiveIRQ_C_if tc)" + apply (simp add: checkActiveIRQ_if_def checkActiveIRQ_C_if_def) + apply (simp add: getActiveIRQ_C_def) + apply (subst bind_assoc[symmetric]) + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="\a c. case a of None \ c = ucast irqInvalid + | Some x \ c = ucast x \ c \ ucast irqInvalid", + OF ccorres_corres_u_xf]) + apply (rule ccorres_guard_imp) + apply (rule ccorres_rel_imp, rule ccorres_guard_imp) + apply (rule getActiveIRQ_ccorres) + apply simp+ + apply (rule no_fail_dmo') + apply (rule no_fail_getActiveIRQ) + apply (rule corres_trivial, clarsimp split: if_split option.splits) + apply wp+ + apply simp+ + apply fastforce + done + +lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: + "\pspace_aligned' bd;pspace_distinct' bd; + cpspace_user_data_relation (ksPSpace bd) (underlying_memory (ksMachineState bd)) hgs\ + \ cpspace_user_data_relation (ksPSpace bd) (underlying_memory (observable_memory (ksMachineState bd) (user_mem' bd))) hgs" + apply (clarsimp simp: cmap_relation_def dom_heap_to_user_data) + apply (drule bspec,fastforce) + apply (clarsimp simp: cuser_user_data_relation_def observable_memory_def + heap_to_user_data_def map_comp_def Let_def + split: option.split_asm) + apply (drule_tac x = off in spec) + apply (subst option_to_0_user_mem') + apply (subst map_option_byte_to_word_heap) + apply (clarsimp simp: projectKO_opt_user_data pointerInUserData_def field_simps + split: kernel_object.split_asm option.split_asm) + apply (frule(1) pspace_alignedD') + apply (subst neg_mask_add_aligned) + apply (simp add: objBits_simps) + apply (simp add: word_less_nat_alt) + apply (rule le_less_trans[OF unat_plus_gt]) + apply (subst add.commute) + apply (subst unat_mult_simple) + apply (simp add: word_bits_def) + apply (rule less_le_trans[OF unat_lt2p]) + apply simp + apply simp + apply (rule nat_add_offset_less [where n = 3, simplified]) + apply simp + apply (rule unat_lt2p) + apply (simp add: pageBits_def objBits_simps) + apply (frule(1) pspace_distinctD') + apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def objBits_simps) + apply simp + done + +end + + +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_Refine_assms)?) +qed + +end diff --git a/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy new file mode 100644 index 0000000000..a7df9032df --- /dev/null +++ b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy @@ -0,0 +1,3835 @@ +(* + * Copyright 2023, Proofcraft Pty Ltd + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory Example_Valid_StateH +imports "InfoFlow.Example_Valid_State" ArchADT_IF_Refine +begin + +context begin interpretation Arch . + +section \Haskell state\ + +text \One invariant we need on s0 is that there exists + an associated Haskell state satisfying the invariants. + This does not yet exist.\ + +subsection \Defining the State\ + +definition empty_cte :: "nat \ bool list \ (capability \ mdbnode) option" where + "empty_cte bits \ \x. if length x = bits then Some (NullCap, MDB 0 0 False False) else None" + +abbreviation (input) Null_mdb :: "mdbnode" where + "Null_mdb \ MDB 0 0 False False" + + +text \Low's CSpace\ + +definition Low_capsH :: "cnode_index \ (capability \ mdbnode) option" where + "Low_capsH \ + (empty_cte 10) + ((the_nat_to_bl_10 1) + \ (ThreadCap Low_tcb_ptr, Null_mdb), + (the_nat_to_bl_10 2) + \ (CNodeCap Low_cnode_ptr 10 2 10, MDB 0 Low_tcb_ptr False False), + (the_nat_to_bl_10 3) + \ (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0))), + MDB 0 (Low_tcb_ptr + 0x20) False False), + (the_nat_to_bl_10 4) + \ (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid)), Null_mdb), + (the_nat_to_bl_10 5) + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite RISCVLargePage + False (Some (ucast Low_asid, 0))), + MDB 0 (Silc_cnode_ptr + 0xA0) False False), + (the_nat_to_bl_10 6) + \ (ArchObjectCap (PageTableCap Low_pt_ptr (Some (ucast Low_asid, 0))), Null_mdb), + (the_nat_to_bl_10 318) + \ (NotificationCap ntfn_ptr 0 True False, MDB (Silc_cnode_ptr + 318 * 0x20) 0 False False))" + +definition Low_cte' :: "10 word \ cte option" where + "Low_cte' \ (map_option (\(cap, mdb). CTE cap mdb)) \ Low_capsH \ to_bl" + +definition Low_cte :: "obj_ref \ obj_ref \ kernel_object option" where + "Low_cte \ \base offs. + if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then map_option (\cte. KOCTE cte) (Low_cte' (ucast (offs - base >> 5))) + else None" + + +text \High's Cspace\ + +definition High_capsH :: "cnode_index \ (capability \ mdbnode) option" where + "High_capsH \ + (empty_cte 10) + ((the_nat_to_bl_10 1) + \ (ThreadCap High_tcb_ptr, Null_mdb), + (the_nat_to_bl_10 2) + \ (CNodeCap High_cnode_ptr 10 2 10, MDB 0 High_tcb_ptr False False), + (the_nat_to_bl_10 3) + \ (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0))), + MDB 0 (High_tcb_ptr + 0x20) False False), + (the_nat_to_bl_10 4) + \ (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid)), Null_mdb), + (the_nat_to_bl_10 5) + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + False (Some (ucast High_asid, 0))), + MDB (Silc_cnode_ptr + 0xA0) 0 False False), + (the_nat_to_bl_10 6) + \ (ArchObjectCap (PageTableCap High_pt_ptr (Some (ucast High_asid, 0))), + Null_mdb), + (the_nat_to_bl_10 318) + \ (NotificationCap ntfn_ptr 0 False True, MDB 0 (Silc_cnode_ptr + 318 * 0x20) False False))" + +definition High_cte' :: "10 word \ cte option" where + "High_cte' \ (map_option (\(cap, mdb). CTE cap mdb)) \ High_capsH \ to_bl" + +definition High_cte :: "obj_ref \ obj_ref \ kernel_object option" where + "High_cte \ \base offs. + if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then map_option (\cte. KOCTE cte) (High_cte' (ucast (offs - base >> 5))) + else None" + + +text \We need a copy of boundary crossing caps owned by SilcLabel.\ + +definition Silc_capsH :: "cnode_index \ (capability \ mdbnode) option" where + "Silc_capsH \ + (empty_cte 10) + ((the_nat_to_bl_10 2) + \ (CNodeCap Silc_cnode_ptr 10 2 10, Null_mdb), + (the_nat_to_bl_10 5) + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + False (Some (ucast Silc_asid, 0))), + MDB (Low_cnode_ptr + 0xA0) (High_cnode_ptr + 0xA0) False False), + (the_nat_to_bl_10 318) + \ (NotificationCap ntfn_ptr 0 True False, + MDB (High_cnode_ptr + 318 * 0x20) (Low_cnode_ptr + 318 * 0x20) False False))" + +definition Silc_cte' :: "10 word \ cte option" where + "Silc_cte' \ (map_option (\(cap, mdb). CTE cap mdb)) \ Silc_capsH \ to_bl" + +definition Silc_cte :: "obj_ref \ obj_ref \ kernel_object option" where + "Silc_cte \ \base offs. + if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then map_option (\cte. KOCTE cte) (Silc_cte' (ucast (offs - base >> 5))) + else None" + + +text \Notification between Low and High\ + +definition ntfnH :: notification where + "ntfnH \ NTFN (ntfn.WaitingNtfn [High_tcb_ptr]) None" + + +text \Global page table\ + +definition global_pteH' :: "pt_index \ pte" where + "global_pteH' idx \ + if idx = 0x100 + then PagePTE ((ucast (idx && mask (ptTranslationBits - 1)) << ptTranslationBits * size max_pt_level)) + False False False VMKernelOnly + else if idx = elf_index + then PagePTE (ucast ((kernelELFPAddrBase && ~~mask toplevel_bits) >> pageBits)) False False False VMKernelOnly + else InvalidPTE" + +definition global_pteH where + "global_pteH \ (\idx. if idx \ kernel_mapping_slots then global_pteH' idx else InvalidPTE)" + +definition global_ptH :: "obj_ref \ obj_ref \ kernel_object option" where + "global_ptH \ \base. + (map_option (\x. KOArch (KOPTE (global_pteH (x :: pt_index))))) \ + (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 + then Some (ucast (offs - base >> 3)) else None)" + + +text \Low's page tables\ + +definition Low_pt'H :: "pt_index \ pte" where + "Low_pt'H \ + (\_. InvalidPTE) + (0 := PagePTE (shared_page_ptr_phys >> pt_bits) False False False VMReadWrite)" + +definition Low_ptH :: "obj_ref \ obj_ref \ kernel_object option" where + "Low_ptH \ + \base. (map_option (\x. KOArch (KOPTE (Low_pt'H x)))) \ + (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 + then Some (ucast (offs - base >> 3)) else None)" + +definition Low_pd'H :: "pt_index \ pte" where + "Low_pd'H \ + global_pteH + (0 := PageTablePTE (addrFromPPtr Low_pt_ptr >> pt_bits) False)" + +definition Low_pdH :: "obj_ref \ obj_ref \ kernel_object option" where + "Low_pdH \ + \base. (map_option (\x. KOArch (KOPTE (Low_pd'H x)))) \ + (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 + then Some (ucast (offs - base >> 3)) else None)" + + +text \High's page tables\ + +definition High_pt'H :: "pt_index \ pte" where + "High_pt'H \ + (\_. InvalidPTE) + (0 := PagePTE (shared_page_ptr_phys >> pt_bits) False False False VMReadOnly)" + +definition High_ptH :: "obj_ref \ obj_ref \ kernel_object option" where + "High_ptH \ + \base. (map_option (\x. KOArch (KOPTE (High_pt'H x)))) \ + (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 + then Some (ucast (offs - base >> 3)) else None)" + +definition High_pd'H :: "pt_index \ pte" where + "High_pd'H \ + global_pteH + (0 := PageTablePTE (addrFromPPtr High_pt_ptr >> pt_bits) False)" + +definition High_pdH :: "obj_ref \ obj_ref \ kernel_object option" where + "High_pdH \ + \base. (map_option (\x. KOArch (KOPTE (High_pd'H x)))) \ + (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 + then Some (ucast (offs - base >> 3)) else None)" + + +text \Low's tcb\ + +definition Low_tcbH :: tcb where + "Low_tcbH \ Thread + \ \tcbCTable =\ (CTE (CNodeCap Low_cnode_ptr 10 2 10) + (MDB (Low_cnode_ptr + 0x40) 0 False False)) + \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0)))) + (MDB (Low_cnode_ptr + 0x60) 0 False False)) + \ \tcbReply =\ (CTE (ReplyCap Low_tcb_ptr True True) (MDB 0 0 True True)) + \ \tcbCaller =\ (CTE NullCap Null_mdb) + \ \tcbIPCBufferFrame =\ (CTE NullCap Null_mdb) + \ \tcbDomain =\ Low_domain + \ \tcbState =\ Running + \ \tcbMCPriority =\ Low_mcp + \ \tcbPriority =\ Low_prio + \ \tcbQueued =\ False + \ \tcbFault =\ None + \ \tcbTimeSlice =\ Low_time_slice + \ \tcbFaultHandler =\ 0 + \ \tcbIPCBuffer =\ 0 + \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None + \ \tcbFlags =\ 0 + \ \tcbContext =\ (ArchThread undefined)" + + +text \High's tcb\ + +definition High_tcbH :: tcb where + "High_tcbH \ Thread + \ \tcbCTable =\ (CTE (CNodeCap High_cnode_ptr 10 2 10) + (MDB (High_cnode_ptr + 0x40) 0 False False)) + \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) + (MDB (High_cnode_ptr + 0x60) 0 False False)) + \ \tcbReply =\ (CTE (ReplyCap High_tcb_ptr True True) (MDB 0 0 True True)) + \ \tcbCaller =\ (CTE NullCap Null_mdb) + \ \tcbIPCBufferFrame =\ (CTE NullCap Null_mdb) + \ \tcbDomain =\ High_domain + \ \tcbState =\ (BlockedOnNotification ntfn_ptr) + \ \tcbMCPriority =\ High_mcp + \ \tcbPriority =\ High_prio + \ \tcbQueued =\ False + \ \tcbFault =\ None + \ \tcbTimeSlice =\ High_time_slice + \ \tcbFaultHandler =\ 0 + \ \tcbIPCBuffer =\ 0 + \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None + \ \tcbFlags =\ 0 + \ \tcbContext =\ (ArchThread undefined)" + + +text \idle's tcb\ + +definition idle_tcbH :: tcb where + "idle_tcbH \ Thread + \ \tcbCTable =\ (CTE NullCap Null_mdb) + \ \tcbVTable =\ (CTE NullCap Null_mdb) + \ \tcbReply =\ (CTE NullCap Null_mdb) + \ \tcbCaller =\ (CTE NullCap Null_mdb) + \ \tcbIPCBufferFrame =\ (CTE NullCap Null_mdb) + \ \tcbDomain =\ default_domain + \ \tcbState =\ IdleThreadState + \ \tcbMCPriority =\ default_priority + \ \tcbPriority =\ default_priority + \ \tcbQueued =\ False + \ \tcbFault =\ None + \ \tcbTimeSlice =\ timeSlice + \ \tcbFaultHandler =\ 0 + \ \tcbIPCBuffer =\ 0 + \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None + \ \tcbFlags =\ 0 + \ \tcbContext =\ (ArchThread empty_context)" + + +text \Low's asid pool\ + +abbreviation Low_poolH' :: "obj_ref \ obj_ref" where + "Low_poolH' \ \idx. if idx = ucast (asid_low_bits_of Low_asid) then Some Low_pd_ptr else None" + +definition Low_poolH :: arch_kernel_object where + "Low_poolH \ KOASIDPool (ASIDPool Low_poolH')" + + +text \High's asid pool\ + +abbreviation High_poolH' :: "obj_ref \ obj_ref" where + "High_poolH' \ \idx. if idx = ucast (asid_low_bits_of High_asid) then Some High_pd_ptr else None" + +definition High_poolH :: arch_kernel_object where + "High_poolH \ KOASIDPool (ASIDPool High_poolH')" + + +text \Shared page\ + +definition shared_pageH :: "obj_ref \ obj_ref \ kernel_object option" where + "shared_pageH \ \base. + (\offs. if is_aligned offs 12 \ base \ offs \ offs \ base + 2 ^ 21 - 1 + then Some KOUserData else None)" + + +text \Initial ksPSpace\ + +definition irq_cte :: cte where + "irq_cte \ CTE NullCap Null_mdb" + +definition option_update_range :: "('a \ 'b option) \ ('a \ 'b option) \ ('a \ 'b option)" where + "option_update_range f g \ \x. case f x of None \ g x | Some y \ Some y" + +definition kh0H :: "(obj_ref \ kernel_object)" where + "kh0H \ (option_update_range (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some (KOCTE (CTE NullCap Null_mdb)) else None) \ + option_update_range (Low_cte Low_cnode_ptr) \ + option_update_range (High_cte High_cnode_ptr) \ + option_update_range (Silc_cte Silc_cnode_ptr) \ + option_update_range [ntfn_ptr \ KONotification ntfnH] \ + option_update_range [irq_cnode_ptr \ KOCTE irq_cte] \ + option_update_range (Low_pdH Low_pd_ptr) \ + option_update_range (High_pdH High_pd_ptr) \ + option_update_range (Low_ptH Low_pt_ptr) \ + option_update_range (High_ptH High_pt_ptr) \ + option_update_range [Low_pool_ptr \ KOArch Low_poolH] \ + option_update_range [High_pool_ptr \ KOArch High_poolH] \ + option_update_range [Low_tcb_ptr \ KOTCB Low_tcbH] \ + option_update_range [High_tcb_ptr \ KOTCB High_tcbH] \ + option_update_range [idle_tcb_ptr \ KOTCB idle_tcbH] \ + option_update_range (shared_pageH shared_page_ptr_virt) \ + option_update_range (global_ptH riscv_global_pt_ptr) + ) Map.empty" + + +lemma s0_ptrs_aligned: + "is_aligned riscv_global_pt_ptr 12" + "is_aligned High_pd_ptr 12" + "is_aligned Low_pd_ptr 12" + "is_aligned High_pt_ptr 12" + "is_aligned Low_pt_ptr 12" + "is_aligned Silc_cnode_ptr 15" + "is_aligned High_cnode_ptr 15" + "is_aligned Low_cnode_ptr 15" + "is_aligned High_tcb_ptr 10" + "is_aligned Low_tcb_ptr 10" + "is_aligned idle_tcb_ptr 10" + "is_aligned ntfn_ptr 5" + "is_aligned shared_page_ptr_virt 21" + "is_aligned irq_cnode_ptr 10" + "is_aligned Low_pool_ptr 12" + "is_aligned High_pool_ptr 12" + by (simp add: is_aligned_def s0_ptr_defs)+ + + +text \Page offset lemmas\ + +lemma page_offs_min': + "is_aligned ptr 21 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pt_index) << 12)" + apply (erule is_aligned_no_wrap') + apply (word_bitwise, auto) + done + +lemma page_offs_min: + "shared_page_ptr_virt \ shared_page_ptr_virt + (ucast (x:: pt_index) << 12)" + by (simp_all add: page_offs_min' s0_ptrs_aligned) + +lemma page_offs_max': + "is_aligned ptr 21 \ (ptr :: obj_ref) + (ucast (x :: pt_index) << 12) \ ptr + 0x1FFFFF" + apply (rule word_plus_mono_right) + apply (simp add: shiftl_t2n mult.commute) + apply (rule div_to_mult_word_lt) + apply simp + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply simp + apply (fastforce elim: dual_order.strict_trans[rotated]) + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma page_offs_max: + "shared_page_ptr_virt + (ucast (x :: pt_index) << 12) \ shared_page_ptr_virt + 0x1FFFFF" + by (simp_all add: page_offs_max' s0_ptrs_aligned) + +definition page_offs_range where + "page_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 21 - 1} + \ {x. is_aligned x 12}" + +lemma page_offs_in_range': + "is_aligned ptr 21 \ ptr + (ucast (x :: pt_index) << 12) \ page_offs_range ptr" + apply (clarsimp simp: page_offs_min' page_offs_max' page_offs_range_def add.commute) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (erule is_aligned_weaken) + apply simp + done + +lemma page_offs_in_range: + "shared_page_ptr_virt + (ucast (x :: pt_index) << 12) \ page_offs_range shared_page_ptr_virt" + by (simp_all add: page_offs_in_range' s0_ptrs_aligned) + +lemma page_offs_range_correct': + "\ x \ page_offs_range ptr; is_aligned ptr 21 \ + \ \y. x = ptr + (ucast (y :: pt_index) << 12)" + apply (clarsimp simp: page_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast ((x - ptr) >> 12)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply simp + apply (rule_tac n=21 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0x1FFFFF" and n=21 in neg_mask_mono_le) + apply (simp add: add.commute) + apply (drule_tac n=21 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (simp add: add.commute) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma page_offs_range_correct: + "x \ page_offs_range shared_page_ptr_virt + \ \y. x = shared_page_ptr_virt + (ucast (y :: pt_index) << 12)" + by (simp_all add: page_offs_range_correct' s0_ptrs_aligned) + + +text \Page table offset lemmas\ + +lemma pt_offs_min': + "is_aligned ptr 12 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pt_index) << 3)" + apply (erule is_aligned_no_wrap') + apply (word_bitwise, auto) + done + +lemma pt_offs_min: + "Low_pd_ptr \ Low_pd_ptr + (ucast (x :: pt_index) << 3)" + "High_pd_ptr \ High_pd_ptr + (ucast (x :: pt_index) << 3)" + "Low_pt_ptr \ Low_pt_ptr + (ucast (x :: pt_index) << 3)" + "High_pt_ptr \ High_pt_ptr + (ucast (x :: pt_index) << 3)" + "riscv_global_pt_ptr \ riscv_global_pt_ptr + (ucast (x :: pt_index) << 3)" + by (simp_all add: pt_offs_min' s0_ptrs_aligned) + +lemma pt_offs_max': + "is_aligned ptr 12 \ (ptr :: obj_ref) + (ucast (x :: pt_index) << 3) \ ptr + 0xFFF" + apply (rule word_plus_mono_right) + apply (simp add: shiftl_t2n mult.commute) + apply (rule div_to_mult_word_lt) + apply simp + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply simp + apply (fastforce elim: dual_order.strict_trans[rotated]) + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma pt_offs_max: + "Low_pd_ptr + (ucast (x :: pt_index) << 3) \ Low_pd_ptr + 0xFFF" + "High_pd_ptr + (ucast (x :: pt_index) << 3) \ High_pd_ptr + 0xFFF" + "Low_pt_ptr + (ucast (x :: pt_index) << 3) \ Low_pt_ptr + 0xFFF" + "High_pt_ptr + (ucast (x :: pt_index) << 3) \ High_pt_ptr + 0xFFF" + "riscv_global_pt_ptr + (ucast (x :: pt_index) << 3) \ riscv_global_pt_ptr + 0xFFF" + by (simp_all add: pt_offs_max' s0_ptrs_aligned) + +definition pt_offs_range where + "pt_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 12 - 1} + \ {x. is_aligned x 3}" + +lemma pt_offs_in_range': + "is_aligned ptr 12 + \ ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range ptr" + apply (clarsimp simp: pt_offs_min' pt_offs_max' pt_offs_range_def add.commute) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (erule is_aligned_weaken) + apply simp + done + +lemma pt_offs_in_range: + "Low_pd_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range Low_pd_ptr" + "High_pd_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range High_pd_ptr" + "Low_pt_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range Low_pt_ptr" + "High_pt_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range High_pt_ptr" + "riscv_global_pt_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range riscv_global_pt_ptr" + by (simp_all add: pt_offs_in_range' s0_ptrs_aligned) + +lemma pt_offs_range_correct': + "\ x \ pt_offs_range ptr; is_aligned ptr 12 \ + \ \y. x = ptr + (ucast (y :: pt_index) << 3)" + apply (clarsimp simp: pt_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast ((x - ptr) >> 3)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply simp + apply (rule_tac n=12 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0xFFF" and n=12 in neg_mask_mono_le) + apply (simp add: add.commute) + apply (drule_tac n=12 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (simp add: add.commute) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma pt_offs_range_correct: + "x \ pt_offs_range Low_pd_ptr \ \y. x = Low_pd_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range High_pd_ptr \ \y. x = High_pd_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range Low_pt_ptr \ \y. x = Low_pt_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range High_pt_ptr \ \y. x = High_pt_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range riscv_global_pt_ptr \ \y. x = riscv_global_pt_ptr + (ucast (y :: pt_index) << 3)" + by (simp_all add: pt_offs_range_correct' s0_ptrs_aligned) + + +text \CNode offset lemmas\ + +lemma bl_to_bin_le2p_aux: + "bl_to_bin_aux bs w \ (w + 1) * (2 ^ length bs) - 1" + apply (induct bs arbitrary: w) + apply clarsimp + apply (clarsimp split del: split_of_bool) + apply (drule meta_spec, erule xtr8 [rotated], simp)+ + done + +lemma bl_to_bin_le2p: + "bl_to_bin bs \ (2 ^ length bs) - 1" + apply (unfold bl_to_bin_def) + apply (rule xtr3) + prefer 2 + apply (rule bl_to_bin_le2p_aux) + apply simp + done + +lemma of_bl_length_le: + "\ length x = k; k < len_of TYPE('a) \ \ (of_bl x :: 'a :: len word) \ 2 ^ k - 1" + apply (unfold of_bl_def word_less_alt word_numeral_alt) + apply safe + apply (simp add: word_le_def take_bit_int_def uint_2p_alt uint_word_arith_bintrs(2)) + apply (subst mod_pos_pos_trivial) + apply simp + using not_le apply fastforce + apply (subst uint_word_of_int) + apply (subst mod_pos_pos_trivial) + apply (rule bl_to_bin_ge0) + apply (rule order_less_trans) + apply (rule bl_to_bin_lt2p) + apply simp + apply (rule bl_to_bin_le2p) + done + +lemma cnode_offs_min': + "\ is_aligned ptr 15; length x = 10 \ \ (ptr :: obj_ref) \ ptr + of_bl x * 0x20" + apply (erule is_aligned_no_wrap') + apply (rule div_lt_mult) + apply (drule of_bl_length_less[where 'a=64]) + apply simp + apply simp + apply simp + done + +lemma cnode_offs_min: + "length x = 10 \ Low_cnode_ptr \ Low_cnode_ptr + of_bl x * 0x20" + "length x = 10 \ High_cnode_ptr \ High_cnode_ptr + of_bl x * 0x20" + "length x = 10 \ Silc_cnode_ptr \ Silc_cnode_ptr + of_bl x * 0x20" + by (simp_all add: cnode_offs_min' s0_ptrs_aligned) + +lemma cnode_offs_max': + "\ is_aligned ptr 15; length x = 10 \ \ (ptr :: obj_ref) + of_bl x * 0x20 \ ptr + 0x7fff" + apply (rule word_plus_mono_right) + apply (rule div_to_mult_word_lt) + apply simp + apply (rule plus_one_helper) + apply simp + apply (drule of_bl_length_less[where 'a=64]) + apply simp + apply simp + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma cnode_offs_max: + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ Low_cnode_ptr + 0x7fff" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ High_cnode_ptr + 0x7fff" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ Silc_cnode_ptr + 0x7fff" + by (simp_all add: cnode_offs_max' s0_ptrs_aligned) + +definition cnode_offs_range where + "cnode_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 15 - 1} + \ {x. is_aligned x 5}" + +lemma cnode_offs_in_range': + "\ is_aligned ptr 15; length x = 10 \ \ ptr + of_bl x * 0x20 \ cnode_offs_range ptr" + apply (simp add: cnode_offs_min' cnode_offs_max' cnode_offs_range_def add.commute) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (rule_tac is_aligned_mult_triv2[where x="of_bl x" and n=5, simplified]) + done + +lemma cnode_offs_in_range: + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ cnode_offs_range Low_cnode_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ cnode_offs_range High_cnode_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ cnode_offs_range Silc_cnode_ptr" + by (simp_all add: cnode_offs_in_range' s0_ptrs_aligned) + +lemma le_mask_eq: + "x \ 2 ^ n - 1 \ x AND mask n = (x :: 'a :: len word)" + apply (unfold word_less_alt word_numeral_alt) + apply (simp add: word_of_int_power_hom mask_eq_exp_minus_1[symmetric]) + apply (erule word_le_mask_eq) + done + +lemma word_div_mult': + fixes c :: obj_ref + shows "\ 0 < c; a \ b * c \ \ a div c \ b" + apply (simp add: word_le_nat_alt unat_div) + apply (simp add: less_Suc_eq_le[symmetric]) + apply (subst td_gal_lt [symmetric]) + apply (simp add: word_less_nat_alt) + apply (erule order_less_le_trans) + apply (subst unat_word_ariths) + apply (rule_tac y="Suc (unat b * unat c)" in order_trans) + apply simp + apply (simp add: word_less_nat_alt) + done + +lemma cnode_offs_range_correct': + "\ x \ cnode_offs_range ptr; is_aligned ptr 15 \ + \ \y. length y = 10 \ (x = ptr + of_bl y * 0x20)" + apply (clarsimp simp: cnode_offs_range_def s0_ptr_defs) + apply (rule_tac x="to_bl (ucast ((x - ptr) div 0x20) :: 10 word)" in exI) + apply (clarsimp simp: to_bl_ucast of_bl_drop) + apply (subst le_mask_eq) + apply simp + apply (rule word_div_mult') + apply simp + apply simp + apply (rule word_diff_ls') + apply (drule_tac a=x and n=5 in aligned_le_sharp) + apply simp + apply (simp add: add.commute) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + apply simp + apply (clarsimp simp: neg_mask_is_div[where n=5, simplified, symmetric]) + apply (subst is_aligned_neg_mask_eq) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply simp + done + +lemma cnode_offs_range_correct: + "x \ cnode_offs_range Low_cnode_ptr \ \y. length y = 10 \ (x = Low_cnode_ptr + of_bl y * 0x20)" + "x \ cnode_offs_range High_cnode_ptr \ \y. length y = 10 \ (x = High_cnode_ptr + of_bl y * 0x20)" + "x \ cnode_offs_range Silc_cnode_ptr \ \y. length y = 10 \ (x = Silc_cnode_ptr + of_bl y * 0x20)" + by (simp_all add: cnode_offs_range_correct' s0_ptrs_aligned) + + +text \TCB offset lemmas\ + +lemma tcb_offs_min': + "is_aligned ptr 10 \ (ptr :: obj_ref) \ ptr + ucast (x :: 10 word)" + apply (erule is_aligned_no_wrap') + apply (cut_tac x=x and 'a=64 in ucast_less) + apply simp + apply simp + done + +lemma tcb_offs_min: + "Low_tcb_ptr \ Low_tcb_ptr + ucast (x :: 10 word)" + "High_tcb_ptr \ High_tcb_ptr + ucast (x :: 10 word)" + "idle_tcb_ptr \ idle_tcb_ptr + ucast (x :: 10 word)" + by (simp_all add: tcb_offs_min' s0_ptrs_aligned) + +lemma tcb_offs_max': + "is_aligned ptr 10 \ (ptr :: obj_ref) + ucast (x :: 10 word) \ ptr + 0x3ff" + apply (rule word_plus_mono_right) + apply (rule plus_one_helper) + apply (cut_tac ucast_less[where x=x and 'a=64]) + apply simp + apply simp + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma tcb_offs_max: + "Low_tcb_ptr + ucast (x :: 10 word) \ Low_tcb_ptr + 0x3ff" + "High_tcb_ptr + ucast (x :: 10 word) \ High_tcb_ptr + 0x3ff" + "idle_tcb_ptr + ucast (x :: 10 word) \ idle_tcb_ptr + 0x3ff" + by (simp_all add: tcb_offs_max' s0_ptrs_aligned) + +definition tcb_offs_range where + "tcb_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 10 - 1}" + +lemma tcb_offs_in_range': + "is_aligned ptr 10 \ ptr + ucast (x :: 10 word) \ tcb_offs_range ptr" + by (clarsimp simp: tcb_offs_min' tcb_offs_max' tcb_offs_range_def add.commute) + +lemma tcb_offs_in_range: + "Low_tcb_ptr + ucast (x :: 10 word) \ tcb_offs_range Low_tcb_ptr" + "High_tcb_ptr + ucast (x :: 10 word) \ tcb_offs_range High_tcb_ptr" + "idle_tcb_ptr + ucast (x :: 10 word) \ tcb_offs_range idle_tcb_ptr" + by (simp_all add: tcb_offs_in_range' s0_ptrs_aligned) + +lemma tcb_offs_range_correct': + "\ x \ tcb_offs_range ptr; is_aligned ptr 10 \ + \ \y. x = ptr + ucast (y :: 10 word)" + apply (clarsimp simp: tcb_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast (x - ptr)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (rule_tac n=10 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0x3FF" and n=10 in neg_mask_mono_le) + apply (simp add: add.commute) + apply (drule_tac n=10 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (simp add: add.commute) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma tcb_offs_range_correct: + "x \ tcb_offs_range Low_tcb_ptr \ \y. x = Low_tcb_ptr + ucast (y:: 10 word)" + "x \ tcb_offs_range High_tcb_ptr \ \y. x = High_tcb_ptr + ucast (y:: 10 word)" + "x \ tcb_offs_range idle_tcb_ptr \ \y. x = idle_tcb_ptr + ucast (y:: 10 word)" + by (simp_all add: tcb_offs_range_correct' s0_ptrs_aligned) + +lemma caps_dom_length_10: + "Silc_caps x = Some y \ length x = 10" + "High_caps x = Some y \ length x = 10" + "Low_caps x = Some y \ length x = 10" + by (auto simp: Silc_caps_def High_caps_def Low_caps_def the_nat_to_bl_def nat_to_bl_def + split: if_splits) + +lemma dom_caps: + "dom Silc_caps = {x. length x = 10}" + "dom High_caps = {x. length x = 10}" + "dom Low_caps = {x. length x = 10}" + by (auto simp: Silc_caps_def High_caps_def Low_caps_def the_nat_to_bl_def nat_to_bl_def dom_def + split: if_split_asm) + +lemmas kh0H_obj_def = + Low_cte_def High_cte_def Silc_cte_def ntfnH_def irq_cte_def Low_pdH_def + High_pdH_def Low_ptH_def High_ptH_def Low_tcbH_def High_tcbH_def idle_tcbH_def + global_ptH_def shared_pageH_def High_poolH_def Low_poolH_def + +lemmas kh0H_all_obj_def = + Low_pd'H_def High_pd'H_def Low_pt'H_def High_pt'H_def global_pteH_def global_pteH'_def + Low_cte'_def Low_capsH_def High_cte'_def High_capsH_def + Silc_cte'_def Silc_capsH_def empty_cte_def kh0H_obj_def + +lemma not_in_range_None: + "x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x = None" + "x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x = None" + "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x = None" + "x \ pt_offs_range Low_pd_ptr \ Low_pdH Low_pd_ptr x = None" + "x \ pt_offs_range High_pd_ptr \ High_pdH High_pd_ptr x = None" + "x \ pt_offs_range riscv_global_pt_ptr \ global_ptH riscv_global_pt_ptr x = None" + "x \ pt_offs_range Low_pt_ptr \ Low_ptH Low_pt_ptr x = None" + "x \ pt_offs_range High_pt_ptr \ High_ptH High_pt_ptr x = None" + "x \ page_offs_range shared_page_ptr_virt \ shared_pageH shared_page_ptr_virt x = None" + by (auto simp: page_offs_range_def cnode_offs_range_def pt_offs_range_def s0_ptr_defs kh0H_obj_def) + +lemma kh0H_dom_distinct: + "idle_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" + "High_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" + "Low_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" + "High_pool_ptr \ cnode_offs_range Silc_cnode_ptr" + "Low_pool_ptr \ cnode_offs_range Silc_cnode_ptr" + "irq_cnode_ptr \ cnode_offs_range Silc_cnode_ptr" + "ntfn_ptr \ cnode_offs_range Silc_cnode_ptr" + "idle_tcb_ptr \ cnode_offs_range Low_cnode_ptr" + "High_tcb_ptr \ cnode_offs_range Low_cnode_ptr" + "Low_tcb_ptr \ cnode_offs_range Low_cnode_ptr" + "High_pool_ptr \ cnode_offs_range Low_cnode_ptr" + "Low_pool_ptr \ cnode_offs_range Low_cnode_ptr" + "irq_cnode_ptr \ cnode_offs_range Low_cnode_ptr" + "ntfn_ptr \ cnode_offs_range Low_cnode_ptr" + "idle_tcb_ptr \ cnode_offs_range High_cnode_ptr" + "High_tcb_ptr \ cnode_offs_range High_cnode_ptr" + "Low_tcb_ptr \ cnode_offs_range High_cnode_ptr" + "High_pool_ptr \ cnode_offs_range High_cnode_ptr" + "Low_pool_ptr \ cnode_offs_range High_cnode_ptr" + "irq_cnode_ptr \ cnode_offs_range High_cnode_ptr" + "ntfn_ptr \ cnode_offs_range High_cnode_ptr" + "idle_tcb_ptr \ pt_offs_range Low_pd_ptr" + "High_tcb_ptr \ pt_offs_range Low_pd_ptr" + "Low_tcb_ptr \ pt_offs_range Low_pd_ptr" + "High_pool_ptr \ pt_offs_range Low_pd_ptr" + "Low_pool_ptr \ pt_offs_range Low_pd_ptr" + "irq_cnode_ptr \ pt_offs_range Low_pd_ptr" + "ntfn_ptr \ pt_offs_range Low_pd_ptr" + "idle_tcb_ptr \ pt_offs_range High_pd_ptr" + "High_tcb_ptr \ pt_offs_range High_pd_ptr" + "Low_tcb_ptr \ pt_offs_range High_pd_ptr" + "High_pool_ptr \ pt_offs_range High_pd_ptr" + "Low_pool_ptr \ pt_offs_range High_pd_ptr" + "irq_cnode_ptr \ pt_offs_range High_pd_ptr" + "ntfn_ptr \ pt_offs_range High_pd_ptr" + "idle_tcb_ptr \ pt_offs_range riscv_global_pt_ptr" + "High_tcb_ptr \ pt_offs_range riscv_global_pt_ptr" + "Low_tcb_ptr \ pt_offs_range riscv_global_pt_ptr" + "High_pool_ptr \ pt_offs_range riscv_global_pt_ptr" + "Low_pool_ptr \ pt_offs_range riscv_global_pt_ptr" + "irq_cnode_ptr \ pt_offs_range riscv_global_pt_ptr" + "ntfn_ptr \ pt_offs_range riscv_global_pt_ptr" + "idle_tcb_ptr \ pt_offs_range Low_pt_ptr" + "High_tcb_ptr \ pt_offs_range Low_pt_ptr" + "Low_tcb_ptr \ pt_offs_range Low_pt_ptr" + "High_pool_ptr \ pt_offs_range Low_pt_ptr" + "Low_pool_ptr \ pt_offs_range Low_pt_ptr" + "irq_cnode_ptr \ pt_offs_range Low_pt_ptr" + "ntfn_ptr \ pt_offs_range Low_pt_ptr" + "idle_tcb_ptr \ pt_offs_range High_pt_ptr" + "High_tcb_ptr \ pt_offs_range High_pt_ptr" + "Low_tcb_ptr \ pt_offs_range High_pt_ptr" + "High_pool_ptr \ pt_offs_range High_pt_ptr" + "Low_pool_ptr \ pt_offs_range High_pt_ptr" + "irq_cnode_ptr \ pt_offs_range High_pt_ptr" + "ntfn_ptr \ pt_offs_range High_pt_ptr" + "idle_tcb_ptr \ tcb_offs_range Low_tcb_ptr" + "High_tcb_ptr \ tcb_offs_range Low_tcb_ptr" + "High_pool_ptr \ tcb_offs_range Low_tcb_ptr" + "Low_pool_ptr \ tcb_offs_range Low_tcb_ptr" + "irq_cnode_ptr \ tcb_offs_range Low_tcb_ptr" + "ntfn_ptr \ tcb_offs_range Low_tcb_ptr" + "idle_tcb_ptr \ tcb_offs_range High_tcb_ptr" + "Low_tcb_ptr \ tcb_offs_range High_tcb_ptr" + "High_pool_ptr \ tcb_offs_range High_tcb_ptr" + "Low_pool_ptr \ tcb_offs_range High_tcb_ptr" + "irq_cnode_ptr \ tcb_offs_range High_tcb_ptr" + "ntfn_ptr \ tcb_offs_range High_tcb_ptr" + "High_tcb_ptr \ tcb_offs_range idle_tcb_ptr" + "Low_tcb_ptr \ tcb_offs_range idle_tcb_ptr" + "High_pool_ptr \ tcb_offs_range idle_tcb_ptr" + "Low_pool_ptr \ tcb_offs_range idle_tcb_ptr" + "irq_cnode_ptr \ tcb_offs_range idle_tcb_ptr" + "ntfn_ptr \ tcb_offs_range idle_tcb_ptr" + "idle_tcb_ptr \ page_offs_range shared_page_ptr_virt" + "High_tcb_ptr \ page_offs_range shared_page_ptr_virt" + "Low_tcb_ptr \ page_offs_range shared_page_ptr_virt" + "High_pool_ptr \ page_offs_range shared_page_ptr_virt" + "Low_pool_ptr \ page_offs_range shared_page_ptr_virt" + "irq_cnode_ptr \ page_offs_range shared_page_ptr_virt" + "ntfn_ptr \ page_offs_range shared_page_ptr_virt" + by (auto simp: tcb_offs_range_def pt_offs_range_def page_offs_range_def + cnode_offs_range_def kh0H_obj_def s0_ptr_defs) + +lemma kh0H_dom_sets_distinct: + "irq_node_offs_range \ cnode_offs_range Silc_cnode_ptr = {}" + "irq_node_offs_range \ cnode_offs_range High_cnode_ptr = {}" + "irq_node_offs_range \ cnode_offs_range Low_cnode_ptr = {}" + "irq_node_offs_range \ pt_offs_range riscv_global_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range High_pd_ptr = {}" + "irq_node_offs_range \ pt_offs_range Low_pd_ptr = {}" + "irq_node_offs_range \ pt_offs_range High_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range Low_pt_ptr = {}" + "irq_node_offs_range \ tcb_offs_range High_tcb_ptr = {}" + "irq_node_offs_range \ tcb_offs_range Low_tcb_ptr = {}" + "irq_node_offs_range \ tcb_offs_range idle_tcb_ptr = {}" + "irq_node_offs_range \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range Silc_cnode_ptr \ cnode_offs_range High_cnode_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ cnode_offs_range Low_cnode_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range riscv_global_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range High_pd_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range Low_pd_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range High_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range Low_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range High_cnode_ptr \ cnode_offs_range Low_cnode_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range riscv_global_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range High_pd_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range Low_pd_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range High_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range Low_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range High_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range High_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range High_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range riscv_global_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range High_pd_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range Low_pd_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range High_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range Low_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range riscv_global_pt_ptr \ pt_offs_range High_pd_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ pt_offs_range Low_pd_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ pt_offs_range High_pt_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ pt_offs_range Low_pt_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range riscv_global_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range High_pd_ptr \ pt_offs_range Low_pd_ptr = {}" + "pt_offs_range High_pd_ptr \ pt_offs_range High_pt_ptr = {}" + "pt_offs_range High_pd_ptr \ pt_offs_range Low_pt_ptr = {}" + "pt_offs_range High_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range High_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range High_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range High_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range Low_pd_ptr \ pt_offs_range High_pt_ptr = {}" + "pt_offs_range Low_pd_ptr \ pt_offs_range Low_pt_ptr = {}" + "pt_offs_range Low_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range Low_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range Low_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range Low_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range High_pt_ptr \ pt_offs_range Low_pt_ptr = {}" + "pt_offs_range High_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range High_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range High_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range High_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range Low_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range Low_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range Low_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range Low_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "tcb_offs_range High_tcb_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "tcb_offs_range High_tcb_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "tcb_offs_range High_tcb_ptr \ page_offs_range shared_page_ptr_virt = {}" + "tcb_offs_range Low_tcb_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "tcb_offs_range Low_tcb_ptr \ page_offs_range shared_page_ptr_virt = {}" + "page_offs_range shared_page_ptr_virt \ tcb_offs_range idle_tcb_ptr = {}" + by (rule disjointI, clarsimp simp: tcb_offs_range_def pt_offs_range_def page_offs_range_def + irq_node_offs_range_def cnode_offs_range_def s0_ptr_defs + , drule (1) order_trans le_less_trans, fastforce)+ + +lemmas offs_in_range = + pt_offs_in_range page_offs_in_range tcb_offs_in_range cnode_offs_in_range irq_node_offs_in_range + +lemmas offs_range_correct = + pt_offs_range_correct page_offs_range_correct tcb_offs_range_correct + cnode_offs_range_correct irq_node_offs_range_correct + +lemma kh0H_dom_distinct': + fixes y :: pt_index + shows + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ Low_tcb_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ High_pool_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ High_pool_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ Low_tcb_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ Low_tcb_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ High_pool_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" + "Low_pd_ptr + (ucast y << 3) \ idle_tcb_ptr" + "Low_pd_ptr + (ucast y << 3) \ High_tcb_ptr" + "Low_pd_ptr + (ucast y << 3) \ Low_tcb_ptr" + "Low_pd_ptr + (ucast y << 3) \ High_pool_ptr" + "Low_pd_ptr + (ucast y << 3) \ Low_pool_ptr" + "Low_pd_ptr + (ucast y << 3) \ irq_cnode_ptr" + "Low_pd_ptr + (ucast y << 3) \ ntfn_ptr" + "High_pd_ptr + (ucast y << 3) \ idle_tcb_ptr" + "High_pd_ptr + (ucast y << 3) \ High_tcb_ptr" + "High_pd_ptr + (ucast y << 3) \ Low_tcb_ptr" + "High_pd_ptr + (ucast y << 3) \ High_pool_ptr" + "High_pd_ptr + (ucast y << 3) \ Low_pool_ptr" + "High_pd_ptr + (ucast y << 3) \ irq_cnode_ptr" + "High_pd_ptr + (ucast y << 3) \ ntfn_ptr" + "Low_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" + "Low_pt_ptr + (ucast y << 3) \ High_tcb_ptr" + "Low_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" + "Low_pt_ptr + (ucast y << 3) \ High_pool_ptr" + "Low_pt_ptr + (ucast y << 3) \ Low_pool_ptr" + "Low_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" + "Low_pt_ptr + (ucast y << 3) \ ntfn_ptr" + "High_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" + "High_pt_ptr + (ucast y << 3) \ High_tcb_ptr" + "High_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" + "High_pt_ptr + (ucast y << 3) \ High_pool_ptr" + "High_pt_ptr + (ucast y << 3) \ Low_pool_ptr" + "High_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" + "High_pt_ptr + (ucast y << 3) \ ntfn_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ High_tcb_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ High_pool_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ Low_pool_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" + "riscv_global_pt_ptr + (ucast y << 3) \ ntfn_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ idle_tcb_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ High_tcb_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ Low_tcb_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ High_pool_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ Low_pool_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ irq_cnode_ptr" + "shared_page_ptr_virt + (ucast y << 12) \ ntfn_ptr" + apply (drule offs_in_range, fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=y in offs_in_range(1), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=y in offs_in_range(2), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=y in offs_in_range(3), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=y in offs_in_range(4), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=y in offs_in_range(5), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=y in offs_in_range(6), fastforce simp: kh0H_dom_distinct)+ + done + +lemma not_disjointI: + "\ x = y; x \ A; y \ B \ \ A \ B \ {}" + by fastforce + +lemma shared_pageH_KOUserData[simp]: + "shared_pageH shared_page_ptr_virt (shared_page_ptr_virt + (UCAST(9 \ 64) y << 12)) = Some KOUserData" + apply (clarsimp simp: shared_pageH_def page_offs_min page_offs_max add.commute) + apply (cut_tac shared_page_ptr_is_aligned) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs bit_simps) + apply word_bitwise + done + +lemma kh0H_simps[simp]: + fixes y :: pt_index + shows + "kh0H (init_irq_node_ptr + (ucast (irq :: irq) << 5)) = Some (KOCTE (CTE NullCap Null_mdb))" + "kh0H ntfn_ptr = Some (KONotification ntfnH)" + "kh0H irq_cnode_ptr = Some (KOCTE irq_cte)" + "kh0H Low_pool_ptr = Some (KOArch Low_poolH)" + "kh0H High_pool_ptr = Some (KOArch High_poolH)" + "kh0H Low_tcb_ptr = Some (KOTCB Low_tcbH)" + "kh0H High_tcb_ptr = Some (KOTCB High_tcbH)" + "kh0H idle_tcb_ptr = Some (KOTCB idle_tcbH)" + "length x = 10 \ kh0H (Low_cnode_ptr + of_bl x * 0x20) = Low_cte Low_cnode_ptr (Low_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ kh0H (High_cnode_ptr + of_bl x * 0x20) = High_cte High_cnode_ptr (High_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ kh0H (Silc_cnode_ptr + of_bl x * 0x20) = Silc_cte Silc_cnode_ptr (Silc_cnode_ptr + of_bl x * 0x20)" + "kh0H (Low_pd_ptr + (ucast y << 3)) = Low_pdH Low_pd_ptr (Low_pd_ptr + (ucast y << 3))" + "kh0H (High_pd_ptr + (ucast y << 3)) = High_pdH High_pd_ptr (High_pd_ptr + (ucast y << 3))" + "kh0H (Low_pt_ptr + (ucast y << 3)) = Low_ptH Low_pt_ptr (Low_pt_ptr + (ucast y << 3))" + "kh0H (High_pt_ptr + (ucast y << 3)) = High_ptH High_pt_ptr (High_pt_ptr + (ucast y << 3))" + "kh0H (riscv_global_pt_ptr + (ucast y << 3)) = global_ptH riscv_global_pt_ptr (riscv_global_pt_ptr + (ucast y << 3))" + "kh0H (shared_page_ptr_virt + (ucast y << 12)) = Some KOUserData" + supply option.case_cong[cong] + apply (fastforce simp: kh0H_def option_update_range_def) + by ((clarsimp simp: kh0H_def kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_None offs_in_range + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_None + | rule conjI | clarsimp split: option.splits)+, + drule not_disjointI, + (erule offs_in_range | rule offs_in_range), + (erule offs_in_range | rule offs_in_range), + erule notE, rule kh0H_dom_sets_distinct)+ + +lemma kh0H_dom: + "dom kh0H = {idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, + High_pool_ptr, Low_pool_ptr, irq_cnode_ptr, ntfn_ptr} \ + irq_node_offs_range \ + page_offs_range shared_page_ptr_virt \ + cnode_offs_range Silc_cnode_ptr \ + cnode_offs_range High_cnode_ptr \ + cnode_offs_range Low_cnode_ptr \ + pt_offs_range riscv_global_pt_ptr \ + pt_offs_range High_pd_ptr \ + pt_offs_range Low_pd_ptr \ + pt_offs_range High_pt_ptr \ + pt_offs_range Low_pt_ptr" + apply (rule equalityI) + apply (simp add: kh0H_def dom_def) + apply (clarsimp simp: offs_in_range option_update_range_def not_in_range_None split: if_split_asm) + apply (clarsimp simp: dom_def) + apply (rule conjI) + apply (force simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None + dest: irq_node_offs_range_correct split: option.splits) + by (rule conjI + | clarsimp simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None + split: option.splits + , frule offs_range_correct + , clarsimp simp: kh0H_all_obj_def cnode_offs_range_def page_offs_range_def pt_offs_range_def + split: if_split_asm)+ + +lemmas kh0H_SomeD' = set_mp[OF equalityD1[OF kh0H_dom[simplified dom_def]], OF CollectI, simplified, OF exI] + +lemma kh0H_SomeD: + "kh0H x = Some y + \ x = ntfn_ptr \ y = KONotification ntfnH \ + x = Low_tcb_ptr \ y = KOTCB Low_tcbH \ + x = High_tcb_ptr \ y = KOTCB High_tcbH \ + x = idle_tcb_ptr \ y = KOTCB idle_tcbH \ + x \ pt_offs_range riscv_global_pt_ptr \ global_ptH riscv_global_pt_ptr x \ None + \ y = the (global_ptH riscv_global_pt_ptr x) \ + x \ irq_node_offs_range \ y = KOCTE (CTE NullCap Null_mdb) \ + x \ pt_offs_range Low_pt_ptr \ Low_ptH Low_pt_ptr x \ None \ y = the (Low_ptH Low_pt_ptr x) \ + x \ pt_offs_range High_pt_ptr \ High_ptH High_pt_ptr x \ None \ y = the (High_ptH High_pt_ptr x) \ + x \ pt_offs_range Low_pd_ptr \ Low_pdH Low_pd_ptr x \ None \ y = the (Low_pdH Low_pd_ptr x) \ + x \ pt_offs_range High_pd_ptr \ High_pdH High_pd_ptr x \ None \ y = the (High_pdH High_pd_ptr x) \ + x = Low_pool_ptr \ y = KOArch Low_poolH \ + x = High_pool_ptr \ y = KOArch High_poolH \ + x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x \ None \ y = the (Low_cte Low_cnode_ptr x) \ + x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x \ None \ y = the (High_cte High_cnode_ptr x) \ + x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x \ None \ y = the (Silc_cte Silc_cnode_ptr x) \ + x = irq_cnode_ptr \ y = KOCTE irq_cte \ + x \ page_offs_range shared_page_ptr_virt \ y = KOUserData" + apply (frule kh0H_SomeD') + apply (elim disjE) + by ((clarsimp | drule offs_range_correct)+) + + +definition arch_state0H :: Arch.kernel_state where + "arch_state0H \ + RISCVKernelState [ucast (asid_high_bits_of Low_asid) \ Low_pool_ptr, + ucast (asid_high_bits_of High_asid) \ High_pool_ptr] + (\level. if level = maxPTLevel then [riscv_global_pt_ptr] else []) + init_vspace_uses" + +definition s0H_internal :: "kernel_state" where + "s0H_internal \ \ + ksPSpace = kh0H, + gsUserPages = [shared_page_ptr_virt \ RISCVLargePage], + gsCNodes = (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some 0 else None) + (Low_cnode_ptr \ 10, + High_cnode_ptr \ 10, + Silc_cnode_ptr \ 10, + irq_cnode_ptr \ 0), + gsUntypedZeroRanges = ran (map_comp untypedZeroRange (option_map cteCap o map_to_ctes kh0H)), + gsMaxObjectSize = card (UNIV :: obj_ref set), + ksDomScheduleIdx = 0, + ksDomSchedule = [(0, 10), (1, 10)], + ksCurDomain = 0, + ksDomainTime = 5, + ksReadyQueues = const (TcbQueue None None), + ksReadyQueuesL1Bitmap = const 0, + ksReadyQueuesL2Bitmap = const 0, + ksCurThread = Low_tcb_ptr, + ksIdleThread = idle_tcb_ptr, + ksSchedulerAction = ResumeCurrentThread, + ksInterruptState = InterruptState init_irq_node_ptr ((\_. IRQInactive) (timer_irq := IRQTimer)), + ksWorkUnitsCompleted = undefined, + ksArchState = arch_state0H, + ksMachineState = machine_state0\" + + +definition Low_cte_cte :: "obj_ref \ obj_ref \ cte option" where + "Low_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then Low_cte' (ucast (offs - base >> 5)) else None" + +definition High_cte_cte :: "obj_ref \ obj_ref \ cte option" where + "High_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then High_cte' (ucast (offs - base >> 5)) else None" + +definition Silc_cte_cte :: "obj_ref \ obj_ref \ cte option" where + "Silc_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then Silc_cte' (ucast (offs - base >> 5)) else None" + +definition Low_tcb_cte :: "obj_ref \ cte option" where + "Low_tcb_cte \ [Low_tcb_ptr \ tcbCTable Low_tcbH, + Low_tcb_ptr + 0x20 \ tcbVTable Low_tcbH, + Low_tcb_ptr + 0x40 \ tcbReply Low_tcbH, + Low_tcb_ptr + 0x60 \ tcbCaller Low_tcbH, + Low_tcb_ptr + 0x80 \ tcbIPCBufferFrame Low_tcbH]" + +definition High_tcb_cte :: "obj_ref \ cte option" where + "High_tcb_cte \ [High_tcb_ptr \ tcbCTable High_tcbH, + High_tcb_ptr + 0x20 \ tcbVTable High_tcbH, + High_tcb_ptr + 0x40 \ tcbReply High_tcbH, + High_tcb_ptr + 0x60 \ tcbCaller High_tcbH, + High_tcb_ptr + 0x80 \ tcbIPCBufferFrame High_tcbH]" + +definition idle_tcb_cte :: "obj_ref \ cte option" where + "idle_tcb_cte \ [idle_tcb_ptr \ tcbCTable idle_tcbH, + idle_tcb_ptr + 0x20 \ tcbVTable idle_tcbH, + idle_tcb_ptr + 0x40 \ tcbReply idle_tcbH, + idle_tcb_ptr + 0x60 \ tcbCaller idle_tcbH, + idle_tcb_ptr + 0x80 \ tcbIPCBufferFrame idle_tcbH]" + + +lemma not_in_range_cte_None: + "x \ cnode_offs_range Low_cnode_ptr \ Low_cte_cte Low_cnode_ptr x = None" + "x \ cnode_offs_range High_cnode_ptr \ High_cte_cte High_cnode_ptr x = None" + "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte_cte Silc_cnode_ptr x = None" + "x \ tcb_offs_range Low_tcb_ptr \ Low_tcb_cte x = None" + "x \ tcb_offs_range High_tcb_ptr \ High_tcb_cte x = None" + "x \ tcb_offs_range idle_tcb_ptr \ idle_tcb_cte x = None" + by (fastforce simp: cnode_offs_range_def page_offs_range_def tcb_offs_range_def s0_ptr_defs Low_cte_cte_def + High_cte_cte_def Silc_cte_cte_def Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def)+ + +lemma mask_neg_le: + "x && ~~ mask n \ x" + apply (clarsimp simp: neg_mask_is_div) + apply (rule word_div_mult_le) + done + +lemma mask_in_tcb_offs_range: + "x && ~~ mask 10 = ptr \ x \ tcb_offs_range ptr" + apply (clarsimp simp: tcb_offs_range_def mask_neg_le objBitsKO_def) + apply (cut_tac and_neg_mask_plus_mask_mono[where p=x and n=10]) + apply (simp add: add.commute mask_def) + done + +lemma set_mem_neq: + "\ y \ S; x \ S \ \ x \ y" + by fastforce + +lemma neg_mask_decompose: + "x && ~~ mask n = ptr \ x = ptr + (x && mask n)" + by (clarsimp simp: AND_NOT_mask_plus_AND_mask_eq) + +lemma opt_None_not_dom: + "m a = None \ a \ dom m" + by (simp add: dom_def) + +lemma tcb_offs_range_mask_eq: + "\ x \ tcb_offs_range ptr; is_aligned ptr 10 \ \ x && ~~ mask 10 = ptr" + apply (drule(1) tcb_offs_range_correct') + apply (clarsimp simp: objBitsKO_def) + apply (drule_tac d="ucast y" in is_aligned_add_helper) + apply (cut_tac x=y and 'a=64 in ucast_less) + apply simp + apply simp + apply simp + done + +lemma not_in_tcb_offs: + "\tcb. kh0H (x && ~~ mask 10) \ Some (KOTCB tcb) + \ x \ tcb_offs_range Low_tcb_ptr" + "\tcb. kh0H (x && ~~ mask 10) \ Some (KOTCB tcb) + \ x \ tcb_offs_range High_tcb_ptr" + "\tcb. kh0H (x && ~~ mask 10) \ Some (KOTCB tcb) + \ x \ tcb_offs_range idle_tcb_ptr" + by (fastforce simp: s0_ptrs_aligned dest: tcb_offs_range_mask_eq)+ + +lemma range_tcb_not_kh0H_dom: + "{(x && ~~ mask 10) + 1..(x && ~~ mask 10) + 2 ^ 10 - 1} \ dom kh0H \ {} \ (x && ~~ mask 10) \ High_tcb_ptr" + "{(x && ~~ mask 10) + 1..(x && ~~ mask 10) + 2 ^ 10 - 1} \ dom kh0H \ {} \ (x && ~~ mask 10) \ Low_tcb_ptr" + "{(x && ~~ mask 10) + 1..(x && ~~ mask 10) + 2 ^ 10 - 1} \ dom kh0H \ {} \ (x && ~~ mask 10) \ idle_tcb_ptr" + apply clarsimp + apply (drule int_not_emptyD) + apply (clarsimp simp: kh0H_dom) + apply (subgoal_tac "xa \ tcb_offs_range High_tcb_ptr") + prefer 2 + apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) + apply (rule_tac y="High_tcb_ptr + 1" in order_trans) + apply (simp add: s0_ptr_defs) + apply simp + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] + apply (clarsimp simp: s0_ptr_defs tcb_offs_range_def) + apply clarsimp + apply (drule int_not_emptyD) + apply (clarsimp simp: kh0H_dom) + apply (subgoal_tac "xa \ tcb_offs_range Low_tcb_ptr") + prefer 2 + apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) + apply (rule_tac y="Low_tcb_ptr + 1" in order_trans) + apply (simp add: s0_ptr_defs) + apply simp + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] + apply (clarsimp simp: s0_ptr_defs tcb_offs_range_def) + apply clarsimp + apply (drule int_not_emptyD) + apply (clarsimp simp: kh0H_dom) + apply (subgoal_tac "xa \ tcb_offs_range idle_tcb_ptr") + prefer 2 + apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) + apply (rule_tac y="idle_tcb_ptr + 1" in order_trans) + apply (simp add: s0_ptr_defs) + apply simp + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] + apply (clarsimp simp: s0_ptr_defs tcb_offs_range_def) + done + +lemma kh0H_dom_tcb: + "kh0H x = Some (KOTCB tcb) + \ x = Low_tcb_ptr \ x = High_tcb_ptr \ x = idle_tcb_ptr" + apply (frule domI[where m="kh0H"]) + apply (simp add: kh0H_dom) + apply (elim disjE) + by (auto dest: offs_range_correct simp: kh0H_all_obj_def s0_ptrs_aligned split: if_split_asm) + +lemma map_to_ctes_kh0H: + "map_to_ctes kh0H = + (option_update_range + (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some (CTE NullCap Null_mdb) else None) \ + option_update_range (Low_cte_cte Low_cnode_ptr) \ + option_update_range (High_cte_cte High_cnode_ptr) \ + option_update_range (Silc_cte_cte Silc_cnode_ptr) \ + option_update_range [irq_cnode_ptr \ CTE NullCap Null_mdb] \ + option_update_range Low_tcb_cte \ + option_update_range High_tcb_cte \ + option_update_range idle_tcb_cte + ) Map.empty" + supply option.case_cong[cong] if_cong[cong] + supply objBits_defs[simp] + apply (rule ext) + apply (case_tac "kh0H x") + apply (clarsimp simp add: map_to_ctes_def Let_def objBitsKO_def) + apply (rule conjI) + apply clarsimp + apply (thin_tac "x \ y = {}" for x y) + apply (frule kh0H_dom_tcb) + apply (elim disjE) + apply (clarsimp simp: option_update_range_def) + apply (frule mask_in_tcb_offs_range) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply (simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+ + apply (rule conjI, clarsimp) + apply (clarsimp split: option.splits) + apply (rule conjI) + apply (fastforce simp: tcb_cte_cases_def Low_tcb_cte_def dest: neg_mask_decompose) + subgoal by (fastforce simp: Low_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) + apply (clarsimp simp: option_update_range_def) + apply (frule mask_in_tcb_offs_range) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply (simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+ + apply (rule conjI, clarsimp) + apply clarsimp + apply (clarsimp split: option.splits) + apply (rule conjI) + apply (fastforce simp: tcb_cte_cases_def High_tcb_cte_def dest: neg_mask_decompose) + subgoal by (fastforce simp: High_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) + apply (clarsimp simp: option_update_range_def) + apply (frule mask_in_tcb_offs_range) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply (simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+ + apply (rule conjI, clarsimp) + apply clarsimp + apply (clarsimp split: option.splits) + apply (rule conjI) + apply (fastforce simp: tcb_cte_cases_def idle_tcb_cte_def dest: neg_mask_decompose) + subgoal by (fastforce simp: idle_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) + apply (drule_tac m="kh0H" in opt_None_not_dom) + apply (rule conjI) + apply (clarsimp simp: kh0H_dom option_update_range_def) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_tcb_offs not_in_range_cte_None offs_in_range + | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+)[1] + apply (rule impI) + apply (frule range_tcb_not_kh0H_dom(1)[simplified]) + apply (frule range_tcb_not_kh0H_dom(2)[simplified]) + apply (drule range_tcb_not_kh0H_dom(3)[simplified]) + apply (clarsimp simp: kh0H_dom split del: if_split) + apply (clarsimp simp: option_update_range_def) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_tcb_offs not_in_range_cte_None offs_in_range + | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+)[1] + apply (subst not_in_range_cte_None, + clarsimp simp: tcb_offs_range_mask_eq s0_ptrs_aligned)+ + apply (clarsimp simp: irq_node_offs_in_range) + apply (frule kh0H_SomeD) + apply (elim disjE) + defer + apply ((clarsimp simp: map_to_ctes_def Let_def split del: if_split, + subst if_split_eq1, rule conjI, rule impI, + (subst is_aligned_neg_mask_eq, simp add: is_aligned_def s0_ptr_defs objBitsKO_def)+, + ((clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None | + clarsimp simp: idle_tcb_cte_def High_tcb_cte_def Low_tcb_cte_def)+)[1], + rule impI, + (subst (asm) is_aligned_neg_mask_eq, simp add: is_aligned_def s0_ptr_defs objBitsKO_def)+, + clarsimp, + clarsimp simp: kh0H_dom objBitsKO_def s0_ptr_defs irq_node_offs_range_def + cnode_offs_range_def pt_offs_range_def page_offs_range_def, + rule FalseE, drule int_not_emptyD, clarsimp, + (elim disjE, (clarsimp | drule(1) order_trans le_less_trans, fastforce)+)[1])+)[3] + defer 2 + apply ((clarsimp simp: map_to_ctes_def Let_def split del: if_split, + subst if_split_eq1, rule conjI, rule impI, drule pt_offs_range_correct, + clarsimp simp: kh0H_obj_def kh0H_dom_distinct option_update_range_def not_in_range_cte_None, + rule impI, subst if_split_eq1, rule conjI, rule impI, rule FalseE, + drule pt_offs_range_correct, clarsimp, cut_tac x=ya and 'a=64 in ucast_less, + simp, drule shiftl_less_t2n'[where n=3], simp, simp, + drule plus_one_helper[where n="0xFFF", simplified], drule kh0H_dom_tcb, + (elim disjE, (clarsimp simp: s0_ptr_defs objBitsKO_def, + erule notE[rotated], + rule_tac a="x::obj_ref" for x in dual_order.strict_implies_not_eq, + rule less_le_trans[rotated, OF aligned_le_sharp], + erule word_plus_mono_right2[rotated], + simp, simp add: is_aligned_def, simp)+)[1], + rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct[THEN set_mem_neq] not_in_range_cte_None, + ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None irq_node_offs_in_range | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1])+)[5] + prefer 8 + apply ((clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split, + subst if_split_eq1, rule conjI, + clarsimp, drule kh0H_dom_tcb, fastforce simp: s0_ptr_defs mask_def objBitsKO_def, + fastforce simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None)+)[3] + apply ((clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def objBitsKO_def + split: if_split_asm split del: if_split, + subst if_split_eq1, rule conjI, rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None, + (clarsimp simp: option_update_range_def kh0H_dom_distinct[THEN set_mem_neq] + kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+, + rule conjI, clarsimp, drule offs_range_correct, + fastforce simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def, + rule impI, rule FalseE, drule offs_range_correct, + clarsimp simp: Low_cte_def High_cte_def Silc_cte_def cnode_offs_min cnode_offs_max, + cut_tac x="of_bl y" and z="0x20::obj_ref" and y="2 ^ 15 - 1" in div_to_mult_word_lt, + frule_tac 'a=64 in of_bl_length_le, simp, simp, drule int_not_emptyD, + clarsimp simp: kh0H_dom s0_ptr_defs cnode_offs_range_def page_offs_range_def + pt_offs_range_def irq_node_offs_range_def, + (elim disjE, (clarsimp simp: s0_ptr_defs, + drule_tac b="x + y * 0x20" and n=5 for x y in aligned_le_sharp, + fastforce simp: is_aligned_def, clarsimp simp: add.commute, + subst (asm) mask_out_add_aligned[symmetric], + simp add: is_aligned_mult_triv2[where n=5, simplified], + simp add: mask_def, drule word_leq_le_minus_one, + subst add.commute, rule neq_0_no_wrap, + erule word_plus_mono_right2[rotated], + fastforce, fastforce, fastforce simp: add.commute | unat_arith)+)[1])+)[3] + apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split, + subst if_split_eq1, rule conjI, rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None, rule impI, + clarsimp simp: kh0H_dom objBitsKO_def s0_ptr_defs is_aligned_def page_offs_range_def + cnode_offs_range_def pt_offs_range_def irq_node_offs_range_def, + rule FalseE, drule int_not_emptyD, clarsimp, + (elim disjE, (clarsimp | drule(1) order_trans le_less_trans, fastforce)+)[1]) + apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split) + apply (subst if_split_eq1) + apply (rule conjI, clarsimp) + apply (fastforce dest: kh0H_dom_tcb simp: page_offs_range_def objBitsKO_def) + apply (clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None) + apply (rule conjI; clarsimp) + apply (rule conjI; clarsimp) + apply (subst is_aligned_neg_mask_eq, clarsimp simp: objBitsKO_def page_offs_range_def is_aligned_weaken)+ + apply (clarsimp split: option.splits) + apply (intro conjI impI; drule kh0H_dom_sets_distinct[THEN orthD2] + kh0H_dom_sets_distinct[THEN orthD1], + drule not_in_range_cte_None, solves clarsimp) + apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split) + apply (frule irq_node_offs_range_correct) + apply (subst if_split_eq1) + apply (rule conjI) + apply (rule impI) + apply (clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None) + apply fastforce + apply (rule impI) + apply clarsimp + apply (erule impE) + apply (rule is_aligned_add) + apply (simp add: is_aligned_def s0_ptr_defs objBitsKO_def) + apply (rule is_aligned_shiftl) + apply (clarsimp simp: objBitsKO_def) + apply (rule FalseE) + apply (clarsimp simp: s0_ptr_defs cnode_offs_range_def page_offs_range_def pt_offs_range_def + irq_node_offs_range_def objBitsKO_def kh0H_dom) + apply (cut_tac x=irq and 'a=64 in ucast_less) + apply simp + apply (drule shiftl_less_t2n'[where n=5]) + apply simp + apply simp + apply (drule plus_one_helper[where n="0x7FF", simplified]) + apply (elim disjE) + apply (unat_arith+)[7] + apply (drule int_not_emptyD) + apply clarsimp + apply (elim disjE, + ((clarsimp, + drule(1) aligned_le_sharp, + clarsimp simp: add.commute, + subst(asm) mask_out_add_aligned[symmetric], + simp add: is_aligned_shiftl, + simp add: mask_def, + drule word_leq_le_minus_one, + subst add.commute, + rule neq_0_no_wrap, + erule word_plus_mono_right2[rotated], + fastforce, + fastforce, + fastforce simp: add.commute) + | unat_arith)+)[1] + done + +lemma option_update_range_map_comp: + "option_update_range m m' = map_add m' m" + by (simp add: fun_eq_iff option_update_range_def map_comp_def map_add_def split: option.split) + +lemma tcb_offs_in_rangeI: + "\ ptr \ ptr + x; ptr + x \ ptr + 2 ^ 10 - 1 \ \ ptr + x \ tcb_offs_range ptr" + by (simp add: tcb_offs_range_def) + +lemma map_to_ctes_kh0H_simps[simp]: + "map_to_ctes kh0H (init_irq_node_ptr + (ucast (irq :: irq) << 5)) = Some (CTE NullCap Null_mdb)" + "map_to_ctes kh0H irq_cnode_ptr = Some (CTE NullCap Null_mdb)" + "length x = 10 \ map_to_ctes kh0H (Low_cnode_ptr + of_bl x * 0x20) = + Low_cte_cte Low_cnode_ptr (Low_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ map_to_ctes kh0H (High_cnode_ptr + of_bl x * 0x20) = + High_cte_cte High_cnode_ptr (High_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ map_to_ctes kh0H (Silc_cnode_ptr + of_bl x * 0x20) = + Silc_cte_cte Silc_cnode_ptr (Silc_cnode_ptr + of_bl x * 0x20)" + "map_to_ctes kh0H Low_tcb_ptr = Low_tcb_cte Low_tcb_ptr" + "map_to_ctes kh0H (Low_tcb_ptr + 0x20) = Low_tcb_cte (Low_tcb_ptr + 0x20)" + "map_to_ctes kh0H (Low_tcb_ptr + 0x40) = Low_tcb_cte (Low_tcb_ptr + 0x40)" + "map_to_ctes kh0H (Low_tcb_ptr + 0x60) = Low_tcb_cte (Low_tcb_ptr + 0x60)" + "map_to_ctes kh0H (Low_tcb_ptr + 0x80) = Low_tcb_cte (Low_tcb_ptr + 0x80)" + "map_to_ctes kh0H High_tcb_ptr = High_tcb_cte High_tcb_ptr" + "map_to_ctes kh0H (High_tcb_ptr + 0x20) = High_tcb_cte (High_tcb_ptr + 0x20)" + "map_to_ctes kh0H (High_tcb_ptr + 0x40) = High_tcb_cte (High_tcb_ptr + 0x40)" + "map_to_ctes kh0H (High_tcb_ptr + 0x60) = High_tcb_cte (High_tcb_ptr + 0x60)" + "map_to_ctes kh0H (High_tcb_ptr + 0x80) = High_tcb_cte (High_tcb_ptr + 0x80)" + "map_to_ctes kh0H idle_tcb_ptr = idle_tcb_cte idle_tcb_ptr" + "map_to_ctes kh0H (idle_tcb_ptr + 0x20) = idle_tcb_cte (idle_tcb_ptr + 0x20)" + "map_to_ctes kh0H (idle_tcb_ptr + 0x40) = idle_tcb_cte (idle_tcb_ptr + 0x40)" + "map_to_ctes kh0H (idle_tcb_ptr + 0x60) = idle_tcb_cte (idle_tcb_ptr + 0x60)" + "map_to_ctes kh0H (idle_tcb_ptr + 0x80) = idle_tcb_cte (idle_tcb_ptr + 0x80)" + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def) + apply fastforce + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def kh0H_dom_distinct not_in_range_cte_None) + apply ((clarsimp simp: option_update_range_def not_in_range_cte_None cnode_offs_in_range + kh0H_dom_distinct kh0H_dom_distinct' map_to_ctes_kh0H s0_ptrs_aligned, + ((clarsimp simp: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None | + clarsimp simp: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1], + intro conjI, + (clarsimp, drule not_disjointI, + (erule offs_in_range | rule offs_in_range), + (erule offs_in_range | rule offs_in_range), + erule notE, rule kh0H_dom_sets_distinct)+, + clarsimp split: option.splits)+)[3] + apply (clarsimp simp: option_update_range_def not_in_range_cte_None + map_to_ctes_kh0H kh0H_dom_distinct split: option.splits) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x20" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: not_in_range_cte_None option_update_range_def + map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x40" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x60" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x80" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def kh0H_dom_distinct not_in_range_cte_None split: option.splits) + apply (cut_tac ptr="High_tcb_ptr" and x="0x20" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="High_tcb_ptr" and x="0x40" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="High_tcb_ptr" and x="0x60" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="High_tcb_ptr" and x="0x80" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def kh0H_dom_distinct not_in_range_cte_None split: option.splits) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x20" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x40" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x60" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x80" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + by (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + +lemma map_to_ctes_kh0H_dom: + "dom (map_to_ctes kh0H) = {idle_tcb_ptr, idle_tcb_ptr + 0x20, idle_tcb_ptr + 0x40, + idle_tcb_ptr + 0x60, idle_tcb_ptr + 0x80, + Low_tcb_ptr, Low_tcb_ptr + 0x20, Low_tcb_ptr + 0x40, + Low_tcb_ptr + 0x60, Low_tcb_ptr + 0x80, + High_tcb_ptr, High_tcb_ptr + 0x20, High_tcb_ptr + 0x40, + High_tcb_ptr + 0x60, High_tcb_ptr + 0x80, + irq_cnode_ptr} + \ irq_node_offs_range + \ cnode_offs_range Silc_cnode_ptr + \ cnode_offs_range High_cnode_ptr + \ cnode_offs_range Low_cnode_ptr" + supply option.case_cong[cong] if_cong[cong] + apply (rule equalityI) + apply (simp add: map_to_ctes_kh0H dom_def) + apply clarsimp + apply (clarsimp simp: offs_in_range option_update_range_def split: option.splits if_split_asm) + apply (clarsimp simp: idle_tcb_cte_def) + apply (clarsimp simp: High_tcb_cte_def) + apply (clarsimp simp: Low_tcb_cte_def) + apply (clarsimp simp: Silc_cte_cte_def cnode_offs_range_def split: if_split_asm) + apply (clarsimp simp: High_cte_cte_def cnode_offs_range_def split: if_split_asm) + apply (clarsimp simp: Low_cte_cte_def cnode_offs_range_def split: if_split_asm) + apply (clarsimp simp: dom_def) + apply (clarsimp simp: idle_tcb_cte_def Low_tcb_cte_def High_tcb_cte_def) + apply (rule conjI) + apply (fastforce dest: irq_node_offs_range_correct) + apply (rule conjI) + apply clarsimp + apply (frule cnode_offs_range_correct) + apply (clarsimp simp: Silc_cte_cte_def Silc_cte'_def Silc_capsH_def empty_cte_def cnode_offs_range_def) + apply (rule conjI) + apply clarsimp + apply (frule cnode_offs_range_correct) + apply (clarsimp simp: High_cte_cte_def High_cte'_def High_capsH_def empty_cte_def cnode_offs_range_def) + apply clarsimp + apply (frule cnode_offs_range_correct) + apply (clarsimp simp: Low_cte_cte_def Low_cte'_def Low_capsH_def empty_cte_def cnode_offs_range_def) + done + +lemmas map_to_ctes_kh0H_SomeD' = + set_mp[OF equalityD1[OF map_to_ctes_kh0H_dom[simplified dom_def]], OF CollectI, simplified, OF exI] + +lemma map_to_ctes_kh0H_SomeD: + "map_to_ctes kh0H x = Some y + \ x = idle_tcb_ptr \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x20 \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x40 \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ + x = Low_tcb_ptr \ y = (CTE (CNodeCap Low_cnode_ptr 10 2 10) (MDB (Low_cnode_ptr + 0x40) 0 False False)) \ + x = Low_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid,0)))) + (MDB (Low_cnode_ptr + 0x60) 0 False False)) \ + x = Low_tcb_ptr + 0x40 \ y = (CTE (ReplyCap Low_tcb_ptr True True) (MDB 0 0 True True)) \ + x = Low_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ + x = Low_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ + x = High_tcb_ptr \ y = (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB (High_cnode_ptr + 0x40) 0 False False)) \ + x = High_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) + (MDB (High_cnode_ptr + 0x60) 0 False False)) \ + x = High_tcb_ptr + 0x40 \ y = (CTE (ReplyCap High_tcb_ptr True True) (MDB 0 0 True True)) \ + x = High_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ + x = High_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ + x = irq_cnode_ptr \ y = (CTE NullCap Null_mdb) \ + x \ irq_node_offs_range \ y = (CTE NullCap Null_mdb) \ + x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte_cte Silc_cnode_ptr x \ None + \ y = the (Silc_cte_cte Silc_cnode_ptr x) \ + x \ cnode_offs_range High_cnode_ptr \ High_cte_cte High_cnode_ptr x \ None \ y = the (High_cte_cte High_cnode_ptr x) \ + x \ cnode_offs_range Low_cnode_ptr \ Low_cte_cte Low_cnode_ptr x \ None \ y = the (Low_cte_cte Low_cnode_ptr x)" + apply (frule map_to_ctes_kh0H_SomeD') + apply (erule disjE, rule disjI1, clarsimp simp: idle_tcb_cte_def idle_tcbH_def + Low_tcb_cte_def Low_tcbH_def Low_capsH_def + High_tcb_cte_def High_tcbH_def High_capsH_def + the_nat_to_bl_def nat_to_bl_def, rule disjI2)+ + apply ((erule disjE)?, drule offs_range_correct, clarsimp simp: offs_in_range)+ + done + +lemma mask_neg_add_aligned: + "is_aligned q n \ p + q && ~~ mask n = (p && ~~ mask n) + q" + apply (subst add.commute) + apply (simp add: mask_out_add_aligned[symmetric]) + done + +lemma mask_neg_add_aligned': + "is_aligned q n \ q + p && ~~ mask n = (p && ~~ mask n) + q" + by (simp add: mask_out_add_aligned[symmetric]) + +lemma kh_s0H[simp]: + "ksPSpace s0H_internal = kh0H" + by (simp add: s0H_internal_def) + +lemma pspace_distinct'_split: + notes less_1_simp[simp del] shows + "(\(y, ko) \ graph_of (ksPSpace ks). (x \ y \ y + (1 << objBitsKO ko) - 1 < x) + \ y \ y + (1 << objBitsKO ko) - 1) + \ pspace_distinct' (ks \ksPSpace := restrict_map (ksPSpace ks) {..< x}\) + \ pspace_distinct' (ks \ksPSpace := restrict_map (ksPSpace ks) {x ..}\) + \ pspace_distinct' ks" + apply (clarsimp simp: pspace_distinct'_def) + apply (drule bspec, erule graph_ofI, clarsimp) + apply (simp add: Ball_def) + apply (drule_tac x=xa in spec)+ + apply (erule disjE) + apply (simp add: domI) + apply (thin_tac "P \ Q" for P Q) + apply (simp add: ps_clear_def) + apply (erule trans[rotated]) + apply auto[1] + apply (clarsimp simp add: domI) + apply (drule mp, erule(1) order_le_less_trans) + apply (thin_tac "P \ Q" for P Q) + apply (simp add: ps_clear_def) + apply (erule trans[rotated]) + apply (fastforce simp: mask_eq_exp_minus_1 add_diff_eq) + done + +lemma irq_node_offs_range_def2: + "irq_node_offs_range = {x. init_irq_node_ptr \ x \ x \ init_irq_node_ptr + 0x7E0} \ + {x. is_aligned x 5}" + apply (safe, simp_all add: irq_node_offs_range_def add.commute) + by (auto dest: word_less_sub_1 simp: s0_ptr_defs elim: dual_order.strict_trans2[rotated]) + +(* FIXME IF: fix repetitiveness *) +lemma s0H_pspace_distinct': + notes pteBits_def[simp] objBits_defs[simp] + shows "pspace_distinct' s0H_internal" + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: pspace_distinct'_def ps_clear_def mask_eq_exp_minus_1) + apply (rule disjointI) + apply clarsimp + apply (drule kh0H_SomeD)+ + \ \ntfn_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \Low_tcb_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \High_tcb_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \Idle_tcb_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \riscv_global_pt_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[4] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \irq_node_offs_range\ + apply (erule_tac P="_ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[5] + apply (clarsimp simp: irq_node_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def + split: if_split_asm; + (drule(1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Low_pt_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[6] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \High_pt_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[7] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Low_pd_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[8] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \High_pd_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[9] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Low_pool_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal for x y ya yb + by ((elim disjE; clarsimp), + ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def cnode_offs_range_def + page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, + (thin_tac "ya \ _", drule dual_order.trans, assumption | + thin_tac "_ \ ya", drule dual_order.trans, assumption)?, + solves \clarsimp simp: s0_ptr_defs bit_simps\)+)) + \ \High_pool_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal for x y ya yb + by ((elim disjE; clarsimp), + ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def cnode_offs_range_def + page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, + (thin_tac "ya \ _", drule dual_order.trans, assumption | + thin_tac "_ \ ya", drule dual_order.trans, assumption)?, + solves \clarsimp simp: s0_ptr_defs bit_simps\)+)) + \ \Low_cnode_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 + pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[12] + apply (clarsimp simp: objBitsKO_def kh0H_obj_def Low_cte'_def Low_capsH_def cnode_offs_range_def + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \High_cnode_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 + pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[13] + apply (clarsimp simp: objBitsKO_def kh0H_obj_def High_cte'_def High_capsH_def cnode_offs_range_def + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Silc_cnode_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 + pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[14] + apply (clarsimp simp: objBitsKO_def kh0H_obj_def Silc_cte'_def Silc_capsH_def cnode_offs_range_def + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \irq_cnode_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal for x y ya yb + by ((elim disjE; clarsimp), + ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def cnode_offs_range_def + page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, + (thin_tac "ya \ _", drule dual_order.trans, assumption | + thin_tac "_ \ ya", drule dual_order.trans, assumption)?, + solves \clarsimp simp: s0_ptr_defs bit_simps\)+)) + \ \shared_page_ptr\ + apply (elim disjE; clarsimp) + apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 + page_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[16] + apply (clarsimp simp: page_offs_range_def objBitsKO_def archObjSize_def bit_simps) + apply (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def) + done + +lemma pspace_distinctD'': + "\ \v. ksPSpace s x = Some v \ objBitsKO v = n; pspace_distinct' s \ + \ ps_clear x n s" + apply clarsimp + apply (drule(1) pspace_distinctD') + apply simp + done + +lemma cnode_offs_min2': + "is_aligned ptr 15 \ (ptr :: obj_ref) \ ptr + 0x20 * (x && mask 10)" + apply (erule is_aligned_no_wrap') + apply (subst mult.commute) + apply (rule div_lt_mult) + apply (cut_tac and_mask_less'[where n=10]) + apply simp + apply simp + apply simp + done + +lemma cnode_offs_min2: + "Low_cnode_ptr \ Low_cnode_ptr + 0x20 * (x && mask 10)" + "High_cnode_ptr \ High_cnode_ptr + 0x20 * (x && mask 10)" + "Silc_cnode_ptr \ Silc_cnode_ptr + 0x20 * (x && mask 10)" + by (simp_all add: cnode_offs_min2' s0_ptrs_aligned) + +lemma cnode_offs_max2': + "is_aligned ptr 15 \ (ptr::obj_ref) + 0x20 * (x && mask 10) \ ptr + 0x7fff" + apply (rule word_plus_mono_right) + apply (subst mult.commute) + apply (rule div_to_mult_word_lt) + apply simp + apply (rule plus_one_helper) + apply simp + apply (cut_tac and_mask_less'[where n=10]) + apply simp + apply simp + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma cnode_offs_max2: + "Low_cnode_ptr + 0x20 * (x && mask 10) \ Low_cnode_ptr + 0x7fff" + "High_cnode_ptr + 0x20 * (x && mask 10) \ High_cnode_ptr + 0x7fff" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ Silc_cnode_ptr + 0x7fff" + by (simp_all add: cnode_offs_max2' s0_ptrs_aligned) + +lemma cnode_offs_in_range2': + "is_aligned ptr 15 \ ptr + 0x20 * (x && mask 10) \ cnode_offs_range ptr" + apply (clarsimp simp: cnode_offs_min2' cnode_offs_max2' cnode_offs_range_def add.commute) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (rule_tac is_aligned_mult_triv1[where n=5, simplified]) + done + +lemma cnode_offs_in_range2: + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ cnode_offs_range Silc_cnode_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ cnode_offs_range Low_cnode_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ cnode_offs_range High_cnode_ptr" + by (simp_all add: cnode_offs_in_range2' s0_ptrs_aligned)+ + +lemma kh0H_dom_distinct2: + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ idle_tcb_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ High_tcb_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ Low_tcb_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ High_pool_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ Low_pool_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ irq_cnode_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ ntfn_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ idle_tcb_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ High_tcb_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ Low_tcb_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ High_pool_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ Low_pool_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ irq_cnode_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ ntfn_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ idle_tcb_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ High_tcb_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ Low_tcb_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ High_pool_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ Low_pool_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ irq_cnode_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ ntfn_ptr" + by (cut_tac x=x in cnode_offs_in_range2(1), fastforce simp: kh0H_dom_distinct + | cut_tac x=x in cnode_offs_in_range2(2), fastforce simp: kh0H_dom_distinct + | cut_tac x=x in cnode_offs_in_range2(3), fastforce simp: kh0H_dom_distinct)+ + +lemma kh0H_cnode_simps2[simp]: + "kh0H (Low_cnode_ptr + 0x20 * (x && mask 10)) = Low_cte Low_cnode_ptr (Low_cnode_ptr + 0x20 * (x && mask 10))" + "kh0H (High_cnode_ptr + 0x20 * (x && mask 10)) = High_cte High_cnode_ptr (High_cnode_ptr + 0x20 * (x && mask 10))" + "kh0H (Silc_cnode_ptr + 0x20 * (x && mask 10)) = Silc_cte Silc_cnode_ptr (Silc_cnode_ptr + 0x20 * (x && mask 10))" + supply option.case_cong[cong] if_cong[cong] + by (clarsimp simp: kh0H_def option_update_range_def cnode_offs_in_range' s0_ptrs_aligned + kh0H_dom_distinct kh0H_dom_distinct2 not_in_range_None, + ((clarsimp simp: cnode_offs_in_range2 kh0H_dom_sets_distinct[THEN orthD1] not_in_range_None + | clarsimp simp: cnode_offs_in_range2 kh0H_dom_sets_distinct[THEN orthD2] not_in_range_None)+), + intro conjI, + (clarsimp, drule not_disjointI, + (rule irq_node_offs_in_range cnode_offs_in_range2 | erule offs_in_range), + (rule irq_node_offs_in_range cnode_offs_in_range2 | erule offs_in_range), + erule notE, rule kh0H_dom_sets_distinct)+, + clarsimp split: option.splits)+ + +lemma cnode_offs_aligned2: + "is_aligned (Low_cnode_ptr + 0x20 * (addr && mask 10)) 5" + "is_aligned (High_cnode_ptr + 0x20 * (addr && mask 10)) 5" + "is_aligned (Silc_cnode_ptr + 0x20 * (addr && mask 10)) 5" + by (rule is_aligned_add, rule is_aligned_weaken, rule s0_ptrs_aligned, + simp, rule is_aligned_mult_triv1[where n=5, simplified])+ + +lemma less_t2n_ex_ucast: + "\ (x::'a::len word) < 2 ^ n; len_of TYPE('b) = n \ \ \y. x = ucast (y::'b::len word)" + apply (rule_tac x="ucast x" in exI) + apply (rule ucast_ucast_len[symmetric]) + apply simp + done + +lemma pd_offs_aligned: + "is_aligned (Low_pd_ptr + (ucast (x :: pt_index) << 3)) 3" + "is_aligned (High_pd_ptr + (ucast (x :: pt_index) << 3)) 3" + by (rule is_aligned_add[OF _ is_aligned_shift], simp add: s0_ptr_defs is_aligned_def)+ + +lemma less_0x200_exists_ucast: + "p < 0x200 \ \p'. p = UCAST(9 \ 64) p'" + apply (rule_tac x="UCAST(64 \ 9) p" in exI) + apply word_bitwise + apply clarsimp + done + +lemma valid_caps_s0H[simp]: + notes pteBits_def[simp] objBits_defs[simp] + shows + "valid_cap' NullCap s0H_internal" + "valid_cap' (ThreadCap Low_tcb_ptr) s0H_internal" + "valid_cap' (ThreadCap High_tcb_ptr) s0H_internal" + "valid_cap' (CNodeCap Low_cnode_ptr 10 2 10) s0H_internal" + "valid_cap' (CNodeCap High_cnode_ptr 10 2 10) s0H_internal" + "valid_cap' (CNodeCap Silc_cnode_ptr 10 2 10) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite RISCVLargePage False (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage False (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage False (Some (ucast Silc_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap Low_pt_ptr (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap High_pt_ptr (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid))) s0H_internal" + "valid_cap' (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid))) s0H_internal" + "valid_cap' (NotificationCap ntfn_ptr 0 True False) s0H_internal" + "valid_cap' (NotificationCap ntfn_ptr 0 False True) s0H_internal" + "valid_cap' (ReplyCap Low_tcb_ptr True True) s0H_internal" + "valid_cap' (ReplyCap High_tcb_ptr True True) s0H_internal" + supply option.case_cong[cong] if_cong[cong] + apply (simp | simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def + objBits_def s0_ptrs_aligned obj_at'_def, + intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, + simp add: objBitsKO_def s0_ptrs_aligned mask_def, + rule pspace_distinctD'[OF _ s0H_pspace_distinct', simplified s0H_internal_def], + simp)+ + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: Low_cte_def Low_cte'_def Low_capsH_def cnode_offs_min2 objBitsKO_def + cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned empty_cte_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: Low_cte_def Low_cte'_def Low_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: High_cte_def High_cte'_def High_capsH_def cnode_offs_min2 cnode_offs_max2 + cnode_offs_aligned2 add.commute s0_ptrs_aligned objBitsKO_def empty_cte_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: High_cte_def High_cte'_def High_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: Silc_cte_def Silc_cte'_def Silc_capsH_def cnode_offs_min2 objBitsKO_def + empty_cte_def cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: Silc_cte_def Silc_cte'_def Silc_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply ((clarsimp simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned bit_simps + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + wellformed_mapdata'_def asid_wf_def mask_def, + drule less_0x200_exists_ucast, clarsimp, clarsimp simp: objBitsKO_def, + rule conjI, clarsimp simp: s0_ptr_defs is_aligned_mask bit_simps mask_def, word_bitwise, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: objBitsKO_def)+)[3] + apply ((simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + bit_simps mask_def archObjSize_def pt_offs_min objBitsKO_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def, safe, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def, + clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, word_bitwise, + fastforce simp: pt_offs_max add.commute)+)[4] + apply ((simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned bit_simps wellformed_mapdata'_def + mask_def page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + objBitsKO_def archObjSize_def pt_offs_min, + intro conjI, clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: kh0H_obj_def archObjSize_def bit_simps objBitsKO_def)+)[2] + by (simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def objBits_def obj_at'_def, + intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, + simp add: objBitsKO_def s0_ptrs_aligned mask_def, + rule pspace_distinctD'[OF _ s0H_pspace_distinct', simplified s0H_internal_def], simp)+ + +text \We can only instantiate our example state (featuring high and low domains) if the number + of configured domains is > 1, i.e. that maxDomain is 1 or greater. When seL4 is configured for a + single domain only, none of the state instantiation proofs below are relevant.\ + +lemma s0H_valid_objs': + "1 \ maxDomain \ valid_objs' s0H_internal" + supply objBits_defs[simp] + apply (clarsimp simp: valid_objs'_def ran_def) + apply (drule kh0H_SomeD) + apply (elim disjE) + apply (clarsimp simp: valid_obj'_def ntfnH_def valid_ntfn'_def obj_at'_def) + apply (rule conjI) + apply (clarsimp simp: is_aligned_def s0_ptr_defs objBitsKO_def) + apply (clarsimp simp: pspace_distinctD'[OF _ s0H_pspace_distinct']) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def + Low_domain_def minBound_word valid_arch_tcb'_def + Low_mcp_def Low_prio_def maxPriority_def numPriorities_def + tcb_cte_cases_def Low_capsH_def kh0H_obj_def) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def + High_domain_def minBound_word valid_arch_tcb'_def + High_mcp_def High_prio_def maxPriority_def numPriorities_def + tcb_cte_cases_def High_capsH_def obj_at'_def kh0H_obj_def) + apply (rule conjI) + apply (simp add: is_aligned_def s0_ptr_defs objBitsKO_def) + apply (clarsimp simp: ntfnH_def pspace_distinctD'[OF _ s0H_pspace_distinct']) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def kh0H_obj_def valid_tcb_state'_def + default_domain_def minBound_word valid_arch_tcb'_def + default_priority_def tcb_cte_cases_def) + defer 2 + apply (auto simp: is_aligned_def addrFromPPtr_def ptrFromPAddr_def pptrBaseOffset_def + valid_obj'_def s0_ptr_defs kh0H_obj_def valid_arch_obj'_def)[5] + apply (auto simp: valid_obj'_def valid_cte'_def empty_cte_def irq_cte_def + valid_arch_obj'_def + Low_cte_def Low_cte'_def Low_capsH_def + High_cte_def High_cte'_def High_capsH_def + Silc_cte_def Silc_cte'_def Silc_capsH_def) + done + +lemmas the_nat_to_bl_simps = the_nat_to_bl_def nat_to_bl_def + +lemma ucast_shiftr_13E: + "\ ucast (p - ptr >> 5) = (0x13E :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5 \ + \ p = (ptr :: obj_ref) + 0x27C0" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x27C0" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_6: + "\ ucast (p - ptr >> 5) = (0x6 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0xC0" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0xC0" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_5: + "\ ucast (p - ptr >> 5) = (5 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0xA0" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0xA0" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_4: + "\ ucast (p - ptr >> 5) = (4 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x80" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x80" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_3: + "\ucast (p - ptr >> 5) = (3 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x60" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x60" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_2: + "\ucast (p - ptr >> 5) = (2 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x40" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x40" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_1: + "\ucast (p - ptr >> 5) = (1 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x20" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x20" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemmas kh0H_all_obj_def' = Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def + Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def kh0H_all_obj_def + +lemma map_to_ctes_kh0H_simps'[simp]: + "map_to_ctes kh0H (Low_cnode_ptr + 0x20) = Some (CTE (ThreadCap Low_tcb_ptr) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0x40) = Some (CTE (CNodeCap Low_cnode_ptr 10 2 10) + (MDB 0 Low_tcb_ptr False False))" + "map_to_ctes kh0H (Low_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0)))) + (MDB 0 (Low_tcb_ptr + 0x20) False False))" + "map_to_ctes kh0H (Low_cnode_ptr + 0x80) = Some (CTE (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid))) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite RISCVLargePage + False (Some (ucast Low_asid, 0)))) + (MDB 0 (Silc_cnode_ptr + 0xA0) False False))" + "map_to_ctes kh0H (Low_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap Low_pt_ptr (Some (ucast Low_asid, 0)))) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 True False) + (MDB (Silc_cnode_ptr + 0x27C0) 0 False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0x20) = Some (CTE (ThreadCap High_tcb_ptr) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0x40) = Some (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB 0 High_tcb_ptr False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) + (MDB 0 (High_tcb_ptr + 0x20) False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0x80) = Some (CTE (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid))) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + False (Some (ucast High_asid, 0)))) + (MDB (Silc_cnode_ptr + 0xA0) 0 False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap High_pt_ptr (Some (ucast High_asid, 0)))) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 False True) + (MDB 0 (Silc_cnode_ptr + 0x27C0) False False))" + "map_to_ctes kh0H (Silc_cnode_ptr + 0x40) = Some (CTE (CNodeCap Silc_cnode_ptr 10 2 10) Null_mdb)" + "map_to_ctes kh0H (Silc_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + False (Some (ucast Silc_asid, 0)))) + (MDB (Low_cnode_ptr + 0xA0) (High_cnode_ptr + 0xA0) False False))" + "map_to_ctes kh0H (Silc_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 True False) + (MDB (High_cnode_ptr + 318 * 0x20) (Low_cnode_ptr + 318 * 0x20) False False))" + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 1", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 2", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 3", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 4", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 5", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 6", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 318", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 1", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 2", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 3", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 4", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 5", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 6", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 318", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(5)[where x="the_nat_to_bl_10 2", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(5)[where x="the_nat_to_bl_10 5", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(5)[where x="the_nat_to_bl_10 318", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + done + +lemma mdb_next_s0H: + "p' \ 0 + \ map_to_ctes kh0H \ p \ p' = + (p = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0 \ + p = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = High_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0 \ + p = Silc_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60)" + apply (rule iffI) + apply (simp add: next_unfold') + apply (elim exE conjE) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: next_unfold' map_to_ctes_kh0H_dom) + apply (elim disjE, simp_all add: kh0H_all_obj_def') + done + +lemma mdb_prev_s0H: + "p \ 0 + \ map_to_ctes kh0H \ p \ p' = + (p = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0 \ + p = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = High_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0 \ + p = Silc_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60)" + apply (rule iffI) + apply (simp add: mdb_prev_def) + apply (elim exE conjE) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply clarsimp + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply clarsimp + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_3 ucast_shiftr_2 s0_ptrs_aligned + split: if_split_asm) + apply clarsimp + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_5 ucast_shiftr_3 ucast_shiftr_2 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: mdb_prev_def map_to_ctes_kh0H_dom) + apply (elim disjE, simp_all add: kh0H_all_obj_def') + done + +lemma mdb_next_trancl_s0H: + "p' \ 0 + \ map_to_ctes kh0H \ p \\<^sup>+ p' = + (p = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0 \ + p = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = Low_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = High_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0 \ + p = Silc_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = High_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60)" + apply (rule iffI) + apply (erule converse_trancl_induct) + apply (clarsimp simp: mdb_next_s0H) + apply (subst (asm) mdb_next_s0H) + apply (clarsimp simp: s0_ptr_defs) + apply (clarsimp simp: s0_ptr_defs del: disjCI) + apply ((erule_tac P="y = _ \ _" in disjE | clarsimp)+)[1] + apply (elim disjE) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_r_into_trancl[where b="Silc_cnode_ptr + 0x27C0"]) + apply (simp add: mdb_next_s0H s0_ptr_defs) + apply (simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_r_into_trancl[where b="Silc_cnode_ptr + 0xA0"]) + apply (simp add: mdb_next_s0H s0_ptr_defs) + apply (simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + done + +lemma mdb_next_rtrancl_not_0_s0H: + "\ map_to_ctes kh0H \ p \\<^sup>* p'; p' \ 0 \ \ p \ 0" + apply (drule rtranclD) + apply (clarsimp simp: mdb_next_trancl_s0H s0_ptr_defs) + done + +lemma sameRegionAs_s0H: + "\ map_to_ctes kh0H p = Some (CTE cap mdb); map_to_ctes kh0H p' = Some (CTE cap' mdb'); + sameRegionAs cap cap'; p \ p' \ + \ (p = Low_cnode_ptr + 0x27C0 \ (p' = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0) \ + p = Silc_cnode_ptr + 0x27C0 \ (p' = Low_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0) \ + p = High_cnode_ptr + 0x27C0 \ (p' = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0) \ + p = Low_cnode_ptr + 0xA0 \ (p' = Silc_cnode_ptr + 0xA0 \ p' = High_cnode_ptr + 0xA0) \ + p = Silc_cnode_ptr + 0xA0 \ (p' = Low_cnode_ptr + 0xA0 \ p' = High_cnode_ptr + 0xA0) \ + p = High_cnode_ptr + 0xA0 \ (p' = Low_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0) \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_cnode_ptr + 0x40 \ p' = Low_tcb_ptr \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = Low_cnode_ptr + 0x60 \ p' = Low_tcb_ptr + 0x20 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_cnode_ptr + 0x40 \ p' = High_tcb_ptr \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60 \ + p = High_cnode_ptr + 0x60 \ p' = High_tcb_ptr + 0x20)" + supply option.case_cong[cong] if_cong[cong] s0_ptrs_aligned[simp] + apply (frule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' s0_ptr_defs split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' s0_ptr_defs split: if_split_asm) + apply (clarsimp simp: to_bl_use_of_bl the_nat_to_bl_simps kh0H_all_obj_def' ucast_shiftr_2 + split: if_split_asm) + apply ((frule_tac x=p' in map_to_ctes_kh0H_SomeD, + (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps)[1], + ((clarsimp simp: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps to_bl_use_of_bl + the_nat_to_bl_simps kh0H_all_obj_def' ucast_shiftr_2 ucast_shiftr_3 + split: if_split_asm)+)[3])+)[5] + apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_1; clarsimp) + apply (drule(2) ucast_shiftr_1; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_1; clarsimp) + apply (drule(2) ucast_shiftr_1; clarsimp) + done + +lemma mdb_prevI: + "m p = Some c \ m \ mdbPrev (cteMDBNode c) \ p" + by (simp add: mdb_prev_def) + +lemma mdb_nextI: + "m p = Some c \ m \ p \ mdbNext (cteMDBNode c)" + by (simp add: mdb_next_unfold) + +lemma s0H_valid_pspace': + notes pteBits_def[simp] objBits_defs[simp] + notes valid_arch_badges_def[simp] mdb_chunked_arch_assms_def[simp] + assumes "1 \ maxDomain" + shows "valid_pspace' s0H_internal" + using assms + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: valid_pspace'_def s0H_pspace_distinct' s0H_valid_objs') + apply (intro conjI) + apply (clarsimp simp: pspace_aligned'_def) + apply (drule kh0H_SomeD) + apply (elim disjE; clarsimp simp: s0_ptr_defs kh0H_all_obj_def objBitsKO_def archObjSize_def + cnode_offs_range_def page_offs_range_def pt_offs_range_def + irq_node_offs_range_def is_aligned_mask mask_def bit_simps + split: if_splits) + apply (clarsimp simp: pspace_canonical'_def) + apply (drule kh0H_SomeD') + apply (fastforce elim: dual_order.trans + intro: above_pptr_base_canonical + simp: irq_node_offs_range_def cnode_offs_range_def + pt_offs_range_def page_offs_range_def s0_ptr_defs) + apply (clarsimp simp: pspace_in_kernel_mappings'_def) + apply (clarsimp simp: kernel_mappings_def) + apply (drule kh0H_SomeD') + apply (fastforce elim: dual_order.trans + simp: s0_ptr_defs irq_node_offs_range_def cnode_offs_range_def + pt_offs_range_def page_offs_range_def kernel_mappings_def) + apply (clarsimp simp: no_0_obj'_def) + apply (rule ccontr, clarsimp) + apply (drule kh0H_SomeD) + apply (simp add: irq_node_offs_range_def cnode_offs_range_def + page_offs_range_def pt_offs_range_def s0_ptr_defs) + apply (simp add: valid_mdb'_def) + apply (clarsimp simp: valid_mdb_ctes_def) + apply (intro conjI) + apply (clarsimp simp: valid_dlist_def3) + apply (rule conjI) + apply (clarsimp simp: mdb_next_s0H) + apply (subst mdb_prev_s0H) + apply (fastforce simp: s0_ptr_defs) + apply simp + apply (clarsimp simp: mdb_prev_s0H) + apply (subst mdb_next_s0H) + apply (fastforce simp: s0_ptr_defs) + apply simp + apply (clarsimp simp: no_0_def) + apply (rule ccontr) + apply clarsimp + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: irq_node_offs_range_def + cnode_offs_range_def s0_ptr_defs)+)[1] + apply (clarsimp simp: mdb_chain_0_def) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE) + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[5] + apply ((rule r_r_into_trancl[OF next_fold next_fold], simp+)+)[2] + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[3] + apply ((rule r_r_into_trancl[OF next_fold next_fold], simp+)+)[2] + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[5] + apply (clarsimp simp: kh0H_all_obj_def Silc_cte_cte_def cnode_offs_range_def + split: if_split_asm) + apply ((rule r_r_into_trancl[OF next_fold next_fold], simp+)+)[2] + apply (erule r_into_trancl[OF next_fold], simp) + apply (erule r_into_trancl[OF next_fold], simp) + apply (clarsimp simp: kh0H_all_obj_def High_cte_cte_def cnode_offs_range_def + split: if_split_asm) + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[2] + apply (rule trancl_into_trancl2[OF next_fold], simp+)[1] + apply (rule r_r_into_trancl[OF next_fold next_fold], simp+)[1] + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[5] + apply (clarsimp simp: kh0H_all_obj_def Low_cte_cte_def cnode_offs_range_def + split: if_split_asm) + apply (rule trancl_into_trancl2[OF next_fold], simp+)[1] + apply (rule r_r_into_trancl[OF next_fold next_fold], simp+)[1] + apply (erule r_into_trancl[OF next_fold], simp)+ + apply (clarsimp simp: valid_badges_def) + apply (frule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def + kh0H_all_obj_def isCap_simps + split: if_split_asm)+)[1] + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def + kh0H_all_obj_def isCap_simps sameRegionAs_def + split: if_split_asm)+)[1] + apply (intro conjI impI) + apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (drule(1) sameRegion_ntfn) + apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: High_cte_cte_def Low_cte_cte_def + Silc_cte_cte_def kh0H_all_obj_def + split: if_split_asm)+)[1] + apply (intro conjI impI) + apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (drule(1) sameRegion_ntfn) + apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: High_cte_cte_def Low_cte_cte_def + Silc_cte_cte_def kh0H_all_obj_def + split: if_split_asm)+)[1] + apply (clarsimp simp: caps_contained'_def) + apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: Silc_cte_cte_def kh0H_all_obj_def split: if_split_asm) + apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def split: if_split_asm) + apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def split: if_split_asm) + apply (clarsimp simp: mdb_chunked_def) + apply (frule(3) sameRegionAs_s0H) + apply (clarsimp simp: conj_disj_distribL) + apply (prop_tac "p \ 0 \ p' \ 0") + apply (elim disjE; clarsimp simp: s0_ptr_defs) + apply (intro conjI; clarsimp) + apply (simp add: mdb_next_trancl_s0H) + apply (elim disjE, simp_all)[1] + apply (thin_tac "_ \ _") + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE) + apply ((clarsimp simp: is_chunk_def, + drule mdb_next_rtrancl_not_0_s0H, fastforce simp: s0_ptr_defs, + clarsimp simp: mdb_next_trancl_s0H, + (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def + isCap_simps kh0H_all_obj_def' + , (fastforce simp: s0_ptr_defs)+)[1])+)[10] + apply (thin_tac "_ \ _") + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE) + apply ((clarsimp simp: is_chunk_def, + drule mdb_next_rtrancl_not_0_s0H, fastforce simp: s0_ptr_defs, + clarsimp simp: mdb_next_trancl_s0H, + (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def + isCap_simps kh0H_all_obj_def' + , (fastforce simp: s0_ptr_defs)+)[1])+)[10] + apply (clarsimp simp: untyped_mdb'_def) + apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: untyped_inc'_def) + apply (rule FalseE) + apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: valid_nullcaps_def) + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def' nullMDBNode_def) + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: ut_revocable'_def) + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: class_links_def) + apply (subst(asm) mdb_next_s0H) + apply (drule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: s0_ptr_defs irq_node_offs_range_def cnode_offs_range_def)+)[1] + apply (elim disjE, (clarsimp simp: kh0H_all_obj_def')+)[1] + apply (clarsimp simp: distinct_zombies_def distinct_zombie_caps_def) + apply (drule_tac x=ptr in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: irq_control_def) + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: reply_masters_rvk_fb_def ran_def) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + done + +end + + +(* Instantiate the current, abstract domain scheduler into the + concrete scheduler required for this example *) +axiomatization where + newKSDomSched: "newKSDomSchedule = [(0,0xA), (1, 0xA)]" + +axiomatization where + newKSDomainTime: "newKSDomainTime = 5" + +(* kernel_data_refs is an undefined constant at the moment, and therefore + cannot be referred to in valid_global_refs' and pspace_domain_valid. + We use an axiomatization for the moment. *) +axiomatization where + kdr_valid_global_refs': "valid_global_refs' s0H_internal" and + kdr_pspace_domain_valid: "pspace_domain_valid s0H_internal" + + +context begin interpretation Arch . + +lemma ksArchState0H[simp]: + "ksArchState s0H_internal = arch_state0H" + by (simp add: s0H_internal_def) + +lemma valid_arch_state_s0H: + "valid_arch_state' s0H_internal" + apply (clarsimp simp: valid_arch_state'_def) + apply (intro conjI) + apply (clarsimp simp: valid_asid_table'_def s0H_internal_def arch_state0H_def asid_bits_defs + asid_high_bits_of_def Low_asid_def High_asid_def mask_def s0_ptr_defs) + apply (clarsimp simp: valid_global_pts'_def is_aligned_riscv_global_pt_ptr[simplified bit_simps] + arch_state0H_def page_table_at'_def typ_at'_def ko_wp_at'_def + bit_simps global_ptH_def pt_offs_min) + apply (subst objBitsKO_def) + apply (clarsimp simp: archObjSize_def bit_simps) + apply (intro conjI) + apply (fastforce intro: pspace_distinctD'[OF _ s0H_pspace_distinct'] + simp: global_ptH_def pt_offs_min) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply word_bitwise + apply (clarsimp simp: s0_ptr_defs) + apply word_bitwise + apply (clarsimp simp: arch_state0H_def) + done + +lemma s0H_invs: + assumes "1 \ maxDomain" + notes pteBits_def[simp] objBits_defs[simp] + shows "invs' s0H_internal" + using assms + supply option.case_cong[cong] if_cong[cong] + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) + apply (clarsimp simp: invs'_def valid_state'_def s0H_valid_pspace') + apply (rule conjI) + apply (clarsimp simp: sch_act_wf_def ct_in_state'_def st_tcb_at'_def obj_at'_def + s0H_internal_def s0_ptrs_aligned objBitsKO_def Low_tcbH_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: sym_refs_def state_refs_of'_def refs_of'_def split: option.splits) + apply (frule kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: ntfnH_def ntfn_q_refs_of'_def) + apply (rule conjI) + apply (clarsimp simp: tcb_st_refs_of'_def High_tcbH_def) + apply (clarsimp simp: objBitsKO_def s0_ptrs_aligned) + apply (erule notE, rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: objBitsKO_def) + apply (clarsimp simp: tcb_st_refs_of'_def Low_tcbH_def) + apply (clarsimp simp: tcb_st_refs_of'_def High_tcbH_def) + apply (rule conjI) + apply (clarsimp simp: ntfnH_def) + apply (clarsimp simp: objBitsKO_def ntfnH_def) + apply (erule impE, simp add: is_aligned_def s0_ptr_defs) + apply (erule notE, rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: objBitsKO_def ntfnH_def) + apply (clarsimp simp: tcb_st_refs_of'_def idle_tcbH_def) + apply (clarsimp simp: global_ptH_def) + apply (clarsimp simp: Low_ptH_def) + apply (clarsimp simp: High_ptH_def) + apply (clarsimp simp: Low_pdH_def) + apply (clarsimp simp: High_pdH_def) + apply (clarsimp simp: Low_cte_def Low_cte'_def split: if_split_asm) + apply (clarsimp simp: High_cte_def High_cte'_def split: if_split_asm) + apply (clarsimp simp: Silc_cte_def Silc_cte'_def split: if_split_asm) + apply (rule conjI) + apply (clarsimp simp: if_live_then_nonz_cap'_def ko_wp_at'_def) + apply (drule kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def' objBitsKO_def live'_def hyp_live'_def)[1] + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rule_tac x="Silc_cnode_ptr + 0x27C0" in exI) + apply (clarsimp simp: kh0H_all_obj_def') + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def') + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def') + apply (clarsimp split: if_split_asm simp: live'_def hyp_live'_def)+ + apply (rule conjI) + apply (clarsimp simp: if_unsafe_then_cap'_def ex_cte_cap_wp_to'_def cte_wp_at_ctes_of) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def')[1] + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="Silc_cnode_ptr + 0x40" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E, rule s0_ptrs_aligned, simp) + apply (rule_tac x="(0x27C0 >> 5)" in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_5, rule s0_ptrs_aligned, simp) + apply (rule_tac x=5 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_2, rule s0_ptrs_aligned, simp) + apply (rule_tac x=2 in bexI) + apply simp + apply (simp add: mask_def) + apply (rule_tac x="High_cnode_ptr + 0x40" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E, rule s0_ptrs_aligned, simp) + apply (rule_tac x="0x13E" in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_6, rule s0_ptrs_aligned, simp) + apply (rule_tac x=6 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_5, rule s0_ptrs_aligned, simp) + apply (rule_tac x=5 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_4, rule s0_ptrs_aligned, simp) + apply (rule_tac x=4 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_3, rule s0_ptrs_aligned, simp) + apply (rule_tac x=3 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_2, rule s0_ptrs_aligned, simp) + apply (rule_tac x=2 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_1, rule s0_ptrs_aligned, simp) + apply (rule_tac x=1 in bexI) + apply simp + apply (simp add: mask_def) + apply (rule_tac x="Low_cnode_ptr + 0x40" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E, rule s0_ptrs_aligned, simp) + apply (rule_tac x="0x13E" in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_6, rule s0_ptrs_aligned, simp) + apply (rule_tac x=6 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_5, rule s0_ptrs_aligned, simp) + apply (rule_tac x=5 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_4, rule s0_ptrs_aligned, simp) + apply (rule_tac x=4 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_3, rule s0_ptrs_aligned, simp) + apply (rule_tac x=3 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_2, rule s0_ptrs_aligned, simp) + apply (rule_tac x=2 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_1, rule s0_ptrs_aligned, simp) + apply (rule_tac x=1 in bexI) + apply simp + apply (simp add: mask_def) + apply (rule conjI) + apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def objBitsKO_def idle_tcb'_def) + apply (clarsimp simp: s0H_internal_def s0_ptrs_aligned idle_tcbH_def) + apply (rule conjI) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (clarsimp simp: idle_tcb_ptr_def idle_thread_ptr_def) + apply (rule conjI) + apply (clarsimp simp: kdr_valid_global_refs') (* use axiomatization for now *) + apply (rule conjI) + apply (clarsimp simp: valid_arch_state_s0H) + apply (rule conjI) + apply (clarsimp simp: valid_irq_node'_def) + apply (rule conjI) + apply (clarsimp simp: s0H_internal_def is_aligned_def s0_ptr_defs word_size) + apply (clarsimp simp: obj_at'_def objBitsKO_def s0H_internal_def + shiftl_t2n[where n=4, simplified, symmetric]) + apply (rule conjI) + apply (rule is_aligned_add) + apply (simp add: is_aligned_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: valid_irq_handlers'_def cteCaps_of_def ran_def) + apply (drule_tac map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (rule conjI) + apply (clarsimp simp: valid_irq_states'_def s0H_internal_def machine_state0_def) + apply (rule conjI) + apply (clarsimp simp: valid_machine_state'_def s0H_internal_def machine_state0_def) + apply (rule conjI) + apply (clarsimp simp: irqs_masked'_def s0H_internal_def maxIRQ_def timer_irq_def irqInvalid_def) + apply (rule conjI) + apply (clarsimp simp: sym_heap_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_sched_pointers_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def s0H_internal_def + tcbQueueEmpty_def bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def) + apply (rule conjI) + apply (clarsimp simp: ct_not_inQ_def obj_at'_def objBitsKO_def + s0H_internal_def s0_ptrs_aligned Low_tcbH_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: ct_idle_or_in_cur_domain'_def obj_at'_def tcb_in_cur_domain'_def + s0H_internal_def Low_tcbH_def Low_domain_def objBitsKO_def s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: kdr_pspace_domain_valid) (* use axiomatization for now *) + apply (clarsimp simp: s0H_internal_def cteCaps_of_def untyped_ranges_zero_inv_def + dschDomain_def dschLength_def) + apply (clarsimp simp: newKernelState_def newKSDomSched) + apply (clarsimp simp: cur_tcb'_def obj_at'_def s0H_internal_def objBitsKO_def s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + done + +lemma kh0_pspace_dom: + "pspace_dom kh0 = {idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, + High_pool_ptr, Low_pool_ptr, irq_cnode_ptr, ntfn_ptr} \ + irq_node_offs_range \ + page_offs_range shared_page_ptr_virt \ + cnode_offs_range Silc_cnode_ptr \ + cnode_offs_range High_cnode_ptr \ + cnode_offs_range Low_cnode_ptr \ + pt_offs_range riscv_global_pt_ptr \ + pt_offs_range High_pd_ptr \ + pt_offs_range Low_pd_ptr \ + pt_offs_range High_pt_ptr \ + pt_offs_range Low_pt_ptr" + apply (rule equalityI) + apply (simp add: dom_def pspace_dom_def) + apply clarsimp + apply (clarsimp simp: kh0_def obj_relation_cuts_def page_offs_in_range pt_offs_in_range + cnode_offs_in_range irq_node_offs_in_range s0_ptrs_aligned bit_simps + kh0_obj_def cte_map_def' caps_dom_length_10 + dest!: less_0x200_exists_ucast split: if_split_asm) + apply (clarsimp simp: pspace_dom_def dom_def) + apply (rule conjI) + apply (rule_tac x=idle_tcb_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=High_tcb_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=Low_tcb_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=High_pool_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=Low_pool_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=irq_cnode_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def cte_map_def) + apply (rule conjI) + apply (rule_tac x=ntfn_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=x in exI) + apply (drule offs_range_correct) + apply clarsimp + apply (force simp: kh0_def kh0_obj_def image_def cte_map_def') + apply (rule conjI) + apply clarsimp + apply (rule_tac x=shared_page_ptr_virt in exI) + apply (drule offs_range_correct) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps bit_simps) + apply (rule_tac x="UCAST (9 \ 64) y" in exI) + apply clarsimp + apply word_bitwise + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Silc_cnode_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=High_cnode_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Low_cnode_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=riscv_global_pt_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=High_pd_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Low_pd_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=High_pt_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply clarsimp + apply (rule_tac x=Low_pt_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + done + + +lemma shiftl_shiftr_3_pt_index[simp]: + "ucast (((ucast (x :: pt_index) << 3) :: obj_ref) >> 3) = x" + apply (subst shiftl_shiftr_id) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (erule less_trans) + apply simp + apply simp + apply (rule ucast_ucast_id) + apply simp + done + +lemma mult_shiftr_id[simp]: + "length x = 10 \ of_bl x * (0x20 :: obj_ref) >> 5 = of_bl x" + apply (simp add: shiftl_t2n[symmetric, where n=5, simplified mult.commute, simplified] ) + apply (subst shiftl_shiftr_id) + apply simp + apply (rule less_trans) + apply (rule of_bl_length_less) + apply assumption + apply simp + apply simp + apply simp + done + +lemma to_bl_ucast_of_bl[simp]: + "length x = 10 \ to_bl ((ucast (of_bl x :: obj_ref)) :: 10 word) = x" + apply (subst ucast_of_bl_up) + apply (simp add: word_size) + apply (simp add: word_rep_drop) + done + +lemma is_aligned_shiftr_3[simp]: + "is_aligned (riscv_global_pt_ptr + (n << 3)) 3" + "is_aligned (High_pd_ptr + (n << 3)) 3" + "is_aligned (Low_pd_ptr + (n << 3)) 3" + "is_aligned (High_pt_ptr + (n << 3)) 3" + "is_aligned (Low_pt_ptr + (n << 3)) 3" + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(1), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(2), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(3), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(4), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(5), where y=3, simplified bit_simps]]; fastforce) + done + +lemma s0_pspace_rel: + "pspace_relation (kheap s0_internal) kh0H" + apply (simp add: pspace_relation_def s0_internal_def s0H_internal_def kh0H_dom kh0_pspace_dom) + apply clarsimp + apply (drule kh0_SomeD) + apply (elim disjE) + apply (clarsimp simp: kh0_obj_def bit_simps dest!: less_0x200_exists_ucast) + defer + apply ((clarsimp simp: kh0_obj_def kh0H_obj_def bit_simps word_bits_def + fault_rel_optionation_def tcb_relation_cut_def + tcb_relation_def arch_tcb_relation_def the_nat_to_bl_simps + split del: if_split)+)[3] + prefer 13 + apply ((clarsimp simp: kh0_obj_def kh0H_all_obj_def bit_simps add.commute + pt_offs_max pt_offs_min pte_relation_def + split del: if_split, + clarsimp simp: s0_ptr_defs shared_page_ptr_phys_def addrFromPPtr_def pptrBaseOffset_def paddrBase_def + vmrights_map_def vm_read_only_def vm_read_write_def + kh0_obj_def kh0H_all_obj_def elf_index_value, + (clarsimp simp: bit_simps mask_def)?)+)[5] + apply (clarsimp simp: kh0_obj_def kh0H_obj_def well_formed_cnode_n_def + cte_relation_def cte_map_def bit_simps) + apply (clarsimp simp: kh0H_obj_def bit_simps ntfn_def other_obj_relation_def ntfn_relation_def) + defer + apply ((clarsimp simp: kh0_obj_def kh0H_obj_def other_obj_relation_def + asid_pool_relation_def comp_def inv_into_def2 other_aobj_relation_def, + rule ext, + clarsimp simp: asid_low_bits_of_def asid_low_bits_def High_asid_def, + word_bitwise, fastforce)+)[2] + apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') + apply (cut_tac dom_caps(2))[1] + apply (frule_tac m=High_caps in domI) + apply (cut_tac x=y in cnode_offs_in_range(2), simp) + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def High_caps_def + the_nat_to_bl_simps vmrights_map_def vm_read_only_def + split: if_split_asm) + apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') + apply (cut_tac dom_caps(3))[1] + apply (frule_tac m=Low_caps in domI) + apply (cut_tac x=y in cnode_offs_in_range(1), simp) + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Low_caps_def + the_nat_to_bl_simps vmrights_map_def vm_read_write_def + split: if_split_asm) + apply (fastforce simp: kh0H_obj_def cte_map_def cte_relation_def well_formed_cnode_n_def + dest: irq_node_offs_range_correct split: if_split_asm) + apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') + apply (cut_tac dom_caps(1))[1] + apply (frule_tac m=Silc_caps in domI) + apply (cut_tac x=y in cnode_offs_in_range(3), simp) + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Silc_caps_def + the_nat_to_bl_simps vmrights_map_def vm_read_only_def + split: if_split_asm) + done + +lemma subtree_node_Some: + "m \ a \ b \ m a \ None" + by (erule subtree.cases) (auto simp: parentOf_def) + +lemma s0_srel: + "1 \ maxDomain \ (s0_internal, s0H_internal) \ state_relation" + apply (simp add: state_relation_def) + apply (intro conjI) + apply (simp add: s0_pspace_rel) + apply (simp add: s0_internal_def exst0_def s0H_internal_def sched_act_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def + ready_queues_relation_def ready_queue_relation_def + list_queue_relation_def queue_end_valid_def + prev_queue_head_def inQ_def tcbQueueEmpty_def + projectKOs opt_map_def opt_pred_def + split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def ghost_relation_def) + apply (rule conjI) + apply (fastforce simp: kh0_def kh0_obj_def dest: kh0_SomeD) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: irq_node_offs_in_range) + apply (fastforce simp: kh0_def well_formed_cnode_n_def empty_cnode_def dom_def) + apply clarsimp + apply (clarsimp simp: s0_ptr_defs) + apply (subgoal_tac "a \ irq_node_offs_range") + prefer 2 + apply (clarsimp simp: irq_node_offs_range_def s0_ptr_defs) + apply (erule_tac x="ucast (a - 0xFFFFFFC000003000 >> 5)" in allE) + apply (subst (asm) ucast_ucast_len) + apply (rule shiftr_less_t2n) + apply (rule word_less_sub_right) + apply (erule dual_order.strict_trans[rotated], clarsimp) + apply clarsimp + apply (simp add: shiftr_shiftl1) + apply (subst(asm) is_aligned_neg_mask_eq) + apply (rule aligned_sub_aligned[where n=5]) + apply simp + apply (simp add: is_aligned_def) + apply simp + apply simp + apply (intro conjI impI) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Low_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs High_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (clarsimp simp: s0H_internal_def cdt_relation_def) + apply (clarsimp simp: descendants_of'_def) + apply (frule subtree_parent) + apply (drule subtree_mdb_next) + apply (case_tac "x = 0") + apply (cut_tac s0H_valid_pspace') + apply (simp add: valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def + parentOf_def isMDBParentOf_def kh0H_all_obj_def') + apply simp + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE, (clarsimp simp: parentOf_def isMDBParentOf_def kh0H_all_obj_def')+)[1] + apply (clarsimp simp: cdt_list_relation_def s0_internal_def exst0_def split: option.splits) + apply (clarsimp simp: next_slot_def) + apply (cut_tac p="(a, b)" and t="(const [])" and m="Map.empty" in next_not_child_NoneI) + apply fastforce + apply (simp add: next_sib_def) + apply (simp add: finite_depth_def) + apply simp + apply (clarsimp simp: revokable_relation_def) + apply (clarsimp simp: null_filter_def split: if_split_asm) + apply (drule s0_caps_of_state) + apply clarsimp + apply (elim disjE) + apply (clarsimp simp: s0H_internal_def s0_internal_def + cte_map_def' kh0H_all_obj_def' + split: if_split_asm)+ + apply (clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] + Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def) + apply ((clarsimp simp: cte_map_def' s0H_internal_def s0_internal_def, + clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] + Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def)+)[5] + apply (clarsimp simp: s0_internal_def s0H_internal_def arch_state0_def arch_state0H_def + arch_state_relation_def asid_high_bits_of_def asid_low_bits_def + High_asid_def Low_asid_def max_pt_level_def2 maxPTLevel_def comp_def + split: if_splits) + apply safe + apply (rule ext) + apply clarsimp + apply (word_bitwise, fastforce) + apply (rule ext) + apply (clarsimp split: if_splits) + subgoal for level + by (induct level; simp only: size_maxPTLevel[simplified maxPTLevel_def, symmetric] + bit0.size_inj max_pt_level_def2) + apply (clarsimp simp: s0_internal_def s0H_internal_def exst0_def cte_level_bits_def + interrupt_state_relation_def irq_state_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def)+ + done + +definition + "s0H \ ((if ct_idle' s0H_internal then idle_context s0_internal else s0_context, s0H_internal), KernelExit)" + +lemma step_restrict_s0: + "1 \ maxDomain \ step_restrict s0" + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: step_restrict_def has_srel_state_def) + apply (rule_tac x="fst (fst s0H)" in exI) + apply (rule_tac x="snd (fst s0H)" in exI) + apply (rule_tac x="snd s0H" in exI) + apply (simp add: s0H_def lift_fst_rel_def lift_snd_rel_def s0_srel s0_def split del: if_split) + apply (rule conjI) + apply (clarsimp split: if_split_asm) + apply (rule conjI) + apply clarsimp + apply (frule ct_idle'_related[OF s0_srel s0H_invs]; solves simp) + apply clarsimp + apply (drule ct_idle_related[OF s0_srel]; simp) + apply (clarsimp simp: full_invs_if'_def s0H_invs) + apply (rule conjI) + apply (simp only: ex_abs_def) + apply (rule_tac x="s0_internal" in exI) + apply (simp only: einvs_s0 s0_srel) + apply (simp add: s0H_internal_def valid_domain_list'_def) + apply (clarsimp simp: ct_in_state'_def st_tcb_at'_def obj_at'_def + s0H_internal_def objBits_simps' s0_ptrs_aligned Low_tcbH_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBits_simps') + done + +lemma Sys1_valid_initial_state_noenabled: + assumes domains: "1 \ maxDomain" + assumes utf_det: "\pl pr pxn tc ms s. det_inv InUserMode tc s \ einvs s \ context_matches_state pl pr pxn ms s \ ct_running s + \ (\x. utf (cur_thread s) pl pr pxn (tc, ms) = {x})" + assumes utf_non_empty: "\t pl pr pxn tc ms. utf t pl pr pxn (tc, ms) \ {}" + assumes utf_non_interrupt: "\t pl pr pxn tc ms e f g. (e,f,g) \ utf t pl pr pxn (tc, ms) \ e \ Some Interrupt" + assumes det_inv_invariant: "invariant_over_ADT_if det_inv utf" + assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" + shows "valid_initial_state_noenabled det_inv utf s0_internal Sys1PAS timer_irq s0_context" + by (rule Sys1_valid_initial_state_noenabled[OF step_restrict_s0 utf_det utf_non_empty + utf_non_interrupt det_inv_invariant det_inv_s0 + ], + rule domains) + +end + +end From cb6f8fd29212d394155b0d37dc8d495df796561d Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Wed, 10 Jun 2026 12:10:08 +1000 Subject: [PATCH 04/11] aarch64 access: strengthen vcpu integrity relation The vgic_lr field is defined as a total function from nats to virqs, with the domain restricted only in practice via the parameter arm_gicvcpu_numlistregs. To establish value-level equivalence between vcpus in the InfoFlow proofs, the vcpu integrity relation must therefore ensure out-of-bounds list registers remain untouched. Signed-off-by: Ryan Barry --- proof/access-control/AARCH64/ArchAccess.thy | 14 ++++- .../access-control/AARCH64/ArchAccess_AC.thy | 2 +- proof/access-control/AARCH64/ArchArch_AC.thy | 52 ++++++++++++++++++- proof/access-control/Access.thy | 2 + proof/access-control/Access_AC.thy | 21 ++++++++ 5 files changed, 86 insertions(+), 5 deletions(-) diff --git a/proof/access-control/AARCH64/ArchAccess.thy b/proof/access-control/AARCH64/ArchAccess.thy index da7ad0d1a5..4fe9a78063 100644 --- a/proof/access-control/AARCH64/ArchAccess.thy +++ b/proof/access-control/AARCH64/ArchAccess.thy @@ -133,8 +133,8 @@ where | (Some vcpu, None) \ Some (vcpu_mask n vcpu) \ \No current VCPU\ | (Some vcpu, Some enabled) \ Some (vcpu_mask n (vcpu\vcpu_regs := \reg. if vcpuRegSavedWhenDisabled reg \ \enabled - then vcpu_regs vcpu reg \ \Register saved when VCPU disabled\ - else vcpu_regs vst reg, + then vcpu_regs vcpu reg \ \Register saved when VCPU disabled\ + else vcpu_regs vst reg, vcpu_vgic := (vcpu_vgic vcpu) \vgic_hcr := if \enabled then vgic_hcr (vcpu_vgic vcpu) \ \Saved when VCPU disabled\ @@ -143,8 +143,18 @@ where vgic_apr := vgic_apr (vcpu_vgic vst), vgic_lr := vgic_lr (vcpu_vgic vst)\\))" +(* A vcpu's vgic_lr field is a total function from nats to virqs, with the domain restricted only + in practice via the arm_gicvcpu_numlistregs parameter. To establish true equivalence between + vcpus in the InfoFlow proofs, we prove here that these out-of-bounds registers aren't touched. *) +definition vcpu_extra_lrs :: "nat \ vcpu option \ (nat \ virq)" where + "vcpu_extra_lrs n vopt \ + case vopt of + None \ None + | Some vcpu \ Some (\r. if r \ n then vgic_lr (vcpu_vgic vcpu) r else undefined)" + definition vcpu_integrity where "vcpu_integrity hv hv' cv cv' n n' vopt vopt' \ + vcpu_extra_lrs n vopt = vcpu_extra_lrs n' vopt' \ vcpu_of_state hv cv n vopt = vcpu_of_state hv' cv' n' vopt'" definition integrity_hyp_2 :: diff --git a/proof/access-control/AARCH64/ArchAccess_AC.thy b/proof/access-control/AARCH64/ArchAccess_AC.thy index 6ad2103366..8fd790ddc2 100644 --- a/proof/access-control/AARCH64/ArchAccess_AC.thy +++ b/proof/access-control/AARCH64/ArchAccess_AC.thy @@ -333,7 +333,7 @@ lemma integrity_hyp_ao_upd: "\ ao p = Some ako; vcpu_of ako = None; vcpu_of ako' = None; integrity_hyp_2 aag subjects x ms ms' as as' ao ao' \ \ integrity_hyp_2 aag subjects x ms ms' as as' ao (ao'(p \ ako')) " - unfolding integrity_hyp_def vcpu_integrity_def vcpu_of_state_def opt_map_def + unfolding integrity_hyp_def vcpu_integrity_def vcpu_extra_lrs_def vcpu_of_state_def opt_map_def by (case_tac "x = p"; clarsimp; auto split: option.splits)+ end diff --git a/proof/access-control/AARCH64/ArchArch_AC.thy b/proof/access-control/AARCH64/ArchArch_AC.thy index 83ce529dea..a03e5341c0 100644 --- a/proof/access-control/AARCH64/ArchArch_AC.thy +++ b/proof/access-control/AARCH64/ArchArch_AC.thy @@ -2164,13 +2164,57 @@ lemma vcpu_proj_arch_state_update[simp]: crunch vcpu_switch for arm_gicvcpu_numlistregs[wp]: "\s. P (arm_gicvcpu_numlistregs (arch_state s))" +lemma vcpu_update_extra_lrs[wp]: + "\\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + (\v r. arm_gicvcpu_numlistregs (arch_state s) \ r + \ vgic_lr (vcpu_vgic (f v)) r = vgic_lr (vcpu_vgic v) r)\ + vcpu_update vr f + \\_ s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + unfolding vcpu_update_def + apply (wpsimp wp: set_vcpu_wp get_vcpu_wp) + apply (erule_tac x=v in allE) + apply (erule_tac P=P in rsubst) + apply (auto intro!: ext simp: vcpu_extra_lrs_def) + done + +crunch vcpu_save_reg, vcpu_save_reg_range, save_virt_timer + for extra_lrs[wp]: "\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))" + (wp: mapM_x_wp) + +lemma vgic_update_extra_lrs[wp]: + "\\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + (\v r. arm_gicvcpu_numlistregs (arch_state s) \ r \ vgic_lr (f v) r = vgic_lr v r)\ + vgic_update vr f + \\_ s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + unfolding vgic_update_def by wpsimp + +lemma vgic_update_lr_extra_lrs[wp]: + "\\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + r < arm_gicvcpu_numlistregs (arch_state s)\ + vgic_update_lr vr r irq + \\_ s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + unfolding vgic_update_lr_def by wpsimp + +lemma vcpu_save_extra_lrs[wp]: + "vcpu_save vr \\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + by (wpsimp simp: vcpu_save_def + | rule hoare_strengthen_post, + rule_tac P="\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + num_list_regs = arm_gicvcpu_numlistregs (arch_state s)" + and Q="\r s. r < num_list_regs" and xs="[0..s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))" + (wp: mapM_x_wp) + lemma vcpu_switch_integrity_hyp[wp]: "\integrity_hyp aag subjects x st and valid_arch_state\ vcpu_switch vr \\_. integrity_hyp aag subjects x st\" unfolding integrity_hyp_def vcpu_integrity_def vcpu_switch_def vcpu_proj_of_state supply if_split[split del] if_split[where P="\v. _ = v", simp] - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' | wp dmo_lift_vcpu_proj)+ + apply (wpsimp wp: dmo_lift_vcpu_proj hoare_vcg_all_lift hoare_vcg_imp_lift') apply (auto simp: insert_commute cur_vcpu_of_def split: if_splits) done @@ -2221,11 +2265,15 @@ lemma vcpu_flush_integrity_hyp[wp]: vcpu_flush \\_. integrity_hyp aag subjects x st\" unfolding integrity_hyp_def vcpu_integrity_def vcpu_flush_def vcpu_proj_of_state + apply (rule hoare_weaken_pre) + apply (rule hoare_vcg_conj_lift, solves wpsimp) + apply (rule hoare_vcg_imp_lift, solves wpsimp) + apply (rule hoare_vcg_conj_lift, solves wpsimp) supply if_split[split del] if_split[where P="\v. _ = v", simp] apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_pre_cont[where f=vcpu_invalidate_active and P="\_ s. cur_vcpu_of s x = Some _"] | strengthen None_Some_strg)+ - apply (fastforce simp: cur_vcpu_of_def split: if_splits) + apply (auto simp: insert_commute cur_vcpu_of_def split: if_splits) done crunch vcpu_flush diff --git a/proof/access-control/Access.thy b/proof/access-control/Access.thy index 081778de37..2561adb1b9 100644 --- a/proof/access-control/Access.thy +++ b/proof/access-control/Access.thy @@ -669,6 +669,8 @@ inductive integrity_obj_alt for aag activate subjects l' ko ko' where "\ tro_tag TCBGeneric; ko = Some (TCB tcb); ko' = Some (TCB tcb'); tcb' = tcb \tcb_arch := new_arch, tcb_bound_notification := ntfn', tcb_caller := cap', tcb_ctable := ccap'\; + tcb_ctable tcb = ccap' \ tcb_caller tcb = cap' \ tcb_bound_notification tcb = ntfn' + \ arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb); tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb); tcb_bound_notification_reset_integrity (tcb_bound_notification tcb) ntfn' subjects aag ; reply_cap_deletion_integrity subjects aag (tcb_caller tcb) cap'; diff --git a/proof/access-control/Access_AC.thy b/proof/access-control/Access_AC.thy index 8d1630ca95..6111dd34dd 100644 --- a/proof/access-control/Access_AC.thy +++ b/proof/access-control/Access_AC.thy @@ -603,6 +603,7 @@ lemma tro_alt_trans_spec: (* this takes a long time to process *) apply (find_goal \match premises in "tro_tag TCBGeneric" and "tro_tag' TCBRestart" \ -\) subgoal + apply (thin_tac "_ \ _") apply (erule integrity_obj_alt.intros[simplified tro_tag_to_prime]) apply (simp | rule tcb.equality | fastforce)+ done @@ -638,14 +639,33 @@ lemma tro_alt_trans_spec: (* this takes a long time to process *) simp: arch_tro_alt_trans_spec\\) (* TCB-TCB steps, somewhat slow *) + apply (all \fails \erule thin_rl[of "tro_tag TCBGeneric"], + erule thin_rl[of "tro_tag' TCBGeneric"]\ + | time_methods \solves \ + erule integrity_obj_alt.intros[simplified tro_tag_to_prime], + (assumption | rule refl + | ((erule exE)+)?, (rule exI)?, + force intro: tcb.equality + simp: reply_cap_deletion_integrity_def + tcb_bound_notification_reset_integrity_def)+\\\) + + apply (all \fails \erule thin_rl[of "tro_tag TCBGeneric"]\ + | time_methods \solves \ + (thin_tac \_ \ _\)?, + erule integrity_obj_alt.intros[simplified tro_tag_to_prime], + (assumption | rule refl + | ((erule exE)+)?, (rule exI)?, force intro: tcb.equality)+\\\) + apply (all \fails \erule thin_rl[of "tro_tag TCBGeneric"]\ | time_methods \solves \ + thin_tac \_ \ _\, erule integrity_obj_alt.intros[simplified tro_tag_to_prime], (assumption | rule refl | ((erule exE)+)?, (rule exI)?, force intro: tcb.equality)+\\\) apply (all \fails \erule thin_rl[of "tro_tag' TCBGeneric"]\ | time_methods \solves \ + (thin_tac \_ \ _\)?, erule integrity_obj_alt.intros, (assumption | rule refl | (elim exE)?, (intro exI)?, fastforce intro: tcb.equality @@ -777,6 +797,7 @@ lemma cdt_direct_change_allowed_backward: by (drule spec, erule integrity_objE, erule cdca_owned; (elim exE)?; + (thin_tac "_ \ _")?; simp; rule cdca_reply[rotated], assumption, assumption, fastforce elim:tcb_states_of_state_kheapI simp:direct_call_def) From 4bd1e0ccb8780e4581d7bb48c1e561f0780608a1 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Wed, 10 Jun 2026 12:12:20 +1000 Subject: [PATCH 05/11] aarch64 infoflow: prove noninterference Signed-off-by: Ryan Barry --- proof/infoflow/AARCH64/ArchADT_IF.thy | 227 +- proof/infoflow/AARCH64/ArchArch_IF.thy | 3014 ++++++++++++++--- proof/infoflow/AARCH64/ArchCNode_IF.thy | 58 +- proof/infoflow/AARCH64/ArchDecode_IF.thy | 274 +- proof/infoflow/AARCH64/ArchFinalCaps.thy | 203 +- proof/infoflow/AARCH64/ArchFinalise_IF.thy | 980 +++++- proof/infoflow/AARCH64/ArchIRQMasks_IF.thy | 184 +- proof/infoflow/AARCH64/ArchInfoFlow.thy | 79 +- proof/infoflow/AARCH64/ArchInfoFlow_IF.thy | 454 ++- proof/infoflow/AARCH64/ArchInterrupt_IF.thy | 29 +- proof/infoflow/AARCH64/ArchIpc_IF.thy | 61 +- .../infoflow/AARCH64/ArchNoninterference.thy | 510 ++- proof/infoflow/AARCH64/ArchPasUpdates.thy | 37 +- proof/infoflow/AARCH64/ArchRetype_IF.thy | 150 +- proof/infoflow/AARCH64/ArchScheduler_IF.thy | 1316 ++++++- proof/infoflow/AARCH64/ArchSyscall_IF.thy | 272 +- proof/infoflow/AARCH64/ArchTcb_IF.thy | 208 +- proof/infoflow/AARCH64/ArchUserOp_IF.thy | 278 +- .../infoflow/AARCH64/Example_Valid_State.thy | 4 +- proof/infoflow/ADT_IF.thy | 350 +- proof/infoflow/Arch_IF.thy | 153 +- proof/infoflow/CNode_IF.thy | 37 +- proof/infoflow/Decode_IF.thy | 4 +- proof/infoflow/FinalCaps.thy | 86 +- proof/infoflow/Finalise_IF.thy | 56 +- proof/infoflow/IRQMasks_IF.thy | 103 +- proof/infoflow/InfoFlow.thy | 43 +- proof/infoflow/InfoFlow_IF.thy | 409 ++- proof/infoflow/Interrupt_IF.thy | 10 +- proof/infoflow/Ipc_IF.thy | 41 +- proof/infoflow/Noninterference.thy | 553 +-- proof/infoflow/Noninterference_Base.thy | 2 +- proof/infoflow/PasUpdates.thy | 5 +- proof/infoflow/Retype_IF.thy | 38 +- proof/infoflow/Scheduler_IF.thy | 576 ++-- proof/infoflow/Syscall_IF.thy | 78 +- proof/infoflow/Tcb_IF.thy | 28 +- proof/infoflow/UserOp_IF.thy | 26 +- 38 files changed, 8772 insertions(+), 2164 deletions(-) diff --git a/proof/infoflow/AARCH64/ArchADT_IF.thy b/proof/infoflow/AARCH64/ArchADT_IF.thy index 3661d2d0c7..9ba925bcb5 100644 --- a/proof/infoflow/AARCH64/ArchADT_IF.thy +++ b/proof/infoflow/AARCH64/ArchADT_IF.thy @@ -15,10 +15,105 @@ theory ArchADT_IF imports ADT_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems ADT_IF_assms +lemmas [ADT_IF_assms] = + thread_set_no_etcb_change_cur_fpu_in_cur_domain + thread_set_no_etcb_change_cur_vcpu_in_cur_domain + handle_event_valid_cur_vcpu + cur_vcpu_in_cur_domain_updates + cur_fpu_in_cur_domain_updates + +lemma dmo_getActiveIRQ_wp'[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False st and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (fastforce simp: domain_sep_inv_def non_kernel_IRQs_def + valid_irq_states_def valid_irq_masks_def irq_at_def) + done + +lemma dmo_getActiveIRQ_wp[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\))\ + do_machine_op (getActiveIRQ False) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma thread_set_valid_cur_vcpu_unchanged_strong: + "\\tcb. tcb_vcpu (tcb_arch (f tcb)) = tcb_vcpu (tcb_arch tcb); \tcb. tcb_domain (f tcb) = tcb_domain tcb\ + \ thread_set f tptr \valid_cur_vcpu\" + apply (rule valid_cur_vcpu_lift_weak; (solves wpsimp)?) + apply (clarsimp simp: thread_set_def) + apply (wpsimp wp: set_object_wp) + apply (fastforce simp: pred_tcb_at_def obj_at_def get_tcb_def) + apply (clarsimp simp: in_cur_domain_def) + apply (wp_pre, wps, wpsimp wp: thread_set_no_change_etcb_at, clarsimp) + done + +lemma thread_set_tcb_context_valid_cur_vcpu[ADT_IF_assms,wp]: + "thread_set (tcb_arch_update (arch_tcb_context_set tc)) tcb \valid_cur_vcpu\" + by (wpsimp wp: thread_set_valid_cur_vcpu_unchanged_strong simp: arch_tcb_context_set_def) + +crunch do_user_op_if + for cur_vcpu_in_cur_domain[ADT_IF_assms,wp]: "cur_vcpu_in_cur_domain" + and cur_fpu_in_cur_domain[ADT_IF_assms,wp]: "cur_fpu_in_cur_domain" + and valid_cur_vcpu[ADT_IF_assms,wp]: "valid_cur_vcpu" + (simp: do_user_op_if_def) + +lemma deleted_irq_handler_valid_irq_states[ADT_IF_assms,wp]: + "deleted_irq_handler irq \valid_irq_states\" + unfolding deleted_irq_handler_def set_irq_state_def valid_irq_states_def valid_irq_masks_def maskInterrupt_def + by (wpsimp wp: dmo_wp) + +lemma dmo_getActiveIRQ_valid_irq_states[ADT_IF_assms,wp]: + "do_machine_op (getActiveIRQ in_kernel) \valid_irq_states\" + unfolding getActiveIRQ_def by wpsimp + +crunch prepare_thread_delete, arch_finalise_cap, arch_post_cap_deletion + for valid_irq_states[ADT_IF_assms,wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemmas [ADT_IF_assms] = + maybe_handle_interrupt_cur_vcpu_in_cur_domain + maybe_handle_interrupt_cur_fpu_in_cur_domain + maybe_handle_interrupt_valid_cur_vcpu + handle_event_cur_vcpu_in_cur_domain + handle_event_cur_fpu_in_cur_domain + schedule_cur_vcpu_in_cur_domain + schedule_cur_fpu_in_cur_domain + schedule_valid_cur_vcpu + activate_thread_cur_vcpu_in_cur_domain + activate_thread_cur_fpu_in_cur_domain + activate_thread_valid_cur_vcpu + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms[folded valid_cur_hyp_def cur_hyp_in_cur_domain_def])?) +qed + + +context Arch begin arch_global_naming + (* FIXME: clagged from AInvs.do_user_op_invs *) lemma do_user_op_if_invs[ADT_IF_assms]: "\invs and ct_running\ @@ -79,13 +174,7 @@ lemma do_use_op_guarded_pas_domain[ADT_IF_assms, wp]: lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" - by (simp add: tcb_arch_ref_def) - -crunch arch_switch_to_idle_thread, arch_switch_to_thread - for pspace_aligned[ADT_IF_assms, wp]: "\s :: det_state. pspace_aligned s" - and valid_vspace_objs[ADT_IF_assms, wp]: "\s :: det_state. valid_vspace_objs s" - and valid_arch_state[ADT_IF_assms, wp]: "\s :: det_state. valid_arch_state s" - (wp: crunch_wps simp: crunch_simps) + by (simp add: tcb_arch_ref_def arch_tcb_context_set_def) crunch arch_activate_idle_thread, arch_switch_to_thread for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" @@ -106,14 +195,14 @@ lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: by (cases a; wpsimp) lemma getActiveIRQ_None[ADT_IF_assms]: - "(None,s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) \ + "(None,s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) by simp lemma getActiveIRQ_Some[ADT_IF_assms]: - "(Some i, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some i, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) @@ -165,12 +254,14 @@ lemma idle_globals_lift_scheduler: lemma invs_pt_not_idle_thread[intro]: "invs s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + apply clarsimp + apply (frule invs_valid_idle) + apply (frule invs_valid_global_arch_objs) by (fastforce dest: valid_global_arch_objs_pt_at - simp: invs_def valid_state_def valid_arch_state_def valid_global_objs_def - obj_at_def valid_idle_def pred_tcb_at_def empty_table_def) + simp: obj_at_def valid_idle_def pred_tcb_at_def) lemma kernel_entry_if_idle_equiv[ADT_IF_assms]: - "\invs and (\s. e \ Interrupt \ ct_active s) and idle_equiv st + "\invs and (\s. e \ Interrupt \ ct_active s) and domain_sep_inv irqs st and idle_equiv st and (\s. ct_idle s \ tc = idle_context s)\ kernel_entry_if e tc \\_. idle_equiv st\" @@ -235,11 +326,18 @@ lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: | wps |wp dmo_wp | wpc)+ done -crunch set_flags +crunch set_flags, arch_post_set_flags for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" +lemma checked_cap_insert_valid_irq_states[wp]: + "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \valid_irq_states\" + by (wpsimp simp: check_cap_at_def)+ + +crunch set_mcpriority + for valid_irq_states[wp]: valid_irq_states + lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: - "\(\s. irq_state_inv st s) and domain_sep_inv False sta + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" @@ -252,7 +350,8 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: defer apply ((wp irq_state_inv_triv | simp)+)[2] apply (simp add: split_def cong: option.case_cong) - by (wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + by (clarsimp split del: if_split cong: conj_cong + | wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R checked_cap_insert_domain_sep_inv cap_delete_deletes cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] @@ -264,24 +363,43 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | wp (once) irq_state_inv_triv hoare_drop_imps | clarsimp split: option.splits | intro impI conjI allI)+ +crunch freeMemory + for irq_masks[wp]: "\s. P (irq_masks s)" + (wp: mapM_x_wp) + +lemma valid_irq_states_kheap_update[simp]: + "valid_irq_states (kheap_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch delete_objects + for valid_irq_states[wp]: valid_irq_states + (wp: dmo_machine_state_lift simp: crunch_simps detype_def) + lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" apply (cases "irq_is_recurring irq st", simp_all) apply (simp add: reset_untyped_cap_def) apply (rule hoare_pre) - apply (wp no_irq_clearMemory mapME_x_wp' hoare_vcg_const_imp_lift - get_cap_wp preemption_point_irq_state_inv'[where irq=irq] - | rule irq_state_inv_triv - | simp add: unless_def - | wp (once) dmo_wp)+ - done + by (wp no_irq_clearMemory hoare_vcg_const_imp_lift set_cap_domain_sep_inv + hoare_post_addE[where Q'="domain_sep_inv False sta and valid_irq_states", OF mapME_x_wp'] + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule hoare_vcg_conj_lift + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp + | fastforce)+ + +lemma handle_vm_fault_irq_state_of_state[ADT_IF_assms]: + "handle_vm_fault thread fault \\s. P (irq_state_of_state s)\" + unfolding handle_vm_fault_def addressTranslateS1_def + by (wpsimp wp: dmo_wp) + +lemma handle_hypervisor_fault_irq_state_of_state[ADT_IF_assms]: + "handle_hypervisor_fault thread fault \\s. P (irq_state_of_state s)\" + by (cases fault, wpsimp wp: dmo_wp split_del: if_split) -crunch - handle_vm_fault, handle_hypervisor_fault - for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" - (wp: crunch_wps dmo_wp simp: crunch_simps) text \Not true of invoke_untyped any more.\ crunch create_cap @@ -297,35 +415,50 @@ crunch arch_invoke_irq_control lemma handle_reserved_irq_non_kernel_IRQs[ADT_IF_assms]: "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" - by (wpsimp simp: handle_reserved_irq_def) - -lemma thread_set_pas_refined[ADT_IF_assms]: - assumes cps: "\tcb. \(getF, v)\ran tcb_cap_cases. getF (f tcb) = getF tcb" - and st: "\tcb. tcb_state (f tcb) = tcb_state tcb" - and ntfn: "\tcb. tcb_bound_notification (f tcb) = tcb_bound_notification tcb" - and dom: "\tcb. tcb_domain (f tcb) = tcb_domain tcb" - shows "thread_set f t \pas_refined aag\" - by (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_state_vrefs thread_set_edomains[OF dom] - simp: pas_refined_def state_objs_to_policy_def - | wps thread_set_caps_of_state_trivial[OF cps] - thread_set_thread_st_auth_trivT[OF st] - thread_set_thread_bound_ntfns_trivT[OF ntfn])+ + unfolding handle_reserved_irq_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: when_wp[where P'="\"] simp: non_kernel_IRQs_def irq_vppi_event_index_def) + done + +lemma thread_set_context_state_hyp_refs_of: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \\s. P (state_hyp_refs_of s)\" + apply (wpsimp simp: thread_set_def wp: set_object_wp) + apply (erule_tac P=P in back_subst) + apply (rule ext) + apply (simp add: state_hyp_refs_of_def get_tcb_def arch_tcb_context_set_def + split: option.splits kernel_object.splits) + done + +lemma thread_set_context_pas_refined[ADT_IF_assms]: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" + unfolding pas_refined_def state_objs_to_policy_def + apply (rule hoare_weaken_pre) + apply (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_edomains) + apply (wps thread_set_state_vrefs thread_set_context_state_hyp_refs_of) + apply (rule hoare_lift_Pf2[where f="caps_of_state"]) + apply (rule hoare_lift_Pf2[where f="thread_st_auth"]) + apply (rule hoare_lift_Pf2[where f="thread_bound_ntfns"]) + apply wp + apply (wpsimp wp: thread_set_thread_bound_ntfns_trivT) + apply (wpsimp wp: thread_set_thread_st_auth_trivT) + apply (wpsimp wp: thread_set_caps_of_state_trivial simp: ran_tcb_cap_cases) + apply simp + done + +crunch init_arch_objects + for irq_states_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp) end -global_interpretation ADT_IF_1?: ADT_IF_1 +global_interpretation ADT_IF_2?: ADT_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact ADT_IF_assms | wp init_arch_objects_inv)?) + by (unfold_locales; (fact ADT_IF_assms)?) qed sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. - -hide_fact ADT_IF_1.do_user_op_silc_inv -requalify_facts AARCH64.do_user_op_silc_inv -declare do_user_op_silc_inv[wp] - end diff --git a/proof/infoflow/AARCH64/ArchArch_IF.thy b/proof/infoflow/AARCH64/ArchArch_IF.thy index bf70ea7386..d57c2b58fd 100644 --- a/proof/infoflow/AARCH64/ArchArch_IF.thy +++ b/proof/infoflow/AARCH64/ArchArch_IF.thy @@ -8,7 +8,35 @@ theory ArchArch_IF imports Arch_IF begin -context Arch begin global_naming AARCH64 +(* FIXME AARCH64 IF: consider modelling some of these *) +axiomatization dmo_reads_respects where + dmo_getESR_reads_respects: "reads_respects aag l \ (do_machine_op AARCH64.getESR)" and + dmo_getFAR_reads_respects: "reads_respects aag l \ (do_machine_op AARCH64.getFAR)" and + dmo_doSMC_mop_reads_respects: "reads_respects aag l \ (do_machine_op (AARCH64.doSMC_mop args))" and + dmo_addressTranslateS1_reads_respects: "reads_respects aag l \ (do_machine_op (AARCH64.addressTranslateS1 w))" + +(* Axioms cannot be defined inside the Arch locale. To circumvent this, we define Arch-specific + copies of the axioms, then hide the original axioms from the generic context. *) + +context Arch begin arch_global_naming + +(* Define new copies of the axioms that are only visible in the Arch locale *) +lemmas dmo_getESR_reads_respects = dmo_getESR_reads_respects +lemmas dmo_getFAR_reads_respects = dmo_getFAR_reads_respects +lemmas dmo_doSMC_mop_reads_respects = dmo_doSMC_mop_reads_respects +lemmas dmo_addressTranslateS1_reads_respects = dmo_addressTranslateS1_reads_respects + +end + +(* Hide the original axioms *) +hide_fact + dmo_getESR_reads_respects + dmo_getFAR_reads_respects + dmo_doSMC_mop_reads_respects + dmo_addressTranslateS1_reads_respects + + +context Arch begin arch_global_naming named_theorems Arch_IF_assms @@ -61,6 +89,13 @@ crunch set_irq_state, arch_post_cap_deletion, handle_arch_fault_reply for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" (wp: crunch_wps dmo_wp simp: crunch_simps maskInterrupt_def) +crunch readVCPUHardwareReg, check_export_arch_timer, writeVCPUHardwareReg, maskInterrupt, + enableFpuEL01, isb, dsb, setHCR, setSCTLR, sendSGI, set_gic_vcpu_ctrl_hcr, + set_gic_vcpu_ctrl_lr, set_gic_vcpu_ctrl_apr, set_gic_vcpu_ctrl_vmcr, get_gic_vcpu_ctrl_hcr, + get_gic_vcpu_ctrl_lr, get_gic_vcpu_ctrl_apr, get_gic_vcpu_ctrl_vmcr, do_flush, + invalidateTranslationASID, writeFpuState, disableFpu, enableFpu, deactivateInterrupt + for irq_state[wp]: "\ms. P (irq_state ms)" + crunch arch_switch_to_idle_thread, arch_switch_to_thread for irq_state_of_state[Arch_IF_assms, wp]: "\s :: det_state. P (irq_state_of_state s)" (wp: dmo_wp modify_wp crunch_wps whenE_wp @@ -69,17 +104,17 @@ crunch arch_switch_to_idle_thread, arch_switch_to_thread crunch arch_invoke_irq_handler for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" - (wp: dmo_wp simp: maskInterrupt_def plic_complete_claim_def) + (wp: dmo_wp simp: maskInterrupt_def) crunch arch_perform_invocation for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" - (wp: dmo_wp modify_wp simp: cache_machine_op_defs + (wp: dmo_wp modify_wp simp: cache_machine_op_defs doSMC_mop_def wp: crunch_wps simp: crunch_simps ignore: ignore_failure) crunch arch_finalise_cap, prepare_thread_delete for irq_state_of_state[Arch_IF_assms, wp]: "\s :: det_state. P (irq_state_of_state s)" (wp: modify_wp crunch_wps dmo_wp - simp: crunch_simps hwASIDFlush_def) + simp: crunch_simps) lemma equiv_asid_machine_state_update[Arch_IF_assms, simp]: "equiv_asid asid (machine_state_update f s) s' = equiv_asid asid s s'" @@ -101,17 +136,9 @@ lemma as_user_set_register_reads_respects'[Arch_IF_assms]: lemma store_word_offs_reads_respects[Arch_IF_assms]: "reads_respects aag l \ (store_word_offs ptr offs v)" - apply (simp add: store_word_offs_def) - apply (rule equiv_valid_get_assert) - apply (simp add: storeWord_def) - apply (simp add: do_machine_op_bind) - apply wp - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad) - apply (fastforce intro: equiv_forI elim: equiv_forE simp: upto.simps comp_def) - apply (rule use_spec_ev do_machine_op_spec_reads_respects assert_ev2 - | simp add: spec_equiv_valid_def | wp modify_wp)+ + apply (simp add: store_word_offs_def storeWord_def do_machine_op_bind) + apply (wpsimp wp: equiv_valid_get_assert do_machine_op_reads_respects assert_ev2 modify_ev + | fastforce intro: equiv_forI elim: equiv_forE simp: upto.simps comp_def)+ done lemma set_simple_ko_globals_equiv[Arch_IF_assms]: @@ -139,8 +166,8 @@ lemma set_thread_state_globals_equiv[Arch_IF_assms]: split: option.splits kernel_object.splits)+ done -lemma set_cap_globals_equiv''[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state\ +lemma set_cap_globals_equiv'[Arch_IF_assms]: + "\globals_equiv s and valid_global_arch_objs\ set_cap cap p \\_. globals_equiv s\" unfolding set_cap_def @@ -150,26 +177,34 @@ lemma set_cap_globals_equiv''[Arch_IF_assms]: dest: valid_global_arch_objs_pt_at)+ done -lemma as_user_globals_equiv[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" - unfolding as_user_def - apply (wpsimp wp: set_object_globals_equiv simp: split_def) - apply (fastforce simp: valid_arch_state_def get_tcb_def obj_at_def - dest: valid_global_arch_objs_pt_at) - done +lemma thread_set_non_idle_globals_equiv[Arch_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + by (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def + dest: valid_global_arch_objs_pt_at) + +crunch arch_prepare_set_domain, arch_prepare_next_domain + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + +lemma equiv_hyp_machine_state_rest_update[Arch_IF_assms]: + "equiv_hyp P st (s\machine_state := ms\machine_state_rest := r\\) = equiv_hyp P st (s\machine_state := ms\)" + by (simp add: equiv_hyp_def equiv_for_def) -declare arch_prepare_set_domain_inv[Arch_IF_assms] -declare arch_prepare_next_domain_inv[Arch_IF_assms] +lemma equiv_fpu_machine_state_rest_update[Arch_IF_assms]: + "equiv_fpu P st (s\machine_state := ms\machine_state_rest := r\\) = equiv_fpu P st (s\machine_state := ms\)" + by (simp add: equiv_fpu_def equiv_for_def) end -requalify_facts - AARCH64.set_simple_ko_globals_equiv - AARCH64.retype_region_irq_state_of_state - AARCH64.arch_perform_invocation_irq_state_of_state +(* FIXME AARCH64 IF: add to interface *) +arch_requalify_facts + set_simple_ko_globals_equiv + retype_region_irq_state_of_state + arch_perform_invocation_irq_state_of_state declare retype_region_irq_state_of_state[wp] @@ -190,7 +225,7 @@ lemmas invs_imps = invs_cur invs_kernel_mappings -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma get_asid_pool_revrv': "reads_equiv_valid_rv_inv (affects_equiv aag l) aag @@ -249,15 +284,8 @@ lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq: apply (fastforce simp: equiv_asids_def equiv_asid_def intro: aag_can_read_own_asids) done -lemma set_vm_root_states_equiv_for[wp]: - "set_vm_root thread \states_equiv_for P Q R S st\" - unfolding set_vm_root_def catch_def fun_app_def - by (wpsimp wp: do_machine_op_mol_states_equiv_for - hoare_vcg_all_lift whenE_wp hoare_drop_imps - simp: setVSpaceRoot_def dmo_bind_valid if_apply_def2)+ - lemma find_vspace_for_asid_reads_respects: - "reads_respects aag l (K (asid \ 0 \ aag_can_read_asid aag asid)) (find_vspace_for_asid asid)" + "reads_respects aag l (K (aag_can_read_asid aag asid)) (find_vspace_for_asid asid)" unfolding find_vspace_for_asid_def apply wpsimp apply (simp add: throw_opt_def) @@ -268,16 +296,35 @@ lemma find_vspace_for_asid_reads_respects: apply (erule equiv_forE) apply (erule_tac x=asid in allE) apply clarsimp - apply (fastforce simp: vspace_for_asid_def pool_for_asid_def vspace_for_pool_def + apply (fastforce simp: vspace_for_asid_def entry_for_asid_def entry_for_pool_def + pool_for_asid_def vspace_for_pool_def opt_map_def obind_def obj_at_def equiv_asid_def split: option.splits) done +crunch invalidate_tlb_by_asid + for states_equiv_for[wp]: "states_equiv_for P Q R S st" + and scheduler_action[wp]: "\s. P (scheduler_action s)" + and work_units_completed[wp]: "\s. P (work_units_completed s)" + (wp: do_machine_op_mol_states_equiv_for ignore: do_machine_op simp: invalidateTranslationASID_def) + +lemma invalidate_tlb_by_asid_reads_respects: + "reads_respects aag l (\_. True) (invalidate_tlb_by_asid asid)" + by (wpsimp wp: reads_respects_unobservable_unit_return) + +lemma invalidate_tlb_by_asid_va_reads_respects: + "reads_respects aag l \ (invalidate_tlb_by_asid_va asid vaddr)" + unfolding invalidate_tlb_by_asid_va_def invalidateTranslationSingle_def + by (wpsimp wp: reads_respects_unobservable_unit_return do_machine_op_mol_states_equiv_for) + lemma ptes_of_reads_equiv: - "\ is_subject aag (table_base ptr); reads_equiv aag s t \ - \ ptes_of s ptr = ptes_of t ptr" + "\ is_subject aag (table_base pt_t ptr); reads_equiv aag s t \ + \ ptes_of s pt_t ptr = ptes_of t pt_t ptr" by (fastforce elim: reads_equivE equiv_forE simp: ptes_of_def obind_def opt_map_def) +(* FIXME AARCH64 IF: consolidate with ArchArchAcc_R *) +lemmas bit_pred = bit0.pred bit1.pred + lemma pt_walk_reads_equiv: "\ reads_equiv aag s t; pas_refined aag s; pspace_aligned s; valid_asid_table s; valid_vspace_objs s; is_subject aag pt; vptr \ user_region; @@ -287,15 +334,15 @@ lemma pt_walk_reads_equiv: apply (induct level arbitrary: pt; clarsimp) apply (simp (no_asm) add: pt_walk.simps) apply (clarsimp simp: obind_def split: if_splits) - apply (subgoal_tac "ptes_of s (pt_slot_offset level pt vptr) = - ptes_of t (pt_slot_offset level pt vptr)") + apply (subgoal_tac "ptes_of s (level_type level) (pt_slot_offset level pt vptr) = + ptes_of t (level_type level) (pt_slot_offset level pt vptr)") apply (clarsimp split: option.splits) apply (frule_tac bot_level="level-1" in vs_lookup_table_extend) apply (fastforce simp: pt_walk.simps obind_def) apply clarsimp apply (erule_tac x="pptr_from_pte x2" in meta_allE) apply (drule meta_mp) - apply (subst (asm) vs_lookup_split_Some[OF order_less_imp_le[OF bit0.pred]]) + apply (subst (asm) vs_lookup_split_Some[OF order_less_imp_le], rule bit_pred) apply fastforce+ apply (erule_tac pt_ptr=pt in pt_walk_is_subject; fastforce) apply (erule (1) meta_mp) @@ -320,8 +367,7 @@ lemma pt_lookup_from_level_reads_respects: apply (frule vs_lookup_table_is_aligned; clarsimp) apply (prop_tac "pt_walk level (level - 1) pt vref (ptes_of s) = Some (level - 1, pptr_from_pte rv)") - apply (fastforce simp: vs_lookup_split_Some[OF order_less_imp_le[OF bit0.pred]] - pt_walk.simps obind_def) + apply (fastforce simp: pt_walk.simps obind_def) apply (rule conjI) apply (erule_tac level=level and bot_level="level-1" and pt_ptr=pt in pt_walk_is_subject; fastforce) apply (rule_tac x=asid in exI) @@ -333,13 +379,12 @@ lemma unmap_page_table_reads_respects: (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table and K (asid \ 0 \ is_subject_asid aag asid \ vaddr \ user_region)) (unmap_page_table asid vaddr pt)" - unfolding unmap_page_table_def fun_app_def + unfolding unmap_page_table_def fun_app_def cleanByVA_PoU_def apply (rule gen_asm_ev) apply (rule equiv_valid_guard_imp) - apply (wp dmo_mol_reads_respects store_pte_reads_respects get_pte_rev - pt_lookup_from_level_reads_respects pt_lookup_from_level_is_subject - find_vspace_for_asid_wp find_vspace_for_asid_reads_respects hoare_vcg_all_liftE_R - | wpc | simp add: sfence_def | wp (once) hoare_drop_imps)+ + apply (wp dmo_mol_reads_respects store_pte_reads_respects invalidate_tlb_by_asid_reads_respects + pt_lookup_from_level_reads_respects find_vspace_for_asid_reads_respects + | wpc | simp | fastforce intro: hoare_strengthen_postE_R[OF pt_lookup_from_level_is_subject])+ apply clarsimp apply (frule vspace_for_asid_is_subject) apply (fastforce dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent)+ @@ -354,12 +399,12 @@ lemma perform_page_table_invocation_reads_respects: apply (rule equiv_valid_guard_imp) apply (wp dmo_mol_reads_respects store_pte_reads_respects set_cap_reads_respects mapM_x_ev'' unmap_page_table_reads_respects get_cap_rev - | wpc | simp add: sfence_def)+ + | wpc | simp add: cleanByVA_PoU_def cleanCacheRange_PoU_def)+ apply (case_tac pti; clarsimp simp: authorised_page_table_inv_def) apply (clarsimp simp: valid_pti_def) apply (frule cte_wp_valid_cap) apply fastforce - apply (clarsimp simp: is_PageTableCap_def valid_cap_def wellformed_mapdata_def) + apply (clarsimp simp: is_PageTableCap_def valid_cap_def wellformed_mapdata_def add_mask_fold) done lemma unmap_page_reads_respects: @@ -367,13 +412,12 @@ lemma unmap_page_reads_respects: (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table and K (asid \ 0 \ is_subject_asid aag asid \ vptr \ user_region)) (unmap_page pgsz asid vptr pptr)" - unfolding unmap_page_def catch_def fun_app_def - supply gets_the_ev[wp del] - apply (simp add: unmap_page_def swp_def cong: vmpage_size.case_cong) - apply (simp add: unlessE_def gets_the_def) + unfolding unmap_page_def catch_def fun_app_def cleanByVA_PoU_def + apply (simp add: unmap_page_def unlessE_def gets_the_def cong: vmpage_size.case_cong) apply (wp gets_ev' dmo_mol_reads_respects get_pte_rev throw_on_false_reads_respects find_vspace_for_asid_reads_respects store_pte_reads_respects[simplified] - | wpc | wp (once) hoare_drop_imps | simp add: sfence_def is_aligned_mask[symmetric])+ + invalidate_tlb_by_asid_va_reads_respects + | wpc | simp add: is_aligned_mask[symmetric])+ apply (clarsimp simp: pt_lookup_slot_def) apply (frule (3) vspace_for_asid_is_subject) apply safe @@ -386,6 +430,13 @@ lemma unmap_page_reads_respects: dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent)+ done +lemma perform_flush_reads_respects: + "reads_respects aag l \ (perform_flush type vstart vend pstart space asid)" + unfolding perform_flush_def do_flush_def isb_def dsb_def + cleanCacheRange_PoU_def invalidateCacheRange_I_def + cleanInvalidateCacheRange_RAM_def cleanCacheRange_RAM_def invalidateCacheRange_RAM_def + by (cases type; wpsimp wp: dmo_mol_reads_respects when_ev simp: dmo_distr) + lemma perform_page_invocation_reads_respects: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows @@ -394,17 +445,18 @@ lemma perform_page_invocation_reads_respects: and pspace_aligned and is_subject aag \ cur_thread) (perform_page_invocation pgi)" unfolding perform_page_invocation_def fun_app_def when_def perform_pg_inv_map_def - perform_pg_inv_unmap_def perform_pg_inv_get_addr_def + perform_pg_inv_unmap_def perform_pg_inv_get_addr_def cleanByVA_PoU_def apply (rule equiv_valid_guard_imp) apply (wp dmo_mol_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects - mapM_ev'' store_pte_reads_respects unmap_page_reads_respects dmo_mol_2_reads_respects + mapM_ev'' store_pte_reads_respects unmap_page_reads_respects get_cap_rev set_mrs_reads_respects set_message_info_reads_respects - | simp add: sfence_def + invalidate_tlb_by_asid_va_reads_respects get_pte_rev perform_flush_reads_respects + | simp add: dmo_distr | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ - apply (clarsimp simp: authorised_page_inv_def valid_page_inv_def) - apply (auto simp: cte_wp_at_caps_of_state authorised_slots_def cap_links_asid_slot_def - label_owns_asid_slot_def valid_arch_cap_def wellformed_mapdata_def - dest!: clas_caps_of_state pas_refined_Control)+ + apply (case_tac pgi; clarsimp simp: authorised_page_inv_def valid_page_inv_def) + apply (auto simp: cte_wp_at_caps_of_state authorised_slots_def cap_links_asid_slot_def + label_owns_asid_slot_def valid_arch_cap_def wellformed_mapdata_def + dest!: clas_caps_of_state pas_refined_Control) done lemma equiv_asids_arm_asid_table_update: @@ -418,7 +470,7 @@ lemma equiv_asids_arm_asid_table_update: lemma arm_asid_table_update_reads_respects: "reads_respects aag l (K (is_subject aag pool_ptr)) - (do r \ gets (arm_asid_table \ arch_state); + (do r \ gets asid_table; modify (\s. s\arch_state := arch_state s\arm_asid_table := r(asid_high_bits_of asid \ pool_ptr)\\) od)" @@ -431,14 +483,15 @@ lemma arm_asid_table_update_reads_respects: apply (rule modify_ev2) apply clarsimp apply (drule (1) is_subject_kheap_eq[rotated]) - apply (fastforce simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def - intro!: equiv_asids_arm_asid_table_update) + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def + equiv_for_def equiv_hyp_def equiv_fpu_def) + apply (fastforce intro!: equiv_asids_arm_asid_table_update) apply wpsimp done lemma perform_asid_control_invocation_reads_respects: notes K_bind_ev[wp del] - shows "reads_respects aag l (K (authorised_asid_control_inv aag aci)) + shows "reads_respects aag l (invs and ct_active and valid_aci aci and K (authorised_asid_control_inv aag aci)) (perform_asid_control_invocation aci)" unfolding perform_asid_control_invocation_def apply (rule gen_asm_ev) @@ -451,7 +504,7 @@ lemma perform_asid_control_invocation_reads_respects: apply (wpc) apply (rule bind_ev) apply (rule K_bind_ev) - apply (rule_tac P'=\ in bind_ev) + apply (rule_tac bind_ev) apply (rule K_bind_ev) apply (rule bind_ev) apply (rule bind_ev) @@ -470,39 +523,13 @@ lemma set_asid_pool_reads_respects: unfolding set_asid_pool_def by (wpsimp wp: set_object_reads_respects get_asid_pool_rev) -lemma copy_global_mappings_valid_arch_state: - "\valid_arch_state and valid_global_vspace_mappings and pspace_aligned - and (\s. x \ global_refs s \ is_aligned x pt_bits)\ - copy_global_mappings x - \\_. valid_arch_state\" - unfolding copy_global_mappings_def including classic_wp_pre - apply simp - apply wp - apply (rule_tac Q'="\_. valid_arch_state and valid_global_vspace_mappings and pspace_aligned - and (\s. x \ global_refs s \ is_aligned x pt_bits)" - in hoare_strengthen_post) - apply (wp mapM_x_wp[OF _ subset_refl] - store_pte_valid_arch_state_unreachable - store_pte_valid_global_vspace_mappings) - apply (simp only: pt_index_def) - apply (subst table_base_offset_id) - apply clarsimp - apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def - table_size_def ptTranslationBits_def mask_def) - apply (word_bitwise, fastforce) - apply clarsimp - apply (simp_all) - apply (clarsimp simp: valid_arch_state_def) - apply (subst (asm) table_base_plus; simp add: mask_def) - done - lemma set_asid_pool_globals_equiv: - "\globals_equiv s and valid_arch_state\ + "\globals_equiv s and valid_global_arch_objs\ set_asid_pool ptr pool \\_. globals_equiv s\" unfolding set_asid_pool_def apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] simp: a_type_def) - apply (fastforce simp: valid_arch_state_def obj_at_def dest: valid_global_arch_objs_pt_at) + apply (fastforce simp: obj_at_def dest: valid_global_arch_objs_pt_at) done lemma perform_asid_pool_invocation_reads_respects_g: @@ -514,19 +541,11 @@ lemma perform_asid_pool_invocation_reads_respects_g: reads_respects_g[OF get_asid_pool_rev] set_asid_pool_globals_equiv set_cap_reads_respects doesnt_touch_globalsI get_cap_auth_wp[where aag=aag] get_cap_rev - copy_global_mappings_reads_respects_g copy_global_mappings_valid_arch_state set_cap_reads_respects_g get_cap_reads_respects_g | strengthen valid_arch_state_global_arch_objs | wp (once) hoare_drop_imps)+ apply (clarsimp simp: invs_arch_state invs_valid_global_objs invs_psp_aligned - invs_valid_global_vspace_mappings authorised_asid_pool_inv_def - cong: conj_cong) - apply (frule (1) caps_of_state_valid) - apply (clarsimp simp: is_ArchObjectCap_def is_PageTableCap_def - valid_cap_def cap_aligned_def pt_bits_def aag_cap_auth_def - cap_auth_conferred_def arch_cap_auth_conferred_def) - apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply (fastforce dest: pas_refined_Control cap_not_in_valid_global_refs) + invs_valid_global_vspace_mappings authorised_asid_pool_inv_def) done lemma equiv_asids_arm_asid_table_delete: @@ -549,12 +568,12 @@ lemma arm_asid_table_delete_ev2: else rv' a\\))" apply (rule modify_ev2) (* slow 15s *) - by (auto simp: reads_equiv_def2 affects_equiv_def2 + by (auto simp: reads_equiv_def2 affects_equiv_def2 equiv_hyp_def + equiv_fpu_def equiv_for_def get_tcb_def cur_fpu_for_def intro!: states_equiv_forI equiv_forI equiv_asids_arm_asid_table_delete elim!: states_equiv_forE equiv_forE elim: is_subject_kheap_eq[simplified reads_equiv_def2 states_equiv_for_def, rotated]) - lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': "\ (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base \ is_subject_asid aag asid'); reads_equiv aag s t \ @@ -563,7 +582,7 @@ lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': apply (insert asid_high_bits_0_eq_1) apply (case_tac "base = 0") apply (subgoal_tac "is_subject_asid aag 1") - apply simp + apply (simp del: asid_high_bits_of_0) apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq[where aag=aag]) apply (erule_tac x=1 in allE) apply simp+ @@ -572,6 +591,44 @@ lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': apply simp+ done +lemma states_equiv_for_asid_map_update[simp]: + "states_equiv_for P Q R S st (s\arch_state := arch_state s\arm_asid_map := asid_map'\\) = + states_equiv_for P Q R S st s" + by (auto simp: states_equiv_for_def equiv_for_def equiv_hyp_def equiv_fpu_def get_tcb_def cur_fpu_for_def + intro: equiv_asids_triv' split: if_splits) + +lemma states_equiv_for_vmid_table_update[simp]: + "states_equiv_for P Q R S st (s\arch_state := arch_state s\arm_vmid_table := table\\) = + states_equiv_for P Q R S st s" + by (auto simp: states_equiv_for_def equiv_for_def equiv_hyp_def equiv_fpu_def get_tcb_def cur_fpu_for_def + intro: equiv_asids_triv' split: if_splits) + +lemma states_equiv_for_next_vmid_update[simp]: + "states_equiv_for P Q R S st (s\arch_state := arch_state s\arm_next_vmid := vmid\\) = + states_equiv_for P Q R S st s" + by (auto simp: states_equiv_for_def equiv_for_def equiv_hyp_def equiv_fpu_def get_tcb_def cur_fpu_for_def + intro: equiv_asids_triv' split: if_splits) + +crunch get_vmid + for states_equiv_for[wp]: "states_equiv_for P Q R S st" + (wp: do_machine_op_mol_states_equiv_for ignore: do_machine_op simp: invalidateTranslationASID_def) + +lemma set_vm_root_states_equiv_for: + "set_vm_root thread \states_equiv_for P Q R S st\" + unfolding set_vm_root_def catch_def fun_app_def set_global_user_vspace_def arm_context_switch_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for + hoare_vcg_all_lift whenE_wp hoare_drop_imps + simp: setVSpaceRoot_def dmo_bind_valid if_apply_def2)+ + +crunch invalidate_asid_entry + for states_equiv_for[wp]: "states_equiv_for P Q R S st" + +crunch invalidate_asid_entry + for sched_act[wp]: "\s. P (scheduler_action s)" + +crunch invalidate_asid_entry + for wuc[wp]: "\s. P (work_units_completed s)" + lemma delete_asid_pool_reads_respects: "reads_respects aag l (K (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base \ is_subject_asid aag asid')) @@ -593,10 +650,13 @@ lemma delete_asid_pool_reads_respects: apply (rule equiv_valid_2_guard_imp) apply (rule equiv_valid_2_bind) apply (rule equiv_valid_2_bind) - apply (rule equiv_valid_2_unobservable) - apply (wp set_vm_root_states_equiv_for)+ - apply (rule arm_asid_table_delete_ev2) - apply (wp)+ + apply (rule equiv_valid_2_bind) + apply (rule equiv_valid_2_unobservable) + apply (wp set_vm_root_states_equiv_for)+ + apply (rule arm_asid_table_delete_ev2) + apply (wp)+ + apply (rule equiv_valid_2_unobservable) + apply (wpsimp wp: mapM_wp_inv)+ apply (rule equiv_valid_2_unobservable) by (wp mapM_wp' return_ev2 | rule conjI | drule (1) requiv_arm_asid_table_asid_high_bits_of_asid_eq' @@ -634,59 +694,39 @@ lemma set_asid_pool_delete_ev2: (set_asid_pool a (pool(asid_low_bits_of asid := None))) (set_asid_pool a (pool'(asid_low_bits_of asid := None)))" apply (clarsimp simp: equiv_valid_2_def) - apply (frule_tac s'=b in set_asid_pool_state_equal_except_kheap) - apply (frule_tac s'=ba in set_asid_pool_state_equal_except_kheap) - apply (clarsimp simp: states_equal_except_kheap_asid_def) - apply (rule conjI) - apply (clarsimp simp: states_equiv_for_def reads_equiv_def equiv_for_def | rule conjI)+ - apply (case_tac "x=a") - apply (clarsimp simp: opt_map_def split: option.splits) - apply (fastforce) - apply (clarsimp simp: equiv_asids_def equiv_asid_def | rule conjI)+ - apply (case_tac "pool_ptr = a") - apply (clarsimp) - apply (erule_tac x="pasASIDAbs aag asid" in ballE) - apply (clarsimp) - apply (erule_tac x=asid in allE)+ - apply (clarsimp) - apply (drule aag_can_read_own_asids, simp) - apply (erule_tac x="pasASIDAbs aag asida" in ballE) - apply (clarsimp) - apply (erule_tac x=asida in allE)+ - apply (clarsimp) - apply (clarsimp) - apply (clarsimp) - apply (case_tac "pool_ptr=a") - apply (erule_tac x="pasASIDAbs aag asida" in ballE; clarsimp) - apply (clarsimp simp: opt_map_def split: option.splits) - apply (clarsimp simp: affects_equiv_def equiv_for_def states_equiv_for_def | rule conjI)+ - apply (case_tac "x=a") - apply (clarsimp simp: opt_map_def split: option.splits) - apply (fastforce) - apply (clarsimp simp: equiv_asids_def equiv_asid_def | rule conjI)+ - apply (case_tac "pool_ptr=a") - apply (clarsimp simp: opt_map_def split: option.splits) - apply (erule_tac x=asid in allE)+ - apply (clarsimp simp: asid_pool_at_kheap) - apply (erule_tac x=asida in allE)+ - apply (clarsimp) - apply (clarsimp) - apply (case_tac "pool_ptr=a") + apply (erule use_valid) + apply (wpsimp simp: set_asid_pool_def wp: set_object_wp) + apply clarsimp + apply (erule use_valid) + apply (wpsimp simp: set_asid_pool_def wp: set_object_wp) + apply clarsimp + apply (prop_tac "aag_can_read aag a \ aag_can_affect aag l a \ pool = pool'") + apply (erule reads_equivE) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply clarsimp + apply (clarsimp simp: equiv_for_def) + apply (erule affects_equivE) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply clarsimp apply (clarsimp simp: opt_map_def split: option.splits) - apply (clarsimp simp: opt_map_def split: option.splits) + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def opt_map_def | rule conjI)+ done lemma delete_asid_reads_respects: "reads_respects aag l (K (asid \ 0 \ is_subject_asid aag asid)) (delete_asid asid pt)" unfolding delete_asid_def + supply fun_upd_apply[simp del] apply (subst equiv_valid_def2) - apply (rule_tac W="\\" and Q="\rv s. rv = arm_asid_table (arch_state s) \ + apply (rule_tac W="\\" and Q="\rv s. rv = asid_table s (asid_high_bits_of asid) \ is_subject_asid aag asid \ asid \ 0" in equiv_valid_rv_bind) apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) apply (wp, simp) - apply (case_tac "rv (asid_high_bits_of asid) = rv' (asid_high_bits_of asid)") + apply (case_tac "rv = rv'") apply (simp) - apply (case_tac "rv' (asid_high_bits_of asid)") + apply (case_tac "rv") apply (simp) apply (wp return_ev2, simp) apply (simp) @@ -697,44 +737,120 @@ lemma delete_asid_reads_respects: apply (clarsimp | rule conjI)+ apply (rule_tac R'="\\" in equiv_valid_2_bind) apply (rule_tac R'="\\" in equiv_valid_2_bind) - apply (subst equiv_valid_def2[symmetric]) - apply (rule reads_respects_unobservable_unit_return) - apply (wp set_vm_root_states_equiv_for)+ - apply (rule set_asid_pool_delete_ev2) - apply (wp)+ + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (subst equiv_valid_def2[symmetric]) + apply (rule reads_respects_unobservable_unit_return) + apply (wp set_vm_root_states_equiv_for)+ + apply (rule set_asid_pool_delete_ev2) + apply (wp)+ + apply (rule equiv_valid_2_unobservable) + apply (wpsimp wp: do_machine_op_mol_states_equiv_for invalidate_tlb_by_asid_reads_respects)+ + apply (rule equiv_valid_2_unobservable) + apply wpsimp+ + apply (wpsimp wp: hoare_vcg_imp_lift')+ apply (rule equiv_valid_2_unobservable) - apply (wpsimp wp: do_machine_op_mol_states_equiv_for simp: hwASIDFlush_def)+ + apply (wpsimp wp: hoare_vcg_imp_lift')+ apply (clarsimp | rule return_ev2)+ apply (rule equiv_valid_2_guard_imp) apply (wp get_asid_pool_revrv) apply (simp)+ apply (wp)+ - apply (clarsimp simp: asid_pools_of_ko_at obj_at_def)+ + apply (clarsimp simp: obj_at_def)+ apply (clarsimp simp: equiv_valid_2_def reads_equiv_def equiv_asids_def equiv_asid_def states_equiv_for_def) apply (erule_tac x="pasASIDAbs aag asid" in ballE) apply (clarsimp) apply (drule aag_can_read_own_asids) apply wpsimp+ + apply (clarsimp simp: pool_for_asid_def) done +lemma globals_equiv_arm_asid_map_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_asid_map := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + lemma globals_equiv_arm_asid_table_update[simp]: "globals_equiv s (t\arch_state := arch_state t\arm_asid_table := x\\) = globals_equiv s t" by (simp add: globals_equiv_def) +lemma globals_equiv_arm_vmid_table_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_vmid_table := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma globals_equiv_arm_next_vmid_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_next_vmid := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma valid_global_arch_objs_arm_asid_table_update[simp]: + "valid_global_arch_objs (s\arch_state := arch_state s\arm_asid_table := x\\) = valid_global_arch_objs s" + by (simp add: valid_global_arch_objs_def) + +lemma set_global_user_vspace_globals_equiv[wp]: + "set_global_user_vspace \globals_equiv s\" + unfolding set_global_user_vspace_def setVSpaceRoot_def + by wpsimp + +lemma update_asid_pool_entry_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + update_asid_pool_entry f asid + \\_. globals_equiv s\" + unfolding update_asid_pool_entry_def + by (wpsimp wp: set_asid_pool_globals_equiv) + +crunch invalidate_vmid_entry, invalidate_asid + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps dmo_mol_reads_respects simp: crunch_simps) + +lemma find_free_vmid_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + find_free_vmid + \\_. globals_equiv s\" + unfolding find_free_vmid_def invalidateTranslationASID_def + by wpsimp + +crunch get_vmid + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps dmo_mol_reads_respects simp: crunch_simps) + +lemma arm_context_switch_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + arm_context_switch vspace asid + \\_. globals_equiv s\" + unfolding arm_context_switch_def setVSpaceRoot_def + by (wpsimp wp: dmo_mol_reads_respects) + lemma set_vm_root_globals_equiv[wp]: - "set_vm_root tcb \globals_equiv s\" + "\globals_equiv s and valid_global_arch_objs\ + set_vm_root tcb + \\_. globals_equiv s\" by (wpsimp wp: dmo_mol_globals_equiv hoare_vcg_all_lift hoare_drop_imps simp: set_vm_root_def setVSpaceRoot_def) +crunch invalidate_asid_entry + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps dmo_mol_reads_respects simp: crunch_simps) + +lemma invalidate_tlb_by_asid_globals_equiv[wp]: + "invalidate_tlb_by_asid asid \globals_equiv s\" + unfolding invalidate_tlb_by_asid_def invalidateTranslationASID_def + by wpsimp + +lemma invalidate_tlb_by_asid_va_globals_equiv[wp]: + "invalidate_tlb_by_asid_va asid vaddr \globals_equiv s\" + unfolding invalidate_tlb_by_asid_va_def invalidateTranslationSingle_def + by wpsimp + lemma delete_asid_pool_globals_equiv[wp]: - "delete_asid_pool base ptr \globals_equiv s\" + "\globals_equiv s and valid_global_arch_objs\ + delete_asid_pool base ptr + \\_. globals_equiv s\" unfolding delete_asid_pool_def by (wpsimp wp: set_vm_root_globals_equiv mapM_wp[OF _ subset_refl] modify_wp) lemma vs_lookup_slot_not_global: "\ vs_lookup_slot level asid vref s = Some (level, pte); level \ max_pt_level; - pte_refs_of s pte = Some pt; vref \ user_region; invs s \ + pte_refs_of (level_type level) pte s = Some pt; vref \ user_region; invs s \ \ pt \ global_refs s" apply (prop_tac "vs_lookup_target level asid vref s = Some (level, pt)") apply (clarsimp simp: vs_lookup_target_def obind_def split: if_splits) @@ -745,24 +861,9 @@ lemma unmap_page_table_globals_equiv: "\invs and globals_equiv st and K (vaddr \ user_region)\ unmap_page_table asid vaddr pt \\rv. globals_equiv st\" - unfolding unmap_page_table_def - apply (wp store_pte_globals_equiv pt_lookup_from_level_wrp | wpc | simp add: sfence_def)+ - apply clarsimp - apply (rule_tac x=asid in exI) + unfolding unmap_page_table_def cleanByVA_PoU_def + apply (wp store_pte_globals_equiv pt_lookup_from_level_wrp | wpc | simp)+ apply clarsimp - apply (case_tac "level = asid_pool_level") - apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) - apply (drule vs_lookup_slot_table_base; clarsimp) - apply (drule reachable_page_table_not_global, clarsimp+) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - done - -lemma unmap_page_table_valid_arch_state: - "\invs and valid_arch_state and K (vaddr \ user_region)\ - unmap_page_table asid vaddr pt - \\_. valid_arch_state\" - unfolding unmap_page_table_def - apply (wpsimp wp: store_pte_valid_arch_state_unreachable pt_lookup_from_level_wrp simp: sfence_def) apply (rule_tac x=asid in exI) apply clarsimp apply (case_tac "level = asid_pool_level") @@ -773,73 +874,67 @@ lemma unmap_page_table_valid_arch_state: lemma mapM_x_swp_store_pte_globals_equiv: "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)\ - mapM_x (swp store_pte pte) slots + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)\ + mapM_x (swp (store_pte pt_t) pte) slots \\_. globals_equiv s\" apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)" + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)" in hoare_strengthen_post) apply (wp mapM_x_wp' store_pte_valid_arch_state_unreachable store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ - apply (clarsimp simp: valid_arch_state_def) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply auto + apply (auto simp: global_refs_def) done lemma mapM_x_swp_store_pte_valid_ko_at_arch[wp]: "\pspace_aligned and valid_arch_state and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)\ - mapM_x (swp store_pte A) slots + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)\ + mapM_x (swp (store_pte pt_t) pte) slots \\_. valid_arch_state\" apply (rule_tac Q'="\_. pspace_aligned and valid_arch_state and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)" + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)" in hoare_strengthen_post) apply (wp mapM_x_wp' store_pte_valid_arch_state_unreachable store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ - apply (clarsimp simp: valid_arch_state_def) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply auto done definition authorised_for_globals_page_table_inv :: "page_table_invocation \ 's :: state_ext state \ bool" where "authorised_for_globals_page_table_inv pti \ \s. - case pti of PageTableMap cap ptr pde p \ p && ~~ mask pt_bits \ arm_us_global_vspace (arch_state s) + case pti of PageTableMap cap ptr pte p lvl \ table_base (level_type lvl) p \ arm_us_global_vspace (arch_state s) | _ \ True" - lemma perform_pt_inv_map_globals_equiv: - "\globals_equiv st and valid_arch_state and (\s. table_base x14 \ global_pt s)\ - perform_pt_inv_map x11 x12 x13 x14 + "\globals_equiv st and valid_arch_state and (\s. table_base (level_type lvl) p \ global_pt s)\ + perform_pt_inv_map cap sl pte p lvl \\_. globals_equiv st\" - unfolding perform_pt_inv_map_def - by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' simp: sfence_def) + unfolding perform_pt_inv_map_def cleanByVA_PoU_def + by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv) lemma perform_pt_inv_unmap_globals_equiv: "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ perform_pt_inv_unmap cap ct_slot \\_. globals_equiv st\" - unfolding perform_pt_inv_unmap_def - apply (wpsimp wp: set_cap_globals_equiv'' mapM_x_swp_store_pte_globals_equiv) + unfolding perform_pt_inv_unmap_def cleanCacheRange_PoU_def + apply (wpsimp wp: set_cap_globals_equiv mapM_x_swp_store_pte_globals_equiv) apply (strengthen invs_imps invs_valid_global_vspace_mappings) apply (clarsimp cong: conj_cong) apply (wpsimp wp: unmap_page_table_globals_equiv unmap_page_table_invs) apply wpsimp+ - apply auto + apply (intro conjI) apply (drule cte_wp_valid_cap, fastforce) apply (clarsimp simp: is_PageTableCap_def valid_cap_def valid_arch_cap_def wellformed_mapdata_def) apply (frule cte_wp_valid_cap, fastforce) apply (clarsimp simp: is_PageTableCap_def valid_cap_def valid_arch_cap_def wellformed_mapdata_def) - apply (prop_tac "table_base x = acap_obj cap") - apply (prop_tac "is_aligned x41 pt_bits") + apply (prop_tac "table_base x42 x = acap_obj cap") + apply (prop_tac "is_aligned x41 (pt_bits x42)") apply (fastforce dest: is_aligned_pt simp: valid_arch_cap_def) apply (simp only: is_aligned_neg_mask_eq') apply (clarsimp simp: add_mask_fold) apply (drule subsetD[OF upto_enum_step_subset], clarsimp) - apply (drule neg_mask_mono_le[where n=pt_bits]) - apply (drule neg_mask_mono_le[where n=pt_bits]) + apply (drule_tac n="pt_bits x42" in neg_mask_mono_le) + apply (drule_tac n="pt_bits x42" in neg_mask_mono_le) apply (fastforce dest: plus_mask_AND_NOT_mask_eq) apply clarsimp apply (frule invs_valid_global_refs) @@ -852,68 +947,46 @@ lemma perform_page_table_invocation_globals_equiv: perform_page_table_invocation pti \\_. globals_equiv st\" unfolding perform_page_table_invocation_def - apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' + apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv perform_pt_inv_map_globals_equiv perform_pt_inv_unmap_globals_equiv) apply (case_tac pti; clarsimp simp: authorised_for_globals_page_table_inv_def valid_pti_def) done lemma mapM_swp_store_pte_globals_equiv: - "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)\ - mapM (swp store_pte pte) slots + "\globals_equiv s and (\s. \x \ set slots. table_base pt_t x \ global_refs s)\ + mapM (swp (store_pte pt_t) pte) slots \\_. globals_equiv s\" - apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state - and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)" - in hoare_strengthen_post) - apply (wp mapM_wp' store_pte_valid_arch_state_unreachable - store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ - apply (clarsimp simp: valid_arch_state_def) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply auto - done - -lemma mapM_swp_store_pte_valid_ko_at_arch[wp]: - "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)\ - mapM (swp store_pte pte) slots - \\_. valid_arch_state\" - apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state - and valid_global_vspace_mappings - and (\s. \x \ set slots. table_base x \ global_refs s)" + apply (rule_tac Q'="\_. globals_equiv s and (\s. \x \ set slots. table_base pt_t x \ global_refs s)" in hoare_strengthen_post) apply (wp mapM_wp' store_pte_valid_arch_state_unreachable store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ - apply (clarsimp simp: valid_arch_state_def) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply auto + apply (auto simp: global_refs_def) done lemma unmap_page_globals_equiv: "\globals_equiv st and invs and K (vptr \ user_region)\ unmap_page pgsz asid vptr pptr \\_. globals_equiv st\" - unfolding unmap_page_def including no_pre + unfolding unmap_page_def cleanByVA_PoU_def including no_pre apply (induct pgsz) - apply (wpsimp wp: store_pte_globals_equiv | simp add: sfence_def)+ + apply (wpsimp wp: store_pte_globals_equiv | simp)+ apply (rule hoare_weaken_preE[OF find_vspace_for_asid_wp]) apply clarsimp apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) apply (drule vs_lookup_slot_table_base; clarsimp?) apply (drule reachable_page_table_not_global; clarsimp?) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply fastforce apply (rule hoare_pre) - apply (wpsimp wp: store_pte_globals_equiv mapM_swp_store_pte_globals_equiv hoare_drop_imps - | simp add: sfence_def)+ + apply (wpsimp wp: store_pte_globals_equiv mapM_swp_store_pte_globals_equiv hoare_drop_imps)+ apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) apply (drule vs_lookup_slot_level) apply (case_tac "x = asid_pool_level") apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) apply (drule vs_lookup_slot_table_base; clarsimp?) apply (drule reachable_page_table_not_global; clarsimp?) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply (wpsimp wp: store_pte_globals_equiv | simp add: sfence_def)+ + apply fastforce + apply (wpsimp wp: store_pte_globals_equiv)+ apply (rule hoare_weaken_preE[OF find_vspace_for_asid_wp]) apply clarsimp apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) @@ -922,7 +995,7 @@ lemma unmap_page_globals_equiv: apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) apply (drule vs_lookup_slot_table_base; clarsimp?) apply (drule reachable_page_table_not_global; clarsimp?) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) + apply fastforce done @@ -931,7 +1004,6 @@ definition authorised_for_globals_page_inv :: "authorised_for_globals_page_inv pgi \ \s. case pgi of PageMap cap ptr m \ (\slot. cte_wp_at (parent_for_refs m) slot s) | _ \ True" - lemma length_msg_lt_msg_max: "length msg_registers < msg_max_length" by (simp add: msg_registers_def msgRegisters_def upto_enum_def @@ -967,22 +1039,9 @@ lemma perform_pg_inv_get_addr_globals_equiv: unfolding perform_pg_inv_get_addr_def by (wpsimp wp: set_message_info_globals_equiv set_mrs_globals_equiv) -lemma unmap_page_valid_arch_state: - "\invs and K (vptr \ user_region)\ - unmap_page pgsz asid vptr pptr - \\_. valid_arch_state\" - unfolding unmap_page_def - apply (wpsimp wp: store_pte_valid_arch_state_unreachable) - apply (frule invs_arch_state) - apply (frule invs_valid_global_vspace_mappings) - apply clarsimp - apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) - apply (drule vs_lookup_slot_level) - apply (case_tac "x = asid_pool_level") - apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) - apply (drule vs_lookup_slot_table_base; clarsimp?) - apply (drule reachable_page_table_not_global; clarsimp?) - done +crunch unmap_page + for valid_global_arch_objs[wp]: "valid_global_arch_objs" + (wp: crunch_wps simp: crunch_simps) lemma perform_pg_inv_unmap_globals_equiv: "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ @@ -991,10 +1050,10 @@ lemma perform_pg_inv_unmap_globals_equiv: unfolding perform_pg_inv_unmap_def apply (rule hoare_weaken_pre) apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv - set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + set_cap_globals_equiv' unmap_page_globals_equiv store_pte_globals_equiv store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv - unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv - | wpc | simp add: do_machine_op_bind sfence_def)+ + perform_pg_inv_get_addr_globals_equiv + | wpc | simp add: do_machine_op_bind)+ apply (clarsimp simp: acap_map_data_def) apply (intro conjI; clarsimp) apply (clarsimp split: arch_cap.splits) @@ -1003,15 +1062,23 @@ lemma perform_pg_inv_unmap_globals_equiv: done lemma perform_pg_inv_map_globals_equiv: - "\invs and globals_equiv st and (\s. table_base slot \ global_pt s)\ - perform_pg_inv_map cap ct_slot pte slot + "\invs and globals_equiv st and (\s. table_base (level_type lvl) slot \ global_pt s)\ + perform_pg_inv_map cap ct_slot pte slot lvl \\_. globals_equiv st\" - unfolding perform_pg_inv_map_def - by (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv - set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv - store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv - unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv - | wpc | simp add: do_machine_op_bind sfence_def | fastforce)+ + unfolding perform_pg_inv_map_def cleanByVA_PoU_def + apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv + set_cap_globals_equiv' unmap_page_globals_equiv store_pte_globals_equiv + store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv + perform_pg_inv_get_addr_globals_equiv + | wpc | simp add: do_machine_op_bind | rule conjI; rule impI, wp hoare_drop_imps)+ + apply fastforce + done + +lemma perform_flush_globals_equiv[wp]: + "perform_flush type vstart vend pstart space asid \globals_equiv st\" + unfolding perform_flush_def do_flush_def cleanCacheRange_RAM_def invalidateCacheRange_RAM_def + cleanInvalidateCacheRange_RAM_def cleanCacheRange_PoU_def invalidateCacheRange_I_def isb_def dsb_def + by (cases type; wpsimp wp: dmo_mol_reads_respects when_ev simp: dmo_distr) lemma perform_page_invocation_globals_equiv: "\invs and authorised_for_globals_page_inv pgi and valid_page_inv pgi @@ -1025,7 +1092,6 @@ lemma perform_page_invocation_globals_equiv: apply (clarsimp simp: valid_page_inv_def same_ref_def) apply (drule vs_lookup_slot_table_base; clarsimp) apply (drule reachable_page_table_not_global, clarsimp+) - apply (fastforce dest: global_pt_in_global_refs[OF invs_valid_global_arch_objs]) apply (clarsimp simp: valid_page_inv_def) apply clarsimp apply (fastforce dest: invs_valid_idle @@ -1052,7 +1118,7 @@ lemma perform_asid_control_invocation_globals_equiv: apply (rule hoare_pre) apply wpc apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) - apply (wp modify_wp cap_insert_globals_equiv'' + apply (wp modify_wp cap_insert_globals_equiv retype_region_ASIDPoolObj_globals_equiv[simplified] retype_region_invs_extras(5)[where sz=pageBits] retype_region_invs_extras(6)[where sz=pageBits] @@ -1094,8 +1160,7 @@ lemma perform_asid_control_invocation_globals_equiv: apply (simp add: word_bw_assocs pageBits_def mask_zero) apply (wp add: delete_objects_invs_ex delete_objects_pspace_no_overlap[where dev=False] delete_objects_globals_equiv hoare_vcg_ex_lift - del: Untyped_AI.delete_objects_pspace_no_overlap - | simp add: page_bits_def)+ + del: Untyped_AI.delete_objects_pspace_no_overlap | simp)+ apply (clarsimp simp: conj_comms invs_psp_aligned invs_valid_objs valid_aci_def) apply (clarsimp simp: cte_wp_at_caps_of_state) @@ -1109,13 +1174,11 @@ lemma perform_asid_control_invocation_globals_equiv: apply (clarsimp simp: global_refs_def ptr_range_memI) apply (rule conjI) apply clarify - apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) apply (drule_tac p="global_pt sa" in ptr_range_memI) apply fastforce apply (rule conjI, fastforce simp: global_refs_def) apply (rule conjI) apply clarify - apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) apply fastforce apply (rule conjI) apply (drule untyped_slots_not_in_untyped_range) @@ -1135,7 +1198,7 @@ lemma store_asid_pool_entry_globals_equiv: store_asid_pool_entry pool_ptr asid ptr \\_. globals_equiv st\" unfolding store_asid_pool_entry_def - by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' get_cap_wp | wpc | simp)+ + by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv get_cap_wp | wpc | fastforce)+ lemma perform_asid_pool_invocation_globals_equiv: "\globals_equiv s and invs and valid_apinv api\ @@ -1143,135 +1206,2314 @@ lemma perform_asid_pool_invocation_globals_equiv: \\_. globals_equiv s\" unfolding perform_asid_pool_invocation_def apply (rule hoare_weaken_pre) - apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' - store_asid_pool_entry_globals_equiv copy_global_mappings_globals_equiv - copy_global_mappings_valid_arch_state get_cap_wp + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv + store_asid_pool_entry_globals_equiv get_cap_wp | wpc | simp)+ apply (clarsimp simp: valid_apinv_def cong: conj_cong) - apply (intro conjI; fastforce?) - apply (frule global_pt_in_global_refs[OF invs_valid_global_arch_objs]) - apply (clarsimp simp: cte_wp_at_caps_of_state) - apply (frule (1) cap_not_in_valid_global_refs) - apply (clarsimp simp: acap_obj_def is_pt_cap_def split: arch_cap.splits) - apply (rule caps_of_state_aligned_page_table) - apply (fastforce simp: cte_wp_at_caps_of_state is_pt_cap_def is_PageTableCap_def - split: option.splits) - apply clarsimp - apply (clarsimp simp: cte_wp_at_caps_of_state) - apply (frule (1) cap_not_in_valid_global_refs) - apply (clarsimp simp: acap_obj_def is_pt_cap_def split: arch_cap.splits) done +crunch perform_vspace_invocation + for globals_equiv[wp]: "globals_equiv st" + (simp: sendSGI_def wp: dmo_mol_globals_equiv) + +lemma perform_sgi_invocation_globals_equiv[wp]: + "perform_sgi_invocation iv \globals_equiv s\" + unfolding perform_sgi_invocation_def sendSGI_def + by wpsimp + +lemma perform_vspace_invocation_reads_respects: + "reads_respects aag l \ (perform_vspace_invocation iv)" + unfolding perform_vspace_invocation_def + by (cases iv; wpsimp wp: perform_flush_reads_respects) + + +(* Helpful groupings *) + +definition vcpu_enable_2 where + "vcpu_enable_2 vr \ do + vcpu_enable vr; + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, True)\\) + od" + +definition vcpu_restore_2 where + "vcpu_restore_2 vr \ do + vcpu_restore vr; + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, True)\\) + od" + +definition vcpu_disable_2 where + "vcpu_disable_2 vr \ do + vcpu_disable (Some vr); + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, False)\\) + od" + +definition vcpu_save_hcr where + "vcpu_save_hcr vr \ do + hcr <- do_machine_op get_gic_vcpu_ctrl_hcr; + vgic_update vr (vgic_hcr_update (\_. hcr)) + od" + +definition vcpu_save_vmcr where + "vcpu_save_vmcr vr \ do + vmcr <- do_machine_op get_gic_vcpu_ctrl_vmcr; + vgic_update vr (vgic_vmcr_update (\_. vmcr)) + od" + +definition vcpu_save_apr where + "vcpu_save_apr vr \ do + apr <- do_machine_op get_gic_vcpu_ctrl_apr; + vgic_update vr (vgic_apr_update (\_. apr)) + od" + +definition vcpu_save_lr where + "vcpu_save_lr vr reg \ do + lr <- do_machine_op (get_gic_vcpu_ctrl_lr (word_of_nat reg)); + vgic_update_lr vr reg lr + od" + +definition vcpu_save_lrs where + "vcpu_save_lrs vr \ do + lrs <- do num_list_regs <- gets (arm_gicvcpu_numlistregs \ arch_state); + return [0.. ('l \ bool) \ ('a \ 'b \ bool) \ (det_state \ bool) \ (det_state \ bool) \ + (det_state,'a) nondet_monad \ (det_state,'b) nondet_monad \ bool" + where + "states_equiv_valid_2 aag L \ equiv_valid_2 (\_ _. True) (states_equiv_for_labels aag L) + (states_equiv_for_labels aag L)" + +locale_abbrev states_equiv_valid :: + "'l PAS \ ('l \ bool) \ (det_state \ bool) \ (det_state,'a) nondet_monad \ bool" + where + "states_equiv_valid aag L \ equiv_valid_inv (\_ _. True) (states_equiv_for_labels aag L)" + +lemma states_equiv_valid_2_invisible: + "\ modifies_at_most aag {l. \L l} Q f; modifies_at_most aag {l. \L l} Q' g; + \P. f \\s. P (ready_queues s)\; \P. g \\s. P (ready_queues s)\; + \s t. P s \ P' t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (g t). R rva rvb) \ + \ states_equiv_valid_2 aag L R (P and Q) (P' and Q') f g" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def modifies_at_most_def) + apply (rename_tac u s' v t') + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply clarsimp + apply (drule (1) bspec, clarsimp)+ + apply (prop_tac "states_equiv_for_labels aag L s s'") + apply (subgoal_tac "equiv_for (\x. \x\pasDomainAbs aag x. L x) ready_queues s s'") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def) + apply (clarsimp simp: equiv_for_def) + apply (erule use_valid, erule meta_allE, assumption) + apply simp + apply (prop_tac "states_equiv_for_labels aag L t t'") + apply (subgoal_tac "equiv_for (\x. \x\pasDomainAbs aag x. L x) ready_queues t t'") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def) + apply (clarsimp simp: equiv_for_def) + apply (erule use_valid, erule meta_allE, assumption) + apply (erule use_valid, erule meta_allE, assumption) + apply simp + by (drule (1) states_equiv_for_trans, + drule states_equiv_for_sym, + drule (1) states_equiv_for_trans, + drule states_equiv_for_sym, + solves simp) + +lemma states_equiv_valid_invisible: + "\ modifies_at_most aag {l. \L l} Q f; \P. f \\s. P (ready_queues s)\; + \s t. P s \ P t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (f t). rva = rvb) \ + \ states_equiv_valid aag L (P and Q) f" + unfolding equiv_valid_def2 by (fastforce intro!: states_equiv_valid_2_invisible) + +lemma states_equiv_valid_unit_cases': + "\ states_equiv_valid aag L (P and K (L (pasObjectAbs aag ptr))) f; + modifies_at_most aag {pasObjectAbs aag ptr} Q f; \P. f \\s. P (ready_queues s)\ \ + \ states_equiv_valid aag L (if L (pasObjectAbs aag ptr) then P else Q) (f :: (det_state,unit) nondet_monad)" + apply (case_tac "L (pasObjectAbs aag ptr)") + apply (erule equiv_valid_guard_imp, clarsimp) + apply clarsimp + apply (rule states_equiv_valid_invisible[where P="\", simplified]) + apply (fastforce simp: modifies_at_most_def equiv_but_for_labels_def elim: states_equiv_for_guard_imp) + apply simp + apply simp + done -definition authorised_for_globals_arch_inv :: - "arch_invocation \ ('z::state_ext) state \ bool" where - "authorised_for_globals_arch_inv ai \ - case ai of InvokePageTable oper \ authorised_for_globals_page_table_inv oper - | InvokePage oper \ authorised_for_globals_page_inv oper - | _ \ \" +lemmas states_equiv_valid_unit_cases = states_equiv_valid_unit_cases'[OF _ modifies_at_mostI] + +definition aag_can_affect_label_via where + "aag_can_affect_label_via aag l d \ aag_can_affect_label aag l \ d \ subjectReads (pasPolicy aag) l" + +locale_abbrev aag_can_read_or_affect_label where + "aag_can_read_or_affect_label aag l \ \d. + aag_can_read_label aag d \ aag_can_affect_label_via aag l d" + +(* The states_equiv_for parts of reads_respects *) +definition roa_equiv where + "roa_equiv aag l s s' \ states_equiv_for_labels aag (aag_can_read_or_affect_label aag l) s s'" + +(* The parts of reads_respects besides states_equiv_for *) +definition roa_inv where + "roa_inv s s' \ + cur_thread s = cur_thread s' \ + cur_domain s = cur_domain s' \ + scheduler_action s = scheduler_action s' \ + work_units_completed s = work_units_completed s' \ + equiv_irq_state (machine_state s) (machine_state s')" + +lemma reads_equiv_for_labels: + "reads_equiv aag s s' \ states_equiv_for_labels aag (aag_can_read_label aag) s s' \ roa_inv s s'" + by (auto simp: reads_equiv_def roa_inv_def states_equiv_for_def + equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def) + +lemma affects_equiv_for_labels: + "affects_equiv aag l s s' \ states_equiv_for_labels aag (aag_can_affect_label_via aag l) s s'" + by (auto intro: states_equiv_for_guard_imp[where P=\ and Q=\ and R=\ and S=\] + simp: affects_equiv_def aag_can_affect_label_via_def states_equiv_for_def + equiv_for_def equiv_asids_def equiv_hyp_False equiv_fpu_False) + +lemma roa_equiv_def2: + "roa_equiv aag l s s' \ states_equiv_for_labels aag (aag_can_read_label aag) s s' \ + states_equiv_for_labels aag (aag_can_affect_label_via aag l) s s'" + by (auto simp: roa_equiv_def states_equiv_for_def comp_def bex_disj_distrib + equiv_for_disj equiv_asids_def equiv_fpu_def equiv_hyp_def) + +lemma reads_respects_def2: + "reads_respects aag l P f \ equiv_valid_inv roa_inv (roa_equiv aag l) P f" + by (auto intro!: iff_allI + simp: equiv_valid_def2 equiv_valid_2_def roa_equiv_def2 + reads_equiv_for_labels affects_equiv_for_labels) + +lemma reads_respects_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + assumes inv: + "\P. f \\s. P (cur_domain s)\" + "\P. f \\s. P (cur_thread s)\" + "\P. f \\s. P (scheduler_action s)\" + "\P. f \\s. P (work_units_completed s)\" + "\P. f \\s. P (irq_state_of_state s)\" + shows "reads_respects aag l P f" + unfolding reads_respects_def2 roa_inv_def roa_equiv_def + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + apply (rule hoare_weaken_pre) + apply (wps inv) + apply wp + apply auto[3] + apply (fastforce intro: ev) + done +lemma equiv_valid_guard_necessary: + assumes hoare: "\not P'\ f \\\\" + and ev: "equiv_valid I A B (P and P') f" + shows "equiv_valid I A B P f" + using ev + apply (simp add: equiv_valid_def2 equiv_valid_2_def) + apply (erule all_forward)+ + apply (fastforce dest: use_valid[OF _ hoare]) + done -lemma arch_perform_invocation_reads_respects_g: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_g aag l (ct_active and authorised_arch_inv aag ai and valid_arch_inv ai - and authorised_for_globals_arch_inv ai and invs - and pas_refined aag and is_subject aag \ cur_thread) - (arch_perform_invocation ai)" - unfolding arch_perform_invocation_def fun_app_def - apply (case_tac ai; rule equiv_valid_guard_imp) - by (wpsimp wp: doesnt_touch_globalsI - reads_respects_g[OF perform_page_table_invocation_reads_respects] - reads_respects_g[OF perform_page_invocation_reads_respects] - reads_respects_g[OF perform_asid_control_invocation_reads_respects] - perform_asid_pool_invocation_reads_respects_g - perform_page_table_invocation_globals_equiv - perform_page_invocation_globals_equiv - perform_asid_control_invocation_globals_equiv - perform_asid_pool_invocation_globals_equiv - simp: authorised_arch_inv_def valid_arch_inv_def authorised_for_globals_arch_inv_def - invs_psp_aligned invs_valid_objs invs_vspace_objs invs_valid_asid_table | simp)+ +lemma set_object_states_equiv_valid: + "states_equiv_valid aag L \ (set_object ptr obj)" + apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + bind_def' get_def gets_def put_def return_def fail_def assert_def) + apply (erule states_equiv_for_identical_kheap_updates) + apply (clarsimp simp: identical_kheap_updates_def) + done -lemma arch_perform_invocation_globals_equiv: - "\globals_equiv s and invs and ct_active and valid_arch_inv ai - and authorised_for_globals_arch_inv ai\ - arch_perform_invocation ai - \\_. globals_equiv s\" - unfolding arch_perform_invocation_def - apply (wpsimp wp: perform_page_table_invocation_globals_equiv - perform_page_invocation_globals_equiv - perform_asid_control_invocation_globals_equiv - perform_asid_pool_invocation_globals_equiv)+ - apply (auto simp: authorised_for_globals_arch_inv_def invs_def valid_state_def valid_arch_inv_def) +lemma set_vcpu_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (set_vcpu vr vcpu)" + unfolding set_vcpu_def + apply (rule_tac P'="vcpu_at vr" in equiv_valid_guard_necessary) + apply (rule wp_pre) + apply (rule hoare_set_object_weaken_pre) + apply wp + apply (clarsimp simp: obj_at_def) + apply (wpsimp wp: set_object_states_equiv_valid) done -crunch arch_post_cap_deletion - for valid_global_objs[wp]: "valid_global_objs" +lemma get_vcpu_states_equiv_valid[wp]: + "states_equiv_valid aag L (K (L (pasObjectAbs aag vr))) (get_vcpu vr)" + unfolding get_vcpu_def gets_map_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def opt_map_def) + done -lemma get_thread_state_globals_equiv[wp]: - "get_thread_state ref \globals_equiv s\" - by wp +(* equiv_but_for_labels proofs *) -(* generalises auth_ipc_buffers_mem_Write *) -lemma auth_ipc_buffers_mem_Write': - "\ x \ auth_ipc_buffers s thread; pas_refined aag s; valid_objs s \ - \ (pasObjectAbs aag thread, Write, pasObjectAbs aag x) \ pasPolicy aag" - apply (clarsimp simp add: auth_ipc_buffers_member_def) - apply (drule (1) cap_auth_caps_of_state) - apply simp - apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def - vspace_cap_rights_to_auth_def vm_read_write_def - split: if_split_asm) - apply (auto dest: ipcframe_subset_page) +lemma set_vcpu_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + set_vcpu vr vcpu + \\_. equiv_but_for_labels aag L st\" + unfolding set_vcpu_def + apply (rule wp_pre) + apply (rule hoare_set_object_weaken_pre) + apply (wp set_object_equiv_but_for_labels) + apply (clarsimp simp: opt_map_def obj_at_def) done -lemma thread_set_globals_equiv: - "(\tcb. arch_tcb_context_get (tcb_arch (f tcb)) = arch_tcb_context_get (tcb_arch tcb)) - \ \globals_equiv s and valid_arch_state\ thread_set f tptr \\_. globals_equiv s\" - unfolding thread_set_def - apply (wp set_object_globals_equiv) - apply simp - apply (intro impI conjI allI) - apply (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def dest: valid_global_arch_objs_pt_at)+ +lemma vcpu_update_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vcpu_update vr f + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_update_def by wpsimp + +lemma vgic_update_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vgic_update vr f + \\_. equiv_but_for_labels aag L st\" + unfolding vgic_update_def by wpsimp + +lemma vgic_update_lr_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vgic_update_lr vr reg irq + \\_. equiv_but_for_labels aag L st\" + unfolding vgic_update_lr_def by wpsimp + +lemma dmo_mol_equiv_but_for_labels[wp]: + "do_machine_op (machine_op_lift f) \equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for) + +lemma dmo_equiv_but_for_labels_lift: + assumes "\P. f \\ms. P (underlying_memory ms)\" + assumes "\P. f \\ms. P (device_state ms)\" + assumes "\P. f \\ms. P (irq_state ms)\" + assumes "\P. f \\ms. P (vcpu_state ms)\" + assumes "\P. f \\ms. P (fpu_state ms)\" + shows "do_machine_op f \equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def states_equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def + by (wpsimp wp: equiv_for_lift2 assms dmo_wp) + +lemma dmo_equiv_but_for_labels_vcpu: + assumes "\P. f \\ms. P (underlying_memory ms)\" + assumes "\P. f \\ms. P (device_state ms)\" + assumes "\P. f \\ms. P (irq_state ms)\" + assumes "\P. f \\ms. P (fpu_state ms)\" + shows "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op f + \\_. equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def states_equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def + apply wp + apply clarsimp + apply (rule hoare_vcg_conj_lift, solves "wpsimp wp: equiv_for_lift2 assms dmo_wp")+ + apply (rule hoare_vcg_conj_lift) + apply (rule_tac Q'="\_ s. equiv_for (\x. pasObjectAbs aag x \ L) cur_vcpu_of st s \ + cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None" + in hoare_strengthen_post) + apply (wpsimp wp: equiv_for_lift2 assms dmo_wp) + defer + apply (wpsimp wp: equiv_for_lift2 assms dmo_wp) + apply clarsimp + apply (clarsimp simp: equiv_for_def cur_vcpu_for_def split: option.splits) + apply (clarsimp simp: cur_vcpu_of_def split: option.splits) + apply (clarsimp split: if_splits) + apply (erule_tac x=x in allE) + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) done -end +lemma dmo_get_hcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s\ + do_machine_op get_gic_vcpu_ctrl_hcr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) -hide_fact as_user_globals_equiv +lemma dmo_set_hcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_hcr val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) -context begin interpretation Arch . +lemma dmo_setSCTLR_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (setSCTLR val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) -requalify_consts - authorised_for_globals_arch_inv +lemma dmo_setHCR_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (setHCR val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) -requalify_facts - arch_post_cap_deletion_valid_global_objs - get_thread_state_globals_equiv - auth_ipc_buffers_mem_Write' - thread_set_globals_equiv - arch_post_modify_registers_cur_domain - arch_post_modify_registers_cur_thread - length_msg_lt_msg_max - set_mrs_globals_equiv - arch_perform_invocation_globals_equiv - as_user_globals_equiv - prepare_thread_delete_st_tcb_at_halted - make_arch_fault_msg_inv - check_valid_ipc_buffer_inv - arch_tcb_update_aux2 - arch_perform_invocation_reads_respects_g +lemma dmo_maskInterrupt_equiv_but_for_labels[wp]: + "do_machine_op (maskInterrupt b irq) \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) -declare - arch_post_cap_deletion_valid_global_objs[wp] - get_thread_state_globals_equiv[wp] - arch_post_modify_registers_cur_domain[wp] - arch_post_modify_registers_cur_thread[wp] - prepare_thread_delete_st_tcb_at_halted[wp] +lemma dmo_check_export_arch_timer_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op check_export_arch_timer + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) -end +lemma dmo_writeVCPUHardwareReg_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (writeVCPUHardwareReg reg val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) -declare as_user_globals_equiv[wp] +lemma dmo_readVCPUHardwareReg_inv[wp]: + "do_machine_op (readVCPUHardwareReg reg) \P\" + by (wpsimp simp: readVCPUHardwareReg_def) -axiomatization dmo_reads_respects where - dmo_read_stval_reads_respects: "reads_respects aag l \ (do_machine_op read_stval)" +lemma vcpu_save_reg_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vcpu_save_reg vr reg + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_save_reg_def + by wpsimp + +lemma save_virt_timer_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ cur_vcpu_of s vr \ None\ + save_virt_timer vr + \\_. equiv_but_for_labels aag L st\" + unfolding save_virt_timer_def + apply wpsimp + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + done + +lemma dmo_enableFpuEL01_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op enableFpuEL01 + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_isb_equiv_but_for_labels[wp]: + "do_machine_op isb \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_dsb_equiv_but_for_labels[wp]: + "do_machine_op dsb \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma vcpu_disable_Some_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_of s vr \ None \ pasObjectAbs aag vr \ L\ + vcpu_disable (Some vr) \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_disable_def + apply (clarsimp simp: dmo_distr) + apply wpsimp + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_save_reg_range_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vcpu_save_reg_range vr from to + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_save_reg_range_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: mapM_x_wp_inv) + done + +lemma dmo_get_lr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (get_gic_vcpu_ctrl_lr reg) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_set_lr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_lr reg val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_get_apr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s\ + do_machine_op get_gic_vcpu_ctrl_apr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_set_apr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_apr val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_get_vmcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s\ + do_machine_op get_gic_vcpu_ctrl_vmcr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_set_vmcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_vmcr val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma vcpu_save_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ current_vcpu s = vopt \ + (\vr b. vopt = Some (vr,b) \ pasObjectAbs aag vr \ L)\ + vcpu_save vopt \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_save_def + apply (case_tac vopt; clarsimp) + apply (wpsimp split_del: if_split simp: crunch_simps) + apply (rule_tac Q'="\_ s. equiv_but_for_labels aag L st s \ pasObjectAbs aag a \ L \ + cur_vcpu_of s a \ None" in hoare_strengthen_post) + apply (wpsimp wp: mapM_wp_inv) + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + apply clarsimp + apply (wpsimp simp: crunch_simps)+ + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_restore_reg_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_restore_reg vr reg + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_restore_reg_def + by wp + +lemma vcpu_restore_reg_range_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_restore_reg_range vr from to + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_restore_reg_range_def + apply (rule hoare_strengthen_post, rule mapM_x_wp_inv) + apply (wpsimp wp: mapM_x_wp_inv)+ + done + +lemma restore_virt_timer_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + restore_virt_timer vr + \\_. equiv_but_for_labels aag L st\" + unfolding restore_virt_timer_def + by wpsimp + +lemma vcpu_enable_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_enable vr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp simp: vcpu_enable_def dmo_distr) + +crunch vcpu_restore_reg_range + for current_vcpu[wp]: "\s. P (current_vcpu s)" + (wp: crunch_wps) + +lemma vcpu_restore_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_restore vr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: mapM_wp_inv simp: vcpu_restore_def dmo_distr dom_mapM) + +lemma modify_current_vcpu_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ + (\ptr b. current_vcpu s = Some (ptr,b) \ pasObjectAbs aag ptr \ L)\ + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr,a)\\) + \\_ s. equiv_but_for_labels aag L st s\" + apply wp + apply simp + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + defer + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (intro context_conjI; clarsimp) + apply (erule_tac x=x in allE)+ + apply clarsimp + apply (case_tac "\b. current_vcpu s = Some (x, b)") + apply clarsimp + apply (fastforce simp: cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_enable_2_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ + (\ptr b. current_vcpu s = Some (ptr,b) \ pasObjectAbs aag ptr \ L)\ + vcpu_enable_2 vr + \\_ s. equiv_but_for_labels aag L st s\" + unfolding vcpu_enable_2_def + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply (fastforce simp: cur_vcpu_for_def split: option.splits) + done + +lemma vcpu_restore_2_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ + (\ptr b. current_vcpu s = Some (ptr,b) \ pasObjectAbs aag ptr \ L)\ + vcpu_restore_2 vr + \\_ s. equiv_but_for_labels aag L st s\" + unfolding vcpu_restore_2_def + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply (fastforce simp: cur_vcpu_for_def split: option.splits) + done + +lemma vcpu_disable_2_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ current_vcpu s = Some (vr, True) \ pasObjectAbs aag vr \ L\ + vcpu_disable_2 vr + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_disable_2_def + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply (clarsimp simp: cur_vcpu_of_def) + done + + +lemma vcpu_update_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (vcpu_update vr f)" + unfolding vcpu_update_def + apply (rule wp_pre) + apply (rule_tac ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp+ + done + +lemma cur_vcpu_for_eq_Some[simp]: + "(cur_vcpu_for_2 P cv = Some b) = (\ptr. cv = Some (ptr,b) \ P ptr)" + by (clarsimp simp: cur_vcpu_for_def split: option.splits) + +lemma cur_vcpu_for_equiv_l: + "\ equiv_for P cur_vcpu_of st s \ + \ cur_vcpu_for P st = cur_vcpu_for P s" + apply (case_tac "current_vcpu st"; case_tac "current_vcpu s") + by (auto simp: cur_vcpu_for_None cur_vcpu_for_Some equiv_for_def cur_vcpu_of_def split: if_splits) + +lemma numlistregs_for_equiv_l: + "\ equiv_for P (K \ numlistregs) st s \ + \ numlistregs_for P st = numlistregs_for P s" + by (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def + equiv_hyp_def equiv_for_def numlistregs_for_def) + +lemma do_machine_op_states_equiv_valid': + assumes equiv_dmo: + "\n cv cf. equiv_valid_inv (equiv_machine_state (L o pasObjectAbs aag) + and equiv_hyp_state n cv + and equiv_fpu_state cf) + (equiv_machine_state (L o pasObjectAbs aag)) (Q n cv cf) f" + assumes guard: + "\s. P s \ Q (numlistregs_for (L o pasObjectAbs aag) s) (cur_vcpu_for (L o pasObjectAbs aag) s) + (cur_fpu_for (L o pasObjectAbs aag) s) + (machine_state s)" + shows + "states_equiv_valid aag L P (do_machine_op f)" + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_add_A[OF _ states_equiv_for_refl]) + apply (simp add: do_machine_op_def spec_equiv_valid_def) + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (L o pasObjectAbs aag) rv rv' \ + equiv_hyp_state (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) rv rv' \ + equiv_fpu_state (cur_fpu_for (L o pasObjectAbs aag) st) rv rv'" + and Q="\r s. st = s \ Q (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) + (cur_fpu_for (L o pasObjectAbs aag) st) r" + and Q'="\r s. Q (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) + (cur_fpu_for (L o pasObjectAbs aag) st) r" + and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r, ms') (r', ms''). r = r' \ + equiv_machine_state (L o pasObjectAbs aag) ms' ms'' \ + equiv_hyp_state (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) ms' ms'' \ + equiv_fpu_state (cur_fpu_for (L o pasObjectAbs aag) st) ms' ms''" + and Q="\r s. s = st" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (rule states_equiv_for_machine_state_update) + apply clarsimp + apply (clarsimp simp: equiv_for_def) + apply (rule equiv_hyp_state_identical_hyp_state_updates) + apply (clarsimp simp: equiv_hyp_state_def cur_vcpu_for_def numlistregs_for_def + split: option.splits if_splits) + apply (clarsimp simp: states_equiv_for_def) + apply (rule equiv_fpu_state_identical_fpu_state_updates) + apply (fastforce simp: equiv_fpu_state_def cur_fpu_for_def hw_fpu_def + split: option.splits if_splits) + apply (clarsimp simp: states_equiv_for_def) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 split_def equiv_for_def) + apply (erule_tac x="numlistregs_for (L o pasObjectAbs aag) st" in meta_allE) + apply (erule_tac x="cur_vcpu_for (L o pasObjectAbs aag) st" in meta_allE) + apply (erule_tac x="cur_fpu_for (L o pasObjectAbs aag) st" in meta_allE) + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec, fastforce) + apply wp + apply wp + apply clarsimp + apply clarsimp + apply (clarsimp simp: equiv_valid_2_def in_monad states_equiv_for_def equiv_hyp_def equiv_hyp_state_def comp_def) + apply (rule conjI) + apply (frule cur_vcpu_for_equiv_l) + apply (case_tac "cur_vcpu_for (L o pasObjectAbs aag) t"; clarsimp) + apply (clarsimp simp: cur_vcpu_for_def split: option.splits if_splits) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=ptr in allE)+ + apply (fastforce simp: cur_vcpu_for_Some cur_vcpu_of_def hw_vcpu_def numlistregs_for_def + split: if_splits option.splits) + apply (fastforce simp: equiv_fpu_def equiv_fpu_state_def equiv_for_def hw_fpu_def cur_fpu_for_def + split: if_splits) + apply (wpsimp wp: guard)+ + apply (drule guard) + apply (clarsimp simp: states_equiv_for_def equiv_fpu_cur_fpu_for equiv_hyp_def + cur_vcpu_for_equiv_l numlistregs_for_equiv_l comp_def) + done + +lemma do_machine_op_states_equiv_valid: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (L o pasObjectAbs aag)) (equiv_machine_state (L o pasObjectAbs aag)) \ f" + assumes hyp_state_inv: + "\n cv ms. \equiv_hyp_state n cv ms\ f \\_. equiv_hyp_state n cv ms\" + assumes fpu_state_inv: + "\cf ms. \equiv_fpu_state cf ms\ f \\_. equiv_fpu_state cf ms\" + shows + "states_equiv_valid aag L \ (do_machine_op f)" + apply (rule do_machine_op_states_equiv_valid'[where Q="\_ _ _. \"]) + apply (insert equiv_dmo) + apply (clarsimp simp: equiv_valid_2_def equiv_valid_def2 equiv_for_or + simp: split_def split: prod.splits simp: equiv_for_def)[1] + apply (rename_tac rv st rv' st') + apply (drule_tac x=s in spec, drule_tac x=t in spec) + apply clarsimp + apply (drule (1) bspec)+ + apply clarsimp + apply (rule conjI) + apply (erule use_valid[OF _ hyp_state_inv]) + apply (rule equiv_hyp_state_sym) + apply (erule use_valid[OF _ hyp_state_inv]) + apply (erule equiv_hyp_state_sym) + apply (erule use_valid[OF _ fpu_state_inv]) + apply (rule equiv_fpu_state_sym) + apply (erule use_valid[OF _ fpu_state_inv]) + apply (erule equiv_fpu_state_sym) + apply simp + done + +lemma readVCPUHardwareReg_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b \ + (vcpuRegSavedWhenDisabled reg \ b)) + (do_machine_op (readVCPUHardwareReg reg))" + unfolding readVCPUHardwareReg_def + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some) + apply (case_tac b; clarsimp simp: hw_vcpu_def) + apply (drule_tac x=reg in fun_cong, clarsimp) + done + +lemma dmo_mol_states_equiv_valid: + "states_equiv_valid aag L \ (do_machine_op (machine_op_lift mop))" + apply (rule do_machine_op_states_equiv_valid) + apply (rule equiv_valid_guard_imp[OF machine_op_lift_ev]) + apply simp + apply wp+ + done + +lemma writeVCPUHardwareReg_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op (writeVCPUHardwareReg reg val))" + unfolding writeVCPUHardwareReg_def dmo_distr + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (wpsimp wp: do_machine_op_states_equiv_valid' modify_ev) + apply wpsimp + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + apply (case_tac "cur_vcpu_for (L \ pasObjectAbs aag) s"; clarsimp simp: cur_vcpu_for_Some) + apply (clarsimp simp: hw_vcpu_def split: if_splits) + apply (intro conjI ext; drule_tac x=r in fun_cong; clarsimp)+ + done + +lemma vcpu_save_reg_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b) \ (vcpuRegSavedWhenDisabled reg \ b)) + (vcpu_save_reg vr reg)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_reg_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp+ + done + +lemma vcpu_save_reg_range_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b)) + (vcpu_save_reg_range vr VCPURegTTBR0 VCPURegSPSR_EL1)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_reg_range_def + apply (wpsimp wp: mapM_x_ev[where I="\s. \b. current_vcpu s = Some (vr,b)"]) + apply (auto simp: upto_enum_def fromEnum_def enum_vcpureg toEnum_def vcpuRegSavedWhenDisabled_def)[1] + apply wpsimp+ + done + +lemma get_gic_vcpu_ctrl_hcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op (get_gic_vcpu_ctrl_hcr))" + unfolding get_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + done + +lemma get_gic_vcpu_ctrl_vmcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b) + (do_machine_op (get_gic_vcpu_ctrl_vmcr))" + unfolding get_gic_vcpu_ctrl_vmcr_def dmo_distr + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + done + +lemma get_gic_vcpu_ctrl_apr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b) + (do_machine_op (get_gic_vcpu_ctrl_apr))" + unfolding get_gic_vcpu_ctrl_apr_def dmo_distr + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + done + +lemma cur_fpu_for_lift: + assumes "\P. f \\s. P (arch_state s)\" + shows "f \\s. P (cur_fpu_for Q s)\" + unfolding cur_fpu_for_def + by (wp assms) + +lemma numlistregs_for_lift: + assumes "\P. f \\s. P (numlistregs s)\" + shows "f \\s. P (numlistregs_for Q s)\" + unfolding numlistregs_for_def + by (wp assms) + +lemma get_gic_vcpu_ctrl_lr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. (\b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b) \ + unat reg < numlistregs s) + (do_machine_op (get_gic_vcpu_ctrl_lr reg))" + unfolding get_gic_vcpu_ctrl_lr_def dmo_distr + apply wp + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule hoare_lift_Pf[where f="numlistregs_for _"]) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift cur_fpu_for_lift) + apply (wpsimp wp: numlistregs_for_lift) + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + apply (drule_tac x="unat reg" in fun_cong)+ + apply (clarsimp simp: numlistregs_for_def split: if_splits) + done + +lemma vgic_update_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (vgic_update vr f)" + unfolding vgic_update_def by wp + +lemma vgic_lr_update_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (vgic_update_lr vr reg irq)" + unfolding vgic_update_lr_def by wp + +lemma vcpu_save_hcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True)) + (vcpu_save_hcr vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_hcr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply (wpsimp simp: get_gic_vcpu_ctrl_hcr_def)+ + done + +lemma vcpu_save_vmcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b)) + (vcpu_save_vmcr vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_vmcr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply (wpsimp simp: get_gic_vcpu_ctrl_vmcr_def)+ + done + +lemma vcpu_save_apr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b)) + (vcpu_save_apr vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_apr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp+ + done + +lemma vcpu_save_lr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. (\b. current_vcpu s = Some (vr,b)) \ valid_numlistregs s \ reg < numlistregs s) + (vcpu_save_lr vr reg)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_lr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp + apply (clarsimp simp: valid_numlistregs_def) + apply (simp add: unat_of_nat64) + apply wpsimp + apply assumption + apply wpsimp + apply (clarsimp simp: cur_vcpu_for_def) + done + +crunch vcpu_save_hcr, vcpu_save_vmcr, vcpu_save_apr, vcpu_save_lr, vcpu_save_lrs + for arch_state[wp]: "\s. P (arch_state s)" + (wp: mapM_x_wp_inv) + +lemma vcpu_save_lrs_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. (\b. current_vcpu s = Some (vr,b)) \ valid_numlistregs s) + (vcpu_save_lrs vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_lrs_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply (wpsimp wp: mapM_x_ev) + apply (rule wp_pre) + apply wpsimp + apply (prop_tac "\x \ set rv. x < numlistregs s") + apply (erule conjunct1) + apply clarsimp + apply assumption + apply wpsimp+ + apply (fastforce simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (wpsimp wp: mapM_x_wp_inv simp: vcpu_save_lr_def get_gic_vcpu_ctrl_lr_def dmo_distr)+ + done + +lemma equiv_valid_cases'': + "\ \s t. \ A s t; I s t; R s; R t \ \ P s = P t; + equiv_valid I A B (R and P) f; equiv_valid I A B ((\s. \P s) and R) f \ + \ equiv_valid I A B R f" + by (fastforce simp: equiv_valid_def2 equiv_valid_2_def) + +lemma hw_vcpu_Some_True[simp]: + "hw_vcpu n (Some True) vst = Some (vcpu_mask n vst)" + apply (clarsimp simp: hw_vcpu_def) + apply (rule vcpu_state.equality; clarsimp) + apply (rule gic_vcpu_interface.equality; clarsimp) + apply (rule ext; clarsimp) + done + +lemma vcpu_mask_regs_update[simp]: + "vcpu_mask n (vcpu_regs_update f vst) = vcpu_regs_update f (vcpu_mask n vst)" + by (rule vcpu_state.equality; clarsimp) + +lemma check_export_arch_timer_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op check_export_arch_timer)" + (is "states_equiv_valid _ _ ?P _") + unfolding check_export_arch_timer_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma check_export_arch_timer_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op check_export_arch_timer)" + (is "states_equiv_valid _ _ ?P _") + unfolding check_export_arch_timer_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma cur_vcpu_for_None': + "(cur_vcpu_for P s = None) = (\vr. P vr \ cur_vcpu_of s vr = None)" + by (auto simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits) + +lemma check_export_arch_timer_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr. current_vcpu s = Some (vr,True)) + (do_machine_op check_export_arch_timer)" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: check_export_arch_timer_states_equiv_valid'') + apply (wpsimp wp: check_export_arch_timer_states_equiv_valid') + done + +lemma save_virt_timer_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True)) + (save_virt_timer vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding save_virt_timer_def + apply (wpsimp wp: vcpu_save_reg_states_equiv_valid) + apply auto + done + +lemma dmo_dsb_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op dsb)" + unfolding dsb_def + by (wpsimp wp: dmo_mol_states_equiv_valid) + +lemma dmo_isb_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op isb)" + unfolding isb_def + by (wpsimp wp: dmo_mol_states_equiv_valid) + +lemma dmo_setHCR_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op (setHCR val))" + unfolding setHCR_def + by (wpsimp wp: dmo_mol_states_equiv_valid) + +(* FIXME AARCH64 IF: move *) +lemma mapM_K_bind_discarded: + "mapM f xs >>= K_bind g = mapM_x f xs >>= K_bind g" + by (simp add: mapM_x_mapM) + +lemma vcpu_save_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = cv \ valid_numlistregs s) (vcpu_save cv)" + apply (simp only: vcpu_save_def fun_app_def mapM_K_bind_discarded bind_assoc[symmetric] + vcpu_save_vgic_defs[symmetric]) + apply (wpsimp wp: when_ev mapM_ev mapM_wp_inv)+ + apply auto + done + +lemma dmo_maskInterrupt_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op (maskInterrupt m irq))" + unfolding maskInterrupt_def + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid' modify_ev) + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + done + +lemma enableFpuEL01_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op enableFpuEL01)" + (is "states_equiv_valid _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma enableFpuEL01_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op enableFpuEL01)" + (is "states_equiv_valid _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma enableFpuEL01_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op enableFpuEL01)" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: enableFpuEL01_states_equiv_valid'') + apply (wpsimp wp: enableFpuEL01_states_equiv_valid') + done + +lemma setSCTLR_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op (setSCTLR val))" + (is "states_equiv_valid _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma setSCTLR_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op (setSCTLR val))" + (is "states_equiv_valid _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma setSCTLR_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (setSCTLR val))" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: setSCTLR_states_equiv_valid'') + apply (wpsimp wp: setSCTLR_states_equiv_valid') + done + +lemma set_gic_vcpu_ctrl_hcr_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "states_equiv_valid _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma vcpu_mask_hcr_update[simp]: + "vcpu_mask n (vcpu_vgic_update (vgic_hcr_update f) vst) = vcpu_vgic_update (vgic_hcr_update f) (vcpu_mask n vst)" + by (rule vcpu_state.equality; clarsimp) + +lemma set_gic_vcpu_ctrl_hcr_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "states_equiv_valid _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_hcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_states_equiv_valid'') + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_states_equiv_valid') + done + +lemma vcpu_disable_Some_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True)) (vcpu_disable (Some vr))" + apply (simp only: vcpu_disable_def fun_app_def bind_assoc[symmetric] vcpu_save_vgic_defs[symmetric]) + apply (clarsimp simp: dmo_distr) + apply (wpsimp wp: when_ev mapM_ev mapM_wp_inv)+ + apply auto + done + +definition states_equiv_for_non_hyp :: + "(obj_ref \ bool) \ (irq \ bool) \ (asid \ bool) \ + (domain \ bool) \ det_state \ det_state \ bool" + where + "states_equiv_for_non_hyp P Q R S s s' \ + equiv_for P kheap s s' \ + equiv_machine_state P (machine_state s) (machine_state s') \ + equiv_for (P \ fst) cdt s s' \ + equiv_for (P \ fst) cdt_list s s' \ + equiv_for (P \ fst) is_original_cap s s' \ + equiv_for Q interrupt_states s s' \ + equiv_for Q interrupt_irq_node s s' \ + equiv_for S ready_queues s s' \ + equiv_asids R s s' \ + equiv_fpu P s s'" + +lemma states_equiv_for_non_hyp_refl: + "states_equiv_for_non_hyp P Q R S s s" + by (auto simp: states_equiv_for_non_hyp_def intro: equiv_for_refl equiv_asids_refl equiv_hyp_refl equiv_fpu_refl) + +lemma states_equiv_for_non_hyp_sym: + "states_equiv_for_non_hyp P Q R S s t \ states_equiv_for_non_hyp P Q R S t s" + by (auto simp: states_equiv_for_non_hyp_def intro: equiv_for_sym equiv_asids_sym equiv_hyp_sym equiv_fpu_sym) + +lemma states_equiv_for_non_hyp_trans: + "\ states_equiv_for_non_hyp P Q R S s t; states_equiv_for_non_hyp P Q R S t u \ + \ states_equiv_for_non_hyp P Q R S s u" + by (auto simp: states_equiv_for_non_hyp_def + intro: equiv_for_trans equiv_asids_trans equiv_hyp_trans equiv_fpu_trans equiv_forI + elim: equiv_forE) + +lemma states_equiv_for_non_hyp_lift: + assumes "\st. f \\s. equiv_for P kheap st s\" + assumes "\ms. f \\s. equiv_machine_state P ms (machine_state s)\" + assumes "\st. f \\s. equiv_for (P \ fst) cdt st s\" + assumes "\st. f \\s. equiv_for (P \ fst) cdt_list st s\" + assumes "\st. f \\s. equiv_for (P \ fst) is_original_cap st s\" + assumes "\st. f \\s. equiv_for Q interrupt_states st s\" + assumes "\st. f \\s. equiv_for Q interrupt_irq_node st s\" + assumes "\st. f \\s. equiv_for S ready_queues st s\" + assumes "\st. f \\s. equiv_asids R st s\" + assumes "\st. f \\s. equiv_fpu P st s\" + shows "f \states_equiv_for_non_hyp P Q R S st\" + unfolding states_equiv_for_non_hyp_def + apply (rule hoare_weaken_pre) + apply (rule hoare_vcg_conj_lift, rule assms)+ + apply (rule assms) + apply simp + done + +crunch vcpu_switch + for is_original_cap[wp]: "\s. P (is_original_cap s)" + and interrupt_states[wp]: "\s. P (interrupt_states s)" + (wp: crunch_wps) + +lemma equiv_asids_lift: + assumes "\P. f \\s. P (asid_pools_of s)\" + assumes "\P. f \\s. P (asid_table s)\" + shows "f \\s. equiv_asids R st s\" + unfolding equiv_asids_def equiv_asid_def asid_pools_at_eq + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift assms) + apply auto + done + +crunch vcpu_switch + for asid_pools[wp]: "\s. P (asid_pools_of s)" + (wp: crunch_wps) + +lemma equiv_fpu_lift: + assumes "\P. f \\s. P (fpu_state (machine_state s))\" + assumes "\P. f \\s. P (current_fpu s)\" + shows "f \\s. equiv_fpu P st s\" + apply (clarsimp simp: valid_def equiv_fpu_def equiv_for_def) + apply (erule_tac x=x in allE, clarsimp) + apply (frule_tac P="\s'. fpu_state (machine_state s') = fpu_state (machine_state s)" in use_valid) + apply (rule assms(1)) + apply simp + apply (drule_tac P="\s'. current_fpu s' = current_fpu s" in use_valid) + apply (rule assms(2)) + apply simp + apply (clarsimp simp: equiv_fpu_def opt_map_def fpu_of_state_def cur_fpu_for_def get_tcb_def + split: option.splits kernel_object.splits if_splits) + done + +crunch vcpu_restore + for kheap[wp]: "\s. P (kheap s)" + and fpu_state[wp]: "\s. P (fpu_state (machine_state s))" + and underlying_memory[wp]: "\s. P (underlying_memory (machine_state s))" + and device_state[wp]: "\s. P (device_state (machine_state s))" + (wp: crunch_wps dmo_wp simp: crunch_simps) + +lemma equiv_machine_state_lift: + assumes "\P. f \\s. P (underlying_memory (machine_state s))\" + assumes "\P. f \\s. P (device_state (machine_state s))\" + shows "f \\s. equiv_machine_state P ms (machine_state s)\" + by (wpsimp wp: assms equiv_for_lift2) + +lemma vcpu_restore_states_equiv_for_non_hyp[wp]: + "vcpu_restore vopt \states_equiv_for_non_hyp P Q R S st\" + by (wpsimp wp: states_equiv_for_non_hyp_lift equiv_for_lift + equiv_asids_lift equiv_fpu_lift equiv_machine_state_lift) + +lemma equiv_valid_split: + assumes "equiv_valid I A B P f" + assumes "equiv_valid I' A' B' P' f" + shows "equiv_valid (\s s'. I s s' \ I' s s') (\s s'. A s s' \ A' s s') + (\s s'. B s s' \ B' s s') (\s. P s \ P' s) f" + using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def) + +lemma vcpus_of_vcpu_proj: + "vcpus_of s vr = Some vcpu + \ vcpu_proj UNIV UNIV True True True vr s = Some (vcpu_mask (numlistregs s) vcpu)" + by (clarsimp simp: vcpu_proj_def cong: if_cong) + +lemma vcpu_mask_truncate_helper: + "vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu) = + vcpu_state.truncate (vcpu_mask (numlistregs s) vcpu)" + by (clarsimp simp: vcpu_state.defs) + +lemma vcpu_restore_vcpu_proj': + "\\s. vopt = vcpu_proj UNIV UNIV True True True vr s \ valid_arch_state s\ + vcpu_restore vr + \\_ s. vopt = vcpu_proj {} {} False False False vr s\" + by (wpsimp wp: vcpu_restore_vcpu_proj) + +lemma vcpu_restore_helper: + "\\s. vcpus_of s vr = Some vcpu \ valid_arch_state s\ + vcpu_restore vr + \\_ s. vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu) = vcpu_mask (numlistregs s) (vcpu_state (machine_state s))\" + apply (rule_tac P'="\s. vcpus_of s vr = Some vcpu \ valid_arch_state s \ + Some (vcpu_mask (numlistregs s) vcpu) = vcpu_proj UNIV UNIV True True True vr s " + and Q'="\_ s. vcpus_of s vr = Some vcpu \ + Some (vcpu_mask (numlistregs s) vcpu) = vcpu_proj {} {} False False False vr s" + in hoare_chain) + apply (rule hoare_weaken_pre) + apply (rule hoare_vcg_conj_lift) + apply wpsimp + apply wps + apply (wp vcpu_restore_vcpu_proj') + apply clarsimp + apply clarsimp + apply (drule vcpus_of_vcpu_proj) + apply simp + apply clarsimp + apply (clarsimp simp: vcpu_mask_truncate_helper) + apply (clarsimp simp: vcpu_proj_def vcpu_state.defs cong: if_cong) + done + +lemma vcpu_restore_2_helper: + "\\s. vcpus_of s vr = Some vcpu \ valid_arch_state s\ + vcpu_restore_2 vr + \\_ s. hw_vcpu_of s vr = Some (vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu))\" + unfolding vcpu_restore_2_def + apply (rule_tac Q'="\_ s. vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu) + = vcpu_mask (numlistregs s) (vcpu_state (machine_state s)) + \ current_vcpu s = Some (vr,True)" in hoare_strengthen_post) + apply wp + apply (rule hoare_vcg_conj_lift) + apply simp + apply (wp vcpu_restore_helper[simplified]) + apply simp + apply wpsimp+ + apply (clarsimp simp: cur_vcpu_of_def) + done + +lemma get_vcpu_vcpu_at: + "\\s. vcpu_at vr s \ P s\ get_vcpu vr \\_. P\" + unfolding get_vcpu_def gets_map_def + by (wpsimp simp: obj_at_def opt_map_def split: option.splits) + +crunch vcpu_restore_2 + for kheap[wp]: "\s. P (kheap s)" + and numlistregs[wp]: "\s. P (numlistregs s)" + +abbreviation states_equiv_for_labels_non_hyp :: + "'a PAS \ ('a \ bool) \ det_state \ det_state \ bool" + where + "states_equiv_for_labels_non_hyp aag P \ + states_equiv_for_non_hyp (\x. P (pasObjectAbs aag x)) (\x. P (pasIRQAbs aag x)) + (\x. P (pasASIDAbs aag x)) (\x. \l\pasDomainAbs aag x. P l)" + +abbreviation states_equiv_valid_non_hyp where + "states_equiv_valid_non_hyp aag L P f \ equiv_valid_inv \\ (states_equiv_for_labels_non_hyp aag L) P f" + +lemma states_equiv_for_non_hyp_symmetric: + "states_equiv_for_non_hyp P Q R S s t = states_equiv_for_non_hyp P Q R S t s" + by (auto simp: states_equiv_for_non_hyp_sym) + +lemma states_equiv_valid_non_hyp_unobservable: + assumes f: + "\P Q R S st. \states_equiv_for_non_hyp P Q R S st\ f \\_. states_equiv_for_non_hyp P Q R S st\" + shows + "states_equiv_valid_non_hyp aag l \ (f :: (det_state,unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subst states_equiv_for_non_hyp_symmetric) + apply (erule use_valid) + apply (wp assms) + apply (subst states_equiv_for_non_hyp_symmetric) + apply (erule use_valid) + apply (wp assms) + apply simp + done + +lemma states_equiv_for_non_hyp_current_vcpu_update[simp]: + "states_equiv_for_non_hyp P Q R S st (s\arch_state := arch_state s\arm_current_vcpu := cv\\) = + states_equiv_for_non_hyp P Q R S st s" + by (clarsimp simp: states_equiv_for_non_hyp_def equiv_asids_def equiv_asid_def + equiv_for_def cur_fpu_for_def equiv_fpu_def get_tcb_def) + +lemma vcpu_restore_2_reads_respects_hyp_l: + "equiv_valid (\s s'. equiv_for P kheap s s' \ + equiv_for P (K \ numlistregs) s s') + \\ (\s s'. equiv_for P cur_vcpu_of s s' \ + equiv_for P hw_vcpu_of s s') (valid_arch_state) + (vcpu_restore_2 vr)" + apply (rule_tac P'="\s. vcpus_of s vr \ None" in equiv_valid_guard_necessary) + apply (unfold vcpu_restore_2_def vcpu_restore_def)[1] + apply (clarsimp simp: bind_assoc) + apply (wpsimp wp: get_vcpu_vcpu_at simp: obj_at_def opt_map_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule context_conjI) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (rename_tac s' t' vcpu vcpu') + apply (rule context_conjI, clarsimp simp: comp_def) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (prop_tac "current_vcpu s' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_restore_2_def, simp) + apply (prop_tac "current_vcpu t' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_restore_2_def, simp) + apply (rule conjI) + apply (clarsimp simp: equiv_for_def) + apply (case_tac "P vr") + apply (prop_tac "vcpu = vcpu'") + apply (clarsimp simp: equiv_for_def opt_map_def) + apply (drule use_valid[OF _ vcpu_restore_2_helper], simp)+ + apply (subgoal_tac " Some + (vcpu_vgic_update + (vgic_lr_update (\f r. if numlistregs s' \ r then undefined else f r)) + (vcpu_state.truncate vcpu)) = + Some + (vcpu_vgic_update + (vgic_lr_update (\f r. if numlistregs t' \ r then undefined else f r)) + (vcpu_state.truncate vcpu'))") + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def) + apply (clarsimp simp: equiv_for_def) + apply (drule mp, fastforce)+ + apply clarsimp + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def) + done + +lemma vcpu_restore_2_states_equiv_valid: + "states_equiv_valid aag L (valid_arch_state) (vcpu_restore_2 vr)" + apply (rule equiv_valid_conseq) + apply (rule equiv_valid_split) + apply (subst vcpu_restore_2_def)[1] + apply (rule states_equiv_valid_non_hyp_unobservable[of _ L aag]) + apply (wpsimp)+ + apply (rule vcpu_restore_2_reads_respects_hyp_l[of "L o pasObjectAbs aag"]) + apply (auto simp: states_equiv_for_def comp_def + states_equiv_for_non_hyp_def equiv_hyp_def) + done + +lemma vcpu_enable_2_vcpu_proj: + "\\s. vopt = vcpu_proj savedWhenDisabledRegs {} True False False vr s \ valid_arch_state s\ + vcpu_enable_2 vr + \\_ s. vopt = vcpu_proj {} {} False False False vr s\" + by (wpsimp wp: vcpu_enable_vcpu_proj simp: vcpu_enable_2_def) + +crunch vcpu_enable_2 + for kheap[wp]: "\s. P (kheap s)" + and numlistregs[wp]: "\s. P (numlistregs s)" + +lemma vcpu_enable_2_reads_respects_hyp_l: + "equiv_valid (\s s'. equiv_for P kheap s s' \ + equiv_for P (K \ numlistregs) s s') + (equiv_for P hw_vcpu_of) + (\s s'. equiv_for P cur_vcpu_of s s' \ + equiv_for P hw_vcpu_of s s') (\s. current_vcpu s = Some (vr,False) \ valid_arch_state s) + (vcpu_enable_2 vr)" + apply (rule_tac P'="\s. vcpus_of s vr \ None" in equiv_valid_guard_necessary) + apply (unfold vcpu_enable_2_def vcpu_enable_def)[1] + apply (clarsimp simp: bind_assoc) + apply (wpsimp wp: get_vcpu_vcpu_at simp: obj_at_def opt_map_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule context_conjI) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (rename_tac s' t' vcpu vcpu') + apply (rule context_conjI, clarsimp simp: comp_def) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (prop_tac "current_vcpu s' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_enable_2_def, simp) + apply (prop_tac "current_vcpu t' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_enable_2_def, simp) + apply (rule conjI) + apply (clarsimp simp: equiv_for_def) + apply (case_tac "P vr") + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=x in allE)+ + apply (drule mp, fastforce)+ + apply clarsimp + apply (clarsimp simp: cur_vcpu_of_def) + apply (prop_tac "vcpu' = vcpu") + apply (clarsimp simp: opt_map_def) + apply clarsimp + apply (prop_tac "vcpu_proj savedWhenDisabledRegs {} True False False vr s = + vcpu_proj savedWhenDisabledRegs {} True False False vr t") + apply (clarsimp simp: vcpu_proj_def hw_vcpu_def) + apply (case_tac vcpu; clarsimp) + apply (case_tac vcpu_vgic; clarsimp) + apply (intro conjI ext) + apply (drule_tac x=r in fun_cong, clarsimp) + apply (drule_tac x=reg in fun_cong, clarsimp simp: vcpuRegSavedWhenDisabled_def split: if_splits vcpureg.splits) + apply (prop_tac "vcpus_of s' vr = Some vcpu") + apply (erule use_valid, wpsimp, simp) + apply (prop_tac "vcpus_of t' vr = Some vcpu") + apply (erule use_valid, wpsimp, clarsimp simp: opt_map_def) + apply (drule use_valid, rule vcpu_enable_2_vcpu_proj, solves simp) + apply simp + apply (thin_tac "vcpu_proj _ _ _ _ _ _ _ = vcpu_proj _ _ _ _ _ _ _") + apply (drule use_valid, rule vcpu_enable_2_vcpu_proj, solves simp) + apply (thin_tac "vcpu_proj _ _ _ _ _ _ _ = vcpu_proj _ _ _ _ _ _ _") + apply (clarsimp simp: vcpu_proj_def) + apply (case_tac vcpu; clarsimp) + apply (case_tac vcpu_vgic; clarsimp cong: if_cong) + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def) + done + +lemma vcpu_enable_states_equiv_for_non_hyp[wp]: + "vcpu_enable vopt \states_equiv_for_non_hyp P Q R S st\" + by (wpsimp wp: states_equiv_for_non_hyp_lift equiv_for_lift + equiv_asids_lift equiv_fpu_lift equiv_machine_state_lift) + +lemma vcpu_enable_2_states_equiv_valid: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,False) \ valid_arch_state s) (vcpu_enable_2 vr)" + apply (rule equiv_valid_conseq) + apply (rule equiv_valid_split) + apply (subst vcpu_enable_2_def)[1] + apply (rule states_equiv_valid_non_hyp_unobservable[of _ L aag]) + apply (wpsimp)+ + apply (rule vcpu_enable_2_reads_respects_hyp_l[of "L o pasObjectAbs aag"]) + apply (auto simp: states_equiv_for_def equiv_for_def + states_equiv_for_non_hyp_def equiv_hyp_def) + done + +lemma states_equiv_valid_modify_disable: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True) \ L (pasObjectAbs aag vr)) + (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, False)\\))" + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (erule_tac x=vr in allE)+ + apply clarsimp + apply (drule mp, fastforce) + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (clarsimp simp: hw_vcpu_def) + apply (case_tac "vcpu_state (machine_state s)"; case_tac "vcpu_state (machine_state t)"; clarsimp) + apply (case_tac "vcpu_vgic"; case_tac "vcpu_vgica"; clarsimp) + apply (intro conjI ext) + apply (drule_tac x=r in fun_cong, clarsimp) + apply (clarsimp split: if_splits) + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + done + +lemma vcpu_disable_2_states_equiv_valid: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True) \ valid_arch_state s) (vcpu_disable_2 vr)" + unfolding vcpu_disable_2_def + apply (rule equiv_valid_guard_imp) + apply (rule states_equiv_valid_unit_cases) + apply clarsimp + apply (wp vcpu_disable_Some_states_equiv_valid states_equiv_valid_modify_disable) + apply simp + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply clarsimp + apply assumption + apply wpsimp + apply (auto simp: cur_vcpu_of_def) + done + +crunch vcpu_disable_2, vcpu_enable_2, vcpu_restore_2 + for ready_queues[wp]: "\s. P (ready_queues s)" + +lemma ev_evrv: + "equiv_valid I A B P f \ equiv_valid_rv I A B (=) P f" + by (unfold equiv_valid_def2) + +lemma ev2_case_option: + assumes "\x = None; y = None\ \ equiv_valid_2 I A B R P1 Q1 f g" + and "\b. \x = None; y = Some b\ \ equiv_valid_2 I A B R P2 (Q2 b) f (g' b)" + and "\a. \x = Some a; y = None\ \ equiv_valid_2 I A B R (P3 a) Q3 (f' a) g" + and "\a b. \x = Some a; y = Some b\ \ equiv_valid_2 I A B R (P4 a) (Q4 b) (f' a) (g' b)" + shows "equiv_valid_2 I A B R (case_option (P1 and P2) (P3 and P4) x) + (case_option (Q1 and Q3) (Q2 and Q4) y) + (case_option f f' x) (case_option g g' y)" + apply (case_tac x; case_tac y; clarsimp) + by (rule equiv_valid_2_guard_imp, rule assms; fastforce)+ + +lemma vcpu_switch_states_equiv_valid: + notes ev2l_bind = equiv_valid_2_bind_pre[where P=\ and P'=\ and R'="\\", rotated, simplified] + shows "states_equiv_valid aag L (\s. valid_arch_state s) (vcpu_switch vopt)" + apply (unfold vcpu_switch_def) + apply (fold vcpu_restore_2_def vcpu_enable_2_def vcpu_disable_2_def) + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (simp add: cur_vcpu_for_None') + apply (clarsimp simp: states_equiv_for_def equiv_hyp_def equiv_for_def) + prefer 2 + apply (wpsimp wp: when_ev vcpu_disable_2_states_equiv_valid + vcpu_restore_2_states_equiv_valid vcpu_enable_2_states_equiv_valid gets_ev') + apply (subgoal_tac "\t. states_equiv_for_labels aag L s t \ current_vcpu s = current_vcpu t") + apply (clarsimp simp: valid_arch_state_def) + apply (clarsimp simp: states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (erule_tac x=ptr in allE)+ + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (rule_tac P="\_. none_bot (L o pasObjectAbs aag) vopt" in equiv_valid_cases'') + apply simp + prefer 2 + apply (rule states_equiv_valid_invisible[where P="\", simplified]) + apply (rule modifies_at_mostI) + apply (wpsimp wp: vcpu_enable_2_equiv_but_for_labels + vcpu_disable_2_equiv_but_for_labels + vcpu_restore_2_equiv_but_for_labels) + apply (fastforce simp: cur_vcpu_for_def) + apply wpsimp + apply clarsimp + apply (case_tac vopt; clarsimp simp: equiv_valid_def2) + apply (clarsimp simp: equiv_valid_2_def) + apply (rule equiv_valid_2_bind_pre[OF _ gets_any_evrv]) + apply (rule_tac P="\b. rv \ Some (a,b)" in gen_asm_ev2_l) + apply (rule_tac P'="\b. rv' \ Some (a,b)" in gen_asm_ev2_r) + apply (clarsimp simp: split_def) + apply (rule ev2_case_option) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (subst if_P, clarsimp, blast) + apply (subst return_bind[where f="\_. vcpu_restore_2 _", symmetric], + rule_tac R'=dc in equiv_valid_2_bind_pre) + apply (simp only: K_bind_def) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (rule_tac P=\ and P'=\ + in states_equiv_valid_2_invisible[OF modifies_at_mostI modifies_at_mostI]) + apply (assumption | wpsimp simp: split_def split_del: if_split)+ + apply (subst if_P, clarsimp, blast) + apply (subst return_bind[where f="\_. vcpu_restore_2 _", symmetric], + rule_tac R'=dc in equiv_valid_2_bind_pre) + apply (simp only: K_bind_def) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (rule_tac P=\ and P'=\ + in states_equiv_valid_2_invisible[OF modifies_at_mostI modifies_at_mostI]) + apply (assumption | wpsimp simp: split_def split_del: if_split)+ + apply (subst if_P, clarsimp, blast)+ + apply (rule_tac R'=dc in equiv_valid_2_bind_pre) + apply (simp only: K_bind_def) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (rule_tac P=\ and P'=\ + in states_equiv_valid_2_invisible[OF modifies_at_mostI modifies_at_mostI]) + apply (assumption | wpsimp simp: split_def split_del: if_split)+ + apply (auto simp: cur_vcpu_for_def split: option.splits if_splits) + done + +lemma vcpu_switch_reads_respects: + "reads_respects aag l valid_arch_state (vcpu_switch vopt)" + by (wpsimp wp: reads_respects_from_labels[OF vcpu_switch_states_equiv_valid]) + +lemma set_vcpu_reads_respects[wp]: + "reads_respects aag l \ (set_vcpu vr vcpu)" + unfolding set_vcpu_def + apply (rule_tac P'="vcpu_at vr" in equiv_valid_guard_necessary) + apply (rule wp_pre) + apply (rule hoare_set_object_weaken_pre) + apply wp + apply (clarsimp simp: obj_at_def) + apply (wpsimp wp: set_object_reads_respects) + done + +lemma get_vcpu_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read aag vr \ aag_can_affect aag l vr)) (get_vcpu vr)" + unfolding get_vcpu_def gets_map_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def opt_map_def) + done + +lemma vcpu_update_reads_respects[wp]: + "reads_respects aag l \ (vcpu_update vr f)" + unfolding vcpu_update_def + apply (rule wp_pre) + apply (rule_tac ptr=vr in reads_respects_unit_cases) + apply wpsimp+ + done + +lemma vcpu_read_reg_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read aag v)) (vcpu_read_reg v reg)" + unfolding vcpu_read_reg_def + by wpsimp + +lemma vcpu_write_reg_reads_respects[wp]: + "reads_respects aag l \ (vcpu_write_reg v reg val)" + unfolding vcpu_write_reg_def + by wpsimp + +lemma gets_apply_evrv: + "equiv_valid_rv_inv I A R (K (\s t. I s t \ A s t \ R (f s x) (f t x))) (gets_apply f x)" + apply (simp add: gets_apply_def get_def bind_def return_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + done + +lemma gets_apply_evrv': + "\s t. I s t \ A s t \ P s \ P t \ R (f s x) (f t x) + \ equiv_valid_rv_inv I A R P (gets_apply f x)" + apply (simp add: gets_apply_def get_def bind_def return_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + done + +lemma readVCPUHardwareReg_reads_respects[wp]: + "reads_respects aag l (\s. \b. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some b \ (vcpuRegSavedWhenDisabled reg \ b)) + (do_machine_op (readVCPUHardwareReg reg))" + unfolding readVCPUHardwareReg_def + apply (rule do_machine_op_reads_respects'') + apply wp + apply clarsimp + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some) + apply (case_tac b; clarsimp simp: hw_vcpu_def) + apply (drule_tac x=reg in fun_cong, clarsimp) + done + +lemma writeVCPUHardwareReg_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op (writeVCPUHardwareReg reg val))" + unfolding writeVCPUHardwareReg_def dmo_distr + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects'' modify_ev) + apply wpsimp + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + apply (case_tac "cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) s"; clarsimp simp: cur_vcpu_for_Some) + apply (clarsimp simp: hw_vcpu_def split: if_splits) + apply (intro conjI ext; drule_tac x=r in fun_cong; clarsimp)+ + done + +lemma invoke_vcpu_read_register_reads_respects: + "reads_respects aag l (K (aag_can_read aag v)) (invoke_vcpu_read_register v reg)" + unfolding invoke_vcpu_read_register_def read_vcpu_register_def gets_def + apply (subst bind_assoc) + apply (subst return_bind) + apply (subst bind_assoc[symmetric]) + apply (subst gets_apply_def[symmetric]) + apply simp + apply (rule gen_asm_ev) + apply (rule wp_pre) + apply (unfold equiv_valid_def2) + apply (clarsimp simp: bind_assoc) + apply (rule_tac A=A and B=A and P=\ and W="\x y. fst x = fst y \ (fst x \ x = y)" + and Q="\rv s. (fst rv \ Q rv s) \ (\fst rv \ Q' rv s)" + for A Q Q' in equiv_valid_rv_bind_general) + apply (wpsimp wp: gets_apply_evrv') + apply (prop_tac "equiv_for (aag_can_read aag) cur_vcpu_of s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=v in allE) + apply (auto simp: equiv_for_def cur_vcpu_of_def split: option.splits if_splits)[1] + apply (case_tac "fst rv"; clarsimp split del: if_split; wpfix) + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp + apply (rule equiv_valid_guard_imp) + apply wpsimp + apply clarsimp + apply wpsimp + apply wpsimp+ + apply (clarsimp split: option.splits) + apply simp + done + +lemma invoke_vcpu_write_register_reads_respects: + "reads_respects aag l (K (aag_can_read aag v)) (invoke_vcpu_write_register v reg val)" + unfolding invoke_vcpu_write_register_def write_vcpu_register_def gets_def + apply (subst bind_assoc) + apply (subst return_bind) + apply (subst bind_assoc[symmetric]) + apply (subst gets_apply_def[symmetric]) + apply simp + apply (rule gen_asm_ev) + apply (rule wp_pre) + apply (unfold equiv_valid_def2) + apply (clarsimp simp: bind_assoc) + apply (rule_tac A=A and B=A and P=\ and W="\x y. fst x = fst y \ (fst x \ x = y)" + and Q="\rv s. (fst rv \ Q rv s) \ (\fst rv \ Q' rv s)" + for A Q Q' in equiv_valid_rv_bind_general) + apply (wpsimp wp: gets_apply_evrv') + apply (prop_tac "equiv_for (aag_can_read aag) cur_vcpu_of s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=v in allE) + apply (auto simp: equiv_for_def cur_vcpu_of_def split: option.splits if_splits)[1] + apply (case_tac "fst rv"; clarsimp split del: if_split; wpfix) + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_lr_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op (set_gic_vcpu_ctrl_lr reg val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_lr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma hw_vcpu_lr_update[simp]: + "hw_vcpu n cv (vcpu_vgic_update (vgic_lr_update (\f. f(reg := val))) vst) = + (if reg < n then map_option (vcpu_vgic_update (vgic_lr_update (\f. f(reg := val)))) (hw_vcpu n cv vst) + else hw_vcpu n cv vst)" + by (auto split: if_splits option.splits simp: hw_vcpu_def) + +lemma set_gic_vcpu_ctrl_lr_reads_respects': + "reads_respects aag l (\s. \vr b. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some b) + (do_machine_op (set_gic_vcpu_ctrl_lr reg val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_lr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_lr_reads_respects[wp]: + "reads_respects aag l \ + (do_machine_op (set_gic_vcpu_ctrl_lr reg val))" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: set_gic_vcpu_ctrl_lr_reads_respects'') + apply (wpsimp wp: set_gic_vcpu_ctrl_lr_reads_respects') + done + +lemma vgic_update_reads_respects[wp]: + "reads_respects aag l \ (vgic_update vr f)" + unfolding vgic_update_def by wp + +lemma vgic_lr_update_reads_respects[wp]: + "reads_respects aag l \ (vgic_update_lr vr reg irq)" + unfolding vgic_update_lr_def by wp + +lemma invoke_vcpu_inject_irq_reads_respects: + "reads_respects aag l (\s. aag_can_read aag v) (invoke_vcpu_inject_irq v n irq)" + unfolding invoke_vcpu_inject_irq_def + apply (subst equiv_valid_def2) + apply (rule_tac W="\cv cv'. (cv \ None \ fst (the cv) = v) = (cv' \ None \ fst (the cv') = v)" in equiv_valid_rv_bind) + apply (wpsimp wp: gets_evrv'') + apply (prop_tac "equiv_for (aag_can_read aag) cur_vcpu_of s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=v in allE) + apply (auto simp: equiv_for_def cur_vcpu_of_def split: option.splits if_splits)[1] + apply (clarsimp split del: if_split) + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp+ + done + +lemma invoke_vcpu_ack_vppi_reads_respects: + "reads_respects aag l (K (aag_can_read aag v)) (invoke_vcpu_ack_vppi v vppi)" + unfolding invoke_vcpu_ack_vppi_def + by wpsimp + +lemma as_user_getRegister_reads_respects: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) (as_user thread (getRegister reg))" + apply (simp add: as_user_def split_def) + apply (rule gen_asm_ev) + apply (wp set_object_reads_respects select_f_ev gets_the_ev) + apply (auto intro: reads_affects_equiv_get_tcb_eq det_getRegister)[1] + done + +lemma arch_thread_set_vcpu_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) + (arch_thread_set (tcb_vcpu_update f) t)" + unfolding arch_thread_set_def + apply (wpsimp wp: set_object_reads_respects) + apply fastforce + done + +lemma gets_arm_current_vcpu_reads_respects: + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s \ None) + (gets (arm_current_vcpu \ arch_state))" + apply (wpsimp wp: gets_ev') + apply (erule disjE) + apply (prop_tac "equiv_hyp (aag_can_read aag) s t") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + apply (prop_tac "equiv_hyp (aag_can_affect aag l) s t") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + done + +lemma modify_current_vcpu_None_reads_respects[wp]: + "reads_respects aag l \ + (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\))" + apply (wpsimp wp: modify_ev) + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def) + apply (intro conjI) + prefer 4 + apply (auto simp: equiv_asids_def equiv_asid_def)[2] + prefer 2 + prefer 4 + apply (auto simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def)[2] + apply (clarsimp simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: option.split) + apply (clarsimp simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: option.split) + done + +lemma dmo_dsb_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op dsb)" + unfolding dsb_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma dmo_isb_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op isb)" + unfolding isb_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma dmo_setHCR_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op (setHCR val))" + unfolding setHCR_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma dmo_maskInterrupt_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" + unfolding maskInterrupt_def + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects'' modify_ev) + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + done + +lemma enableFpuEL01_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op enableFpuEL01)" + (is "reads_respects _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma enableFpuEL01_reads_respects': + "reads_respects aag l (\s. \vr. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some True) + (do_machine_op enableFpuEL01)" + (is "reads_respects _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma enableFpuEL01_reads_respects[wp]: + "reads_respects aag l (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op enableFpuEL01)" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: enableFpuEL01_reads_respects'') + apply (wpsimp wp: enableFpuEL01_reads_respects') + done + +lemma setSCTLR_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op (setSCTLR val))" + (is "reads_respects _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma setSCTLR_reads_respects': + "reads_respects aag l (\s. \vr. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some True) + (do_machine_op (setSCTLR val))" + (is "reads_respects _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma setSCTLR_reads_respects[wp]: + "reads_respects aag l (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (setSCTLR val))" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: setSCTLR_reads_respects'') + apply (wpsimp wp: setSCTLR_reads_respects') + done + +lemma set_gic_vcpu_ctrl_hcr_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_hcr_reads_respects': + "reads_respects aag l (\s. \vr. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some True) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_hcr_reads_respects[wp]: + "reads_respects aag l (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_reads_respects'') + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_reads_respects') + done + +lemma vcpu_disable_None_reads_respects[wp]: + "reads_respects aag l (\s. \vr. current_vcpu s = Some (vr,True)) (vcpu_disable None)" + apply (simp only: vcpu_disable_def fun_app_def bind_assoc[symmetric] vcpu_save_vgic_defs[symmetric]) + apply (clarsimp simp: dmo_distr) + apply wpsimp + done + +lemma vcpu_invalidate_active_reads_respects: + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s \ None) vcpu_invalidate_active" + unfolding vcpu_invalidate_active_def + apply wp + apply wpsimp + apply wpsimp + apply (wp gets_arm_current_vcpu_reads_respects) + apply wpsimp + apply clarsimp + done + +lemma arch_thread_get_tcb_vcpu_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read aag t)) (arch_thread_get tcb_vcpu t)" + unfolding arch_thread_get_def + apply wpsimp + apply fastforce + done + +(* FIXME AARCH64 IF: move *) +lemma gets_comp: + "do x <- gets f; + m (g x) + od = + do x <- gets (g \ f); + m x + od" + by (simp add: gets_def) + +lemma dissociate_vcpu_tcb_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (K (aag_can_read aag t \ aag_can_read aag vr)) + (dissociate_vcpu_tcb vr t)" + apply (clarsimp simp: dissociate_vcpu_tcb_def as_user_bind) + apply (subst gets_comp) + apply (wpsimp wp: as_user_set_register_reads_respects' as_user_getRegister_reads_respects when_ev + vcpu_invalidate_active_reads_respects get_vcpu_wp arch_thread_get_wp) + apply (rule conjI; clarsimp) + apply (prop_tac "equiv_hyp (aag_can_read aag) sa ta") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + done + +lemma dissociate_vcpu_tcb_helper: + "\\s. \vcpu'. vcpus_of s vr = Some vcpu' \ P (Some (if v = vr then vcpu'\vcpu_tcb := None\ else vcpu'))\ + dissociate_vcpu_tcb v t + \\_ s. P (vcpus_of s vr)\" + unfolding dissociate_vcpu_tcb_def + apply (wpsimp wp: get_vcpu_wp hoare_vcg_all_lift arch_thread_get_wp) + apply (auto elim!: rsubst[where P=P] intro!: ext split: if_splits) + done + +lemma associate_vcpu_tcb_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and valid_arch_state and K (is_subject aag vr \ is_subject aag t)) (associate_vcpu_tcb vr t)" + unfolding associate_vcpu_tcb_def + apply (rule_tac P'="\s. vcpus_of s vr \ None" in equiv_valid_guard_necessary) + apply (clarsimp simp: bind_assoc) + apply (wpsimp wp: get_vcpu_vcpu_at simp: obj_at_def opt_map_def) + apply (subst gets_comp) + apply (wpsimp wp: when_ev vcpu_switch_reads_respects dissociate_vcpu_tcb_reads_respects + arch_thread_get_wp get_vcpu_wp dissociate_vcpu_tcb_helper + hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (intro conjI impI allI; clarsimp?) + apply (fastforce simp: get_tcb_ko_at dest: associated_vcpu_is_subject) + apply (fastforce dest: associated_tcb_is_subject) + apply (clarsimp simp: reads_equiv_def) + apply (fastforce dest: associated_tcb_is_subject) + apply (clarsimp simp: reads_equiv_def) + done + +lemma perform_vcpu_invocation_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag l (pas_refined aag and valid_arch_state and valid_vcpu_invocation iv and K (authorised_vcpu_inv aag iv)) + (perform_vcpu_invocation iv)" + unfolding perform_vcpu_invocation_def authorised_vcpu_inv_def + by (cases iv; wpsimp wp: associate_vcpu_tcb_reads_respects + invoke_vcpu_inject_irq_reads_respects + invoke_vcpu_read_register_reads_respects + invoke_vcpu_write_register_reads_respects + invoke_vcpu_ack_vppi_reads_respects) + +lemma set_vcpu_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + set_vcpu ptr vcpu + \\_. globals_equiv s\" + unfolding set_vcpu_def + apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] get_object_wp + simp: partial_inv_def)+ + apply (fastforce simp: obj_at_def valid_arch_state_def dest: valid_global_arch_objs_pt_at) + done + +lemma vcpu_update_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + vcpu_update vr f + \\_. globals_equiv s\" + unfolding vcpu_update_def + by wpsimp + +lemma thread_set_globals_equiv: + "(\tcb. arch_tcb_context_get (tcb_arch (f tcb)) = arch_tcb_context_get (tcb_arch tcb)) + \ \globals_equiv s and valid_arch_state\ thread_set f tptr \\_. globals_equiv s\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + apply simp + apply (intro impI conjI allI) + apply (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def dest: valid_global_arch_objs_pt_at)+ + done + +lemma arch_thread_set_vcpu_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + arch_thread_set (tcb_vcpu_update f) t + \\_. globals_equiv s\" + unfolding arch_thread_set_is_thread_set + by (wpsimp wp: thread_set_globals_equiv simp: arch_tcb_context_get_def) + +crunch vcpu_save_reg + for globals_equiv[wp]: "globals_equiv st" + (simp: readVCPUHardwareReg_def) + +crunch vgic_update_lr + for globals_equiv[wp]: "globals_equiv st" + +lemma vcpu_save_reg_range_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + vcpu_save_reg_range vr from to + \\_. globals_equiv s\" + unfolding vcpu_save_reg_range_def + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp_inv) + apply wpsimp+ + done + +lemma dmo_globals_equiv: + "\ \P. f \\ms. P (device_state ms)\ \ + \ do_machine_op f \globals_equiv st\" + apply (simp add: do_machine_op_def) + apply (wp modify_wp | simp add: split_def)+ + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + apply (erule use_valid, fastforce+) + done + +crunch vcpu_save + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +crunch vcpu_restore + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_x_wp_inv mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +crunch vcpu_disable + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_x_wp_inv mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +lemma globals_equiv_arm_current_vcpu_update[simp]: + "globals_equiv st (s\arch_state := arch_state s\arm_current_vcpu := vcpu'\\) = globals_equiv st s" + by (auto simp: globals_equiv_def idle_equiv_def) + +crunch vcpu_switch + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_x_wp_inv mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +lemma vcpu_invalidate_active_valid_arch_state[wp]: + "vcpu_invalidate_active \valid_arch_state\" + unfolding vcpu_invalidate_active_def + apply wp + apply (rule_tac Q'="\_. valid_arch_state" in hoare_strengthen_post[rotated]) + apply (clarsimp simp: valid_arch_state_def cur_vcpu_def valid_global_arch_objs_def) + apply wpsimp+ + done + +crunch vcpu_invalidate_active + for globals_equiv[wp]: "globals_equiv st" + +lemma dissociate_vcpu_tcb_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state and (\s. t \ idle_thread s)\ + dissociate_vcpu_tcb vr t + \\_. globals_equiv s\" + unfolding dissociate_vcpu_tcb_def + apply (wpsimp wp: as_user_globals_equiv simp: arch_tcb_context_get_def as_user_bind) + apply (rule_tac Q'="\_ s. arm_current_vcpu (arch_state s) = None" in hoare_post_add) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: get_vcpu_wp arch_thread_get_wp)+ + done + +lemma associate_vcpu_tcb_globals_equiv[wp]: + "\globals_equiv s and invs and ex_nonz_cap_to t\ + associate_vcpu_tcb vr t + \\_. globals_equiv s\" + unfolding associate_vcpu_tcb_def + apply (wpsimp) + apply (wp hoare_drop_imps) + apply clarsimp + apply wpsimp + apply clarsimp + apply wpsimp + apply (wp get_vcpu_wp) + apply (rule_tac Q'="\_. globals_equiv s and valid_arch_state" in hoare_post_add) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift dissociate_vcpu_tcb_vcpus_of) + apply (wp arch_thread_get_wp) + apply clarsimp + apply (case_tac "t = idle_thread sa", clarsimp) + using idle_no_ex_cap apply fastforce + apply clarsimp + apply (case_tac "vcpus_of sa vr"; clarsimp) + apply (case_tac "vcpu_tcb a"; clarsimp) + apply (case_tac "aa = idle_thread sa"; clarsimp) + apply (subgoal_tac "False", clarsimp) + apply (rename_tac s' tcb vcpu) + apply (prop_tac "(idle_thread s', HypTCBRef) \ state_hyp_refs_of s' vr") + apply (clarsimp simp: state_hyp_refs_of_def opt_map_def split: option.splits) + apply (drule sym_refsD) + apply (erule invs_hyp_sym_refs) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] is_vcpu_def + state_hyp_refs_of_def obj_at_def hyp_live_def hyp_refs_of_def + tcb_vcpu_refs_def refs_of_ao_def arch_live_def vcpu_tcb_refs_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def) + apply (frule invs_iflive) + apply (frule invs_valid_global_refs) + apply (frule invs_valid_objs) + apply (drule (1) idle_no_ex_cap) + apply (erule swap, erule if_live_then_nonz_capD) + apply simp + apply clarsimp + apply (clarsimp simp: live_def hyp_live_def) + done + +crunch invoke_vcpu_inject_irq, invoke_vcpu_read_register, invoke_vcpu_write_register, invoke_vcpu_ack_vppi, perform_smc_invocation + for globals_equiv[wp]: "globals_equiv s" + (wp: dmo_globals_equiv) + +lemma perform_vcpu_invocation_globals_equiv: + "\globals_equiv s and invs and valid_vcpu_invocation iv\ + perform_vcpu_invocation iv + \\_. globals_equiv s\" + unfolding perform_vcpu_invocation_def valid_vcpu_invocation_def + by (cases iv; wpsimp) + +lemma perform_sgi_invocation_reads_respects: + "reads_respects aag l \ (perform_sgi_invocation api)" + unfolding perform_sgi_invocation_def sendSGI_def + by (case_tac api; wpsimp wp: dmo_mol_reads_respects) + +lemma perform_smc_invocation_reads_respects: + "reads_respects aag l \ (perform_smc_invocation api)" + unfolding perform_smc_invocation_def + by (case_tac api; wpsimp wp: dmo_doSMC_mop_reads_respects) + + +definition authorised_for_globals_arch_inv :: + "arch_invocation \ ('z::state_ext) state \ bool" where + "authorised_for_globals_arch_inv ai \ + case ai of InvokePageTable oper \ authorised_for_globals_page_table_inv oper + | InvokePage oper \ authorised_for_globals_page_inv oper + | _ \ \" + +lemma arch_perform_invocation_reads_respects_g: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_g aag l (ct_active and authorised_arch_inv aag ai and valid_arch_inv ai + and authorised_for_globals_arch_inv ai and invs + and pas_refined aag and is_subject aag \ cur_thread) + (arch_perform_invocation ai)" + unfolding arch_perform_invocation_def fun_app_def + apply (case_tac ai; clarsimp) + by (wpsimp wp: doesnt_touch_globalsI + reads_respects_g[OF perform_page_table_invocation_reads_respects] + reads_respects_g[OF perform_page_invocation_reads_respects] + reads_respects_g[OF perform_asid_control_invocation_reads_respects] + reads_respects_g[OF perform_vspace_invocation_reads_respects] + reads_respects_g[OF perform_vcpu_invocation_reads_respects] + reads_respects_g[OF perform_sgi_invocation_reads_respects] + reads_respects_g[OF perform_smc_invocation_reads_respects] + perform_asid_pool_invocation_reads_respects_g + perform_page_table_invocation_globals_equiv + perform_page_invocation_globals_equiv + perform_asid_control_invocation_globals_equiv + perform_asid_pool_invocation_globals_equiv + perform_vcpu_invocation_globals_equiv + perform_sgi_invocation_globals_equiv + simp: authorised_arch_inv_def valid_arch_inv_def authorised_for_globals_arch_inv_def + invs_psp_aligned invs_valid_objs invs_vspace_objs invs_valid_asid_table | simp)+ + +lemma arch_perform_invocation_globals_equiv: + "\globals_equiv s and invs and ct_active and valid_arch_inv ai + and authorised_for_globals_arch_inv ai\ + arch_perform_invocation ai + \\_. globals_equiv s\" + unfolding arch_perform_invocation_def + apply (wpsimp wp: perform_page_table_invocation_globals_equiv + perform_page_invocation_globals_equiv + perform_asid_control_invocation_globals_equiv + perform_asid_pool_invocation_globals_equiv + perform_vcpu_invocation_globals_equiv)+ + apply (auto simp: authorised_for_globals_arch_inv_def invs_def valid_state_def valid_arch_inv_def) + done + +crunch arch_post_cap_deletion + for valid_global_objs[wp]: "valid_global_objs" + +(* generalises auth_ipc_buffers_mem_Write *) +lemma auth_ipc_buffers_mem_Write': + "\ x \ auth_ipc_buffers s thread; pas_refined aag s; valid_objs s \ + \ (pasObjectAbs aag thread, Write, pasObjectAbs aag x) \ pasPolicy aag" + apply (clarsimp simp add: auth_ipc_buffers_member_def) + apply (drule (1) cap_auth_caps_of_state) + apply simp + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + vspace_cap_rights_to_auth_def vm_read_write_def + split: if_split_asm) + apply (auto dest: ipcframe_subset_page) + done + +end + +(* FIXME AARCH64 IF: add to interface *) + +arch_requalify_consts + authorised_for_globals_arch_inv + +arch_requalify_facts + arch_post_cap_deletion_valid_global_objs + auth_ipc_buffers_mem_Write' + thread_set_globals_equiv + arch_post_modify_registers_cur_domain + arch_post_modify_registers_cur_thread + length_msg_lt_msg_max + set_mrs_globals_equiv + arch_perform_invocation_globals_equiv + check_valid_ipc_buffer_inv + arch_perform_invocation_reads_respects_g + +declare + arch_post_cap_deletion_valid_global_objs[wp] + arch_post_modify_registers_cur_domain[wp] + arch_post_modify_registers_cur_thread[wp] + prepare_thread_delete_st_tcb_at_halted[wp] end diff --git a/proof/infoflow/AARCH64/ArchCNode_IF.thy b/proof/infoflow/AARCH64/ArchCNode_IF.thy index 3253d95651..6e95437e4a 100644 --- a/proof/infoflow/AARCH64/ArchCNode_IF.thy +++ b/proof/infoflow/AARCH64/ArchCNode_IF.thy @@ -8,7 +8,7 @@ theory ArchCNode_IF imports CNode_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems CNode_IF_assms @@ -28,48 +28,19 @@ lemma set_object_globals_equiv: apply (clarsimp simp: globals_equiv_def idle_equiv_def tcb_at_def2) done -lemma set_object_globals_equiv'': - "\globals_equiv s and (\ s. ptr \ arm_us_global_vspace (arch_state s)) and (\t. ptr \ idle_thread t)\ - set_object ptr obj - \\_. globals_equiv s\" - by (wpsimp wp: set_object_globals_equiv) - -lemma set_cap_globals_equiv': - "\globals_equiv s and (\ s. fst p \ arm_us_global_vspace (arch_state s))\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: obj_at_def is_tcb_def) - done - lemma set_cap_globals_equiv[CNode_IF_assms]: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" unfolding set_cap_def apply (simp only: split_def) apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: is_tcb_def obj_at_def valid_arch_state_def - dest: valid_global_arch_objs_pt_at) + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def + dest: valid_global_arch_objs_pt_at)+ done definition irq_at :: "nat \ (irq \ bool) \ irq option" where - "irq_at pos masks \ let i = irq_oracle pos in (if i = 0x3F \ masks i then None else Some i)" - -lemma dmo_getActiveIRQ_wp[CNode_IF_assms]: - "\\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) - (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ - do_machine_op (getActiveIRQ in_kernel) - \P\" - apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) - apply (wp modify_wp | wpc)+ - apply clarsimp - apply (erule use_valid) - apply (wp modify_wp) - apply (auto simp: irq_at_def Let_def split: if_splits) - done + "irq_at pos masks \ let i = irq_oracle pos in (if masks i then None else Some i)" lemma arch_globals_equiv_irq_state_update[CNode_IF_assms, simp]: "arch_globals_equiv ct it kh kh' as as' ms (irq_state_update f ms') = @@ -81,7 +52,7 @@ lemma arch_globals_equiv_irq_state_update[CNode_IF_assms, simp]: end -requalify_consts AARCH64.irq_at +arch_requalify_consts irq_at global_interpretation CNode_IF_1?: CNode_IF_1 _ irq_at proof goal_cases @@ -91,7 +62,7 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma is_irq_at_triv[CNode_IF_assms]: assumes a: "\P. \(\s. P (irq_masks (machine_state s))) and Q\ @@ -118,20 +89,29 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: notes gets_ev[wp del] shows "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects') + apply (rule do_machine_op_reads_respects') apply (simp add: getActiveIRQ_def) apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift gets_irq_masks_equiv_valid modify_wp | simp add: no_irq_def)+ apply (rule only_timer_irq_inv_determines_irq_masks, blast+) + apply (wpsimp simp: irq_state_independent_def)+ + done + +lemma dmo_getActiveIRQ_globals_equiv[CNode_IF_assms]: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" + unfolding globals_equiv_def arch_globals_equiv_def idle_equiv_def + apply (rule hoare_weaken_pre) + apply wps + apply wpsimp + apply clarsimp done end diff --git a/proof/infoflow/AARCH64/ArchDecode_IF.thy b/proof/infoflow/AARCH64/ArchDecode_IF.thy index 407f1438e9..4046529cd8 100644 --- a/proof/infoflow/AARCH64/ArchDecode_IF.thy +++ b/proof/infoflow/AARCH64/ArchDecode_IF.thy @@ -8,7 +8,7 @@ theory ArchDecode_IF imports Decode_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Decode_IF_assms @@ -46,20 +46,22 @@ lemma arch_decode_irq_control_invocation_rev[Decode_IF_assms]: (arch_decode_irq_control_invocation label args slot caps)" unfolding arch_decode_irq_control_invocation_def arch_check_irq_def apply (wp ensure_empty_rev lookup_slot_for_cnode_op_rev - is_irq_active_rev whenE_inv + is_irq_active_rev whenE_inv range_check_ev | wp (once) hoare_drop_imps - | simp add: Let_def)+ + | simp add: Let_def unlessE_def split del: if_split)+ apply safe - apply simp+ - apply (blast intro: aag_Control_into_owns_irq ) + apply simp+ + apply (blast intro: aag_Control_into_owns_irq) + apply (drule_tac x="caps ! 0" in bspec) + apply (fastforce intro: bang_0_in_set) + apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) + apply (fastforce dest: is_cnode_into_is_subject intro: bang_0_in_set) apply (drule_tac x="caps ! 0" in bspec) apply (fastforce intro: bang_0_in_set) apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) apply (fastforce dest: is_cnode_into_is_subject intro: bang_0_in_set) done -requalify_facts check_valid_ipc_buffer_inv - end @@ -71,12 +73,13 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq'': "\ \asid. is_subject_asid aag asid; reads_equiv aag s t; pas_refined aag x \ \ arm_asid_table (arch_state s) (asid_high_bits_of base) = arm_asid_table (arch_state t) (asid_high_bits_of base)" + supply asid_high_bits_of_0[simp del] apply (subgoal_tac "asid_high_bits_of 0 = asid_high_bits_of 1") apply (case_tac "base = 0") apply (subgoal_tac "is_subject_asid aag 1") @@ -172,6 +175,10 @@ lemma decode_asid_control_invocation_reads_respects_f: apply fastforce done +lemma reads_respects_f_check_vspace_root[wp]: + "reads_respects_f aag l \ (check_vspace_root cap arg)" + unfolding check_vspace_root_def by wpsimp + lemma decode_frame_invocation_reads_respects_f: notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] notes whenE_wps[wp_split del] @@ -179,15 +186,15 @@ lemma decode_frame_invocation_reads_respects_f: "reads_respects_f aag l (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) - and K (cap = FrameCap p R sz dev m) + and valid_arch_cap cap and K (cap = FrameCap p R sz dev m) and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ is_subject aag (fst slot) \ (\v \ cap_asid' cap. is_subject_asid aag v))) (decode_frame_invocation label args slot cap excaps)" - unfolding decode_frame_invocation_def decode_fr_inv_map_def - check_slot_def check_vp_alignment_def gets_the_def - supply gets_the_ev[wp del] + unfolding decode_frame_invocation_def decode_fr_inv_map_def decode_fr_inv_flush_def + check_vp_alignment_def gets_the_def + apply (rule gen_asm_ev)+ apply (rule equiv_valid_guard_imp) apply ((wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] reads_respects_f_inv'[OF ensure_empty_rev] @@ -202,123 +209,204 @@ lemma decode_frame_invocation_reads_respects_f: | wpc | simp add: Let_def unlessE_whenE | wp (once) whenE_throwError_wp)+)[1] - apply clarsimp + apply (case_tac "invocation_type label = ArchInvocationLabel ARMPageMap"; clarsimp) apply (drule_tac x="excaps ! 0" in bspec, fastforce intro: bang_0_in_set)+ - apply (intro conjI; clarsimp) - apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) - apply (prop_tac "args ! 0 \ user_region") - apply (drule not_le_imp_less) - apply (frule order.strict_implies_order[where b=user_vtop]) - apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) - apply (drule canonical_below_pptr_base_user) - apply (erule below_user_vtop_canonical) - apply (clarsimp simp: user_region_def) - apply (drule is_aligned_no_overflow_mask) - apply (erule (1) dual_order.trans) - apply (rule conjI; clarsimp) - apply (clarsimp simp: reads_equiv_f_def) - apply (frule vspace_for_asid_vs_lookup) - apply (frule_tac pt=xa and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv, - (fastforce dest: aag_has_Control_iff_owns - elim: vs_lookup_table_vref_independent - simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def - pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def - split: option.splits)+)[1] - apply (subgoal_tac "is_subject aag (table_base bb)", clarsimp) - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def vspace_for_asid_def) - apply (frule pt_walk_is_aligned) - apply (erule (1) vspace_for_pool_is_aligned[OF _ _ user_region0]; clarsimp) apply clarsimp - apply (erule_tac asid=a in pt_walk_is_subject[rotated 4]; clarsimp?) - apply (clarsimp simp: vs_lookup_table_def in_omonad) - apply (fastforce intro: vspace_for_asid_is_subject simp: vspace_for_asid_def in_omonad) - done + apply (case_tac "m = None \ \ user_vtop < args ! 0 + mask (pageBitsForSize sz) \ (m = Some (asid, args ! 0))") + prefer 2 + apply clarsimp + apply (prop_tac "\ user_vtop < args ! 0 + mask (pageBitsForSize sz) \ args ! 0 \ user_region") + apply (clarsimp simp: user_region_def not_le) + apply (rule user_vtop_leq_canonical_user) + apply (simp add: vmsz_aligned_def not_less) + apply (drule is_aligned_no_overflow_mask) + apply simp + apply (prop_tac "args ! 0 \ user_region") + apply (fastforce simp: valid_arch_cap_def wellformed_mapdata_def) + apply (subgoal_tac "(\t. reads_equiv_f aag s t \ affects_equiv aag l s t \ + pt_lookup_slot pt (args ! 0) (ptes_of s) = pt_lookup_slot pt (args ! 0) (ptes_of t))") + apply clarsimp + apply (clarsimp simp: reads_equiv_f_def) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac pt=pt and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv) + by (fastforce dest: aag_has_Control_iff_owns + elim: vs_lookup_table_vref_independent + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def + split: option.splits)+ lemma decode_page_table_invocation_reads_respects_f: notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] - notes whenE_wps[wp_split del] shows "reads_respects_f aag l (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) - and K (cap = PageTableCap p m) + and valid_arch_cap cap and K (cap = PageTableCap p pt_t m) and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ is_subject aag (fst slot) \ (\v \ cap_asid' cap. is_subject_asid aag v))) (decode_page_table_invocation label args slot cap excaps)" unfolding decode_page_table_invocation_def decode_pt_inv_map_def gets_the_def - supply gets_the_ev[wp del] - apply (rule equiv_valid_guard_imp) - apply ((wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] - reads_respects_f_inv'[OF ensure_empty_rev] - reads_respects_f_inv'[OF get_pte_rev] - reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] - reads_respects_f_inv'[OF ensure_no_children_rev] - reads_respects_f_inv'[OF lookup_error_on_failure_rev] - find_vspace_for_asid_reads_respects - is_final_cap_reads_respects - select_ext_ev_bind_lift - select_ext_ev_bind_lift[simplified] - | simp add: Let_def unlessE_whenE if_fun_split - | wpc - | wp (once) whenE_throwError_wp hoare_drop_imps)+)[1] + apply (wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF get_pte_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | wpc + | simp add: Let_def unlessE_whenE if_fun_split + | wp (once) whenE_throwError_wp hoare_drop_imps)+ apply clarsimp apply (rule conjI; clarsimp) apply (drule_tac x="excaps ! 0" in bspec, fastforce intro: bang_0_in_set)+ apply (prop_tac "args ! 0 \ user_region") - apply (drule not_le_imp_less) - apply (frule order.strict_implies_order[where b=user_vtop]) - apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) - apply (drule canonical_below_pptr_base_user) - apply (erule below_user_vtop_canonical) - apply (clarsimp simp: user_region_def) - apply clarsimp - apply (intro conjI impI allI; clarsimp) - apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) + apply (clarsimp simp: user_region_def not_le) + apply (rule user_vtop_leq_canonical_user) + apply (simp add: vmsz_aligned_def not_less) + apply (clarsimp cong: conj_cong imp_cong) + apply (rule context_conjI; clarsimp) apply (clarsimp simp: reads_equiv_f_def) apply (frule vspace_for_asid_vs_lookup) - apply (frule_tac pt=xa and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv, + apply (frule_tac pt=pt and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv, (fastforce dest: aag_has_Control_iff_owns elim: vs_lookup_table_vref_independent simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def split: option.splits)+)[1] - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def vspace_for_asid_def) - apply (frule pt_walk_is_aligned) - apply (erule (1) vspace_for_pool_is_aligned[OF _ _ user_region0]; clarsimp) - apply clarsimp - apply (erule_tac asid=a in pt_walk_is_subject[rotated 4]; clarsimp?) - apply (clarsimp simp: vs_lookup_table_def in_omonad) - apply (fastforce intro: vspace_for_asid_is_subject simp: vspace_for_asid_def in_omonad) - apply (rule conjI, fastforce elim!: is_subject_not_silc_inv)+ - apply (clarsimp simp: reads_equiv_f_def) - apply (erule reads_equivE) - apply (clarsimp simp: equiv_asids_def equiv_asid_def) - apply (erule_tac x=a in allE) - apply (fastforce simp: vspace_for_asid_def pool_for_asid_def vspace_for_pool_def - asid_pools_of_ko_at obj_at_def obind_def opt_map_def - split: option.splits) + apply (frule (3) pt_lookup_slot_pte_at) + apply (clarsimp simp: pte_at_def2) + apply (frule vspace_for_asid_is_subject, fastforce+) + apply (clarsimp simp: pt_lookup_slot_def) + apply (erule pt_lookup_slot_from_level_is_subject) + apply fastforce+ + apply (fastforce dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent) + apply clarsimp+ + apply (intro conjI) + apply fastforce + apply fastforce + apply fastforce + apply (fastforce dest: silc_inv_not_subject) done -lemma arch_decode_invocation_reads_respects_f[Decode_IF_assms]: +lemma reads_respects_gets_lookup_frame: + "reads_respects aag l + (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table + and (\s. \asid. vspace_for_asid asid s = Some pt \ + is_subject_asid aag asid \ vptr \ user_region)) + (gets (lookup_frame pt vptr \ ptes_of))" + apply (wp gets_ev') + apply (clarsimp simp: lookup_frame_def pt_lookup_slot_def) + apply (frule (3) vspace_for_asid_is_subject) + apply (frule vspace_for_asid_vs_lookup) + apply (rule obind_eqI_full) + apply (frule (6) pt_walk_reads_equiv[where bot_level=0]) + apply (rule order_refl) + apply (erule vs_lookup_table_vref_independent[OF _ order_refl]) + apply (clarsimp simp: pt_lookup_slot_from_level_def obind_def split: option.splits) + apply clarsimp + apply (rule obind_eqI; clarsimp simp: obind_def) + apply (rule_tac aag=aag in ptes_of_reads_equiv) + by (fastforce elim: vs_lookup_table_vref_independent pt_lookup_slot_from_level_is_subject) + +lemma decode_vspace_invocation_reads_respects_f: notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] - notes whenE_wps[wp_split del] shows "reads_respects_f aag l (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot - and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) - and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. - aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ - is_subject aag (fst slot) \ - (\v \ cap_asid' cap. is_subject_asid aag v))) - (arch_decode_invocation label args cap_index slot cap excaps)" + and valid_arch_cap cap + and K (aag_cap_auth aag (pasObjectAbs aag (fst slot)) (ArchObjectCap cap) \ + is_subject aag (fst slot) \ + (\v \ cap_asid' (ArchObjectCap cap). is_subject_asid aag v))) + (decode_vspace_invocation label args slot cap excaps)" + unfolding decode_vspace_invocation_def decode_vs_inv_flush_def + apply (wpsimp wp: reads_respects_f_inv'[OF reads_respects_gets_lookup_frame] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects whenE_throwError_wp hoare_vcg_all_lift + simp: Let_def)+ + apply (fastforce intro: user_vtop_leq_canonical_user simp: user_region_def user_vtop_def) + done + +lemma aag_cap_auth_VCPUCap: + "\ pas_cap_cur_auth aag (ArchObjectCap (VCPUCap vcpu_ptr)); pas_refined aag s \ + \ is_subject aag vcpu_ptr" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma decode_vcpu_inject_irq_reads_respects_f: + "\ cap = VCPUCap vcpu_ptr; invocation_type label = ArchInvocationLabel ARMVCPUInjectIRQ\ + \ reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and valid_arch_cap cap + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_vcpu_inject_irq args (VCPUCap vcpu_ptr))" + unfolding decode_vcpu_inject_irq_def range_check_def unlessE_whenE + apply (wpsimp wp: reads_respects_f[OF get_vcpu_reads_respects, where st=st]) + apply (prop_tac "valid_numlistregs x") + apply (frule invs_arch_state) + apply (clarsimp simp: valid_arch_state_def) + apply (clarsimp simp: valid_numlistregs_def) + apply (auto simp: aag_cap_auth_VCPUCap reads_equiv_f_def reads_equiv_def2 + states_equiv_for_def equiv_hyp_def equiv_for_def + dest: aag_can_read_self) + done + +lemma decode_vcpu_invocation_reads_respects_f: + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and valid_arch_cap cap + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_vcpu_invocation label args cap excaps)" + unfolding decode_vcpu_invocation_def + apply (cases cap; clarsimp; (solves wp)?) + apply (cases "invocation_type label"; clarsimp; (solves wp)?) + by (wpsimp wp: decode_vcpu_inject_irq_reads_respects_f + simp: decode_vcpu_read_register_def decode_vcpu_write_register_def + decode_vcpu_set_tcb_def decode_vcpu_ack_vppi_def arch_check_irq_def + | fastforce)+ + +lemma decode_sgi_signal_invocation_reads_respects_f[wp]: + "reads_respects_f aag l \ (decode_sgi_signal_invocation (SGISignalCap irq target))" + unfolding decode_sgi_signal_invocation_def + by wpsimp + +lemma decode_smc_invocation_reads_respects_f[wp]: + "reads_respects_f aag l \ (decode_smc_invocation label args cap)" + unfolding decode_smc_invocation_def + by (wpsimp simp: unlessE_whenE) + +lemma arch_decode_invocation_reads_respects_f[Decode_IF_assms]: + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (arch_decode_invocation label args cap_index slot cap excaps)" unfolding arch_decode_invocation_def - apply (cases cap; rule equiv_valid_guard_imp) + apply (cases cap; clarsimp; rule equiv_valid_guard_imp) by (wpsimp wp: decode_asid_pool_invocation_reads_respects_f decode_asid_control_invocation_reads_respects_f decode_frame_invocation_reads_respects_f - decode_page_table_invocation_reads_respects_f | fastforce)+ + decode_vspace_invocation_reads_respects_f + decode_vcpu_invocation_reads_respects_f + decode_page_table_invocation_reads_respects_f + | fastforce dest: caps_of_state_valid cte_wp_at_caps_of_state' + simp: valid_cap_def valid_arch_cap_def)+ end diff --git a/proof/infoflow/AARCH64/ArchFinalCaps.thy b/proof/infoflow/AARCH64/ArchFinalCaps.thy index b7e698fbef..272c8543c8 100644 --- a/proof/infoflow/AARCH64/ArchFinalCaps.thy +++ b/proof/infoflow/AARCH64/ArchFinalCaps.thy @@ -8,7 +8,7 @@ theory ArchFinalCaps imports FinalCaps begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems FinalCaps_assms @@ -46,14 +46,41 @@ lemma set_asid_pool_silc_inv[wp]: apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) done -crunch arch_finalise_cap, prepare_thread_delete, init_arch_objects +lemma set_vcpu_silc_inv: + "\silc_inv aag st\ + set_vcpu ptr vcpu + \\_. silc_inv aag st\" + unfolding set_vcpu_def + apply (rule silc_inv_pres) + apply (wpsimp wp: set_object_wp_strong get_object_wp simp: obj_at_def) + apply (drule (1) silc_inv_cnode_only) + apply (fastforce simp: silc_inv_def obj_at_def is_cap_table_def split: kernel_object.splits) + apply (wpsimp wp: set_object_wp get_object_wp) + apply (wpsimp wp: set_object_wp_strong get_object_wp simp: obj_at_def) + apply (case_tac "ptr = fst (a,b)") + apply (fastforce elim: cte_wp_atE simp: obj_at_def) + apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) + done + +crunch vcpu_switch + for silc_inv[wp]: "silc_inv aag st" + (wp: mapM_x_wp_inv mapM_wp_inv) + +crunch associate_vcpu_tcb + for silc_inv[wp]: "silc_inv aag st" + (wp: crunch_wps simp: arch_thread_set_is_thread_set) + +crunch arch_finalise_cap, prepare_thread_delete for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) -crunch handle_reserved_irq, handle_vm_fault, handle_hypervisor_fault, handle_arch_fault_reply, - arch_invoke_irq_handler, arch_mask_irq_signal, - arch_post_cap_deletion, arch_post_modify_registers, - arch_activate_idle_thread, arch_switch_to_idle_thread, arch_switch_to_thread +crunch init_arch_objects + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) + +crunch handle_vm_fault, handle_arch_fault_reply, arch_invoke_irq_handler, arch_mask_irq_signal, + arch_post_cap_deletion, arch_post_modify_registers, arch_activate_idle_thread, + arch_switch_to_idle_thread, arch_switch_to_thread for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" lemma arch_derive_cap_silc[FinalCaps_assms]: @@ -69,7 +96,6 @@ lemma arch_derive_cap_silc[FinalCaps_assms]: declare init_arch_objects_cte_wp_at[FinalCaps_assms] declare handle_vm_fault_cur_thread[FinalCaps_assms] declare finalise_cap_makes_halted[FinalCaps_assms] -declare init_arch_objects_inv[FinalCaps_assms] end @@ -82,7 +108,7 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma perform_page_table_invocation_silc_inv_get_cap_helper: "\silc_inv aag st and cte_wp_at (is_pt_cap or is_frame_cap) xa\ @@ -113,11 +139,11 @@ lemmas perform_page_table_invocation_silc_inv_get_cap_helper' = perform_page_table_invocation_silc_inv_get_cap_helper[simplified o_def fun_app_def] lemma mapM_x_swp_store_pte_silc_inv[wp]: - "mapM_x (swp store_pte A) slots \silc_inv aag st\" + "mapM_x (swp (store_pte pt_t) A) slots \silc_inv aag st\" by (wp mapM_x_wp[OF _ subset_refl] | simp add: swp_def)+ lemma is_arch_eq_pt_is_pt_or_frame_cap: - "cte_wp_at ((=) (ArchObjectCap (PageTableCap xa xb))) slot s + "cte_wp_at ((=) (ArchObjectCap (PageTableCap pt_t xa xb))) slot s \ cte_wp_at (\a. is_pt_cap a \ is_frame_cap a) slot s" apply (erule cte_wp_at_weakenE) by (clarsimp simp: is_frame_cap_def is_pt_cap_def) @@ -151,6 +177,9 @@ lemma perform_page_table_invocation_silc_inv: apply fastforce done +crunch invalidate_tlb_by_asid_va, perform_flush + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + lemma perform_page_invocation_silc_inv: "\silc_inv aag st and valid_page_inv blah and authorised_page_inv aag blah\ perform_page_invocation blah @@ -167,10 +196,15 @@ lemma perform_page_invocation_silc_inv: apply (clarsimp simp: valid_page_inv_def authorised_page_inv_def split: page_invocation.splits) apply (intro allI impI conjI) - apply (drule_tac slot="(ab,bc)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) - apply (fastforce) + apply (drule_tac slot="(ac,bb)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce)+ + apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) + apply fastforce+ + apply (fastforce simp: silc_inv_def) + apply (drule_tac slot="(ac,bb)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce)+ apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) - apply fastforce + apply fastforce+ apply (fastforce simp: silc_inv_def) apply (fastforce dest: is_arch_eq_pg_is_pt_or_pg_cap simp: silc_inv_def pred_disj_def) done @@ -187,8 +221,8 @@ lemma perform_asid_control_invocation_silc_inv: apply (wp modify_wp cap_insert_silc_inv' retype_region_silc_inv[where sz=pageBits] set_cap_silc_inv get_cap_slots_holding_overlapping_caps[where st=st] delete_objects_silc_inv hoare_weak_lift_imp - | wpc | simp )+ - apply (clarsimp simp: authorised_asid_control_inv_def silc_inv_def valid_aci_def ptr_range_def page_bits_def) + | wpc | simp)+ + apply (clarsimp simp: authorised_asid_control_inv_def silc_inv_def valid_aci_def ptr_range_def) apply (rule conjI) apply (clarsimp simp: range_cover_def obj_bits_api_def default_arch_object_def asid_bits_def pageBits_def) apply (rule of_nat_inverse) @@ -206,10 +240,6 @@ lemma perform_asid_control_invocation_silc_inv: crunch store_asid_pool_entry, handle_spurious_irq for silc_inv[wp]: "silc_inv aag st" -crunch copy_global_mappings - for silc_inv[wp]: "silc_inv aag st" - (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) - lemma perform_asid_pool_invocation_silc_inv: "\silc_inv aag st and K (authorised_asid_pool_inv aag blah)\ perform_asid_pool_invocation blah @@ -222,6 +252,9 @@ lemma perform_asid_pool_invocation_silc_inv: is_ArchObjectCap_def is_PageTableCap_def update_map_data_def)+ done +crunch perform_vcpu_invocation, perform_vspace_invocation, perform_sgi_invocation, perform_smc_invocation + for silc_inv[wp]: "silc_inv aag st" + declare handle_spurious_irq_silc_inv[wp, FinalCaps_assms] lemma arch_perform_invocation_silc_inv[FinalCaps_assms]: @@ -234,10 +267,22 @@ lemma arch_perform_invocation_silc_inv[FinalCaps_assms]: perform_page_invocation_silc_inv perform_asid_control_invocation_silc_inv perform_asid_pool_invocation_silc_inv + perform_vcpu_invocation_silc_inv | wpc)+ apply (clarsimp simp: authorised_arch_inv_def valid_arch_inv_def split: arch_invocation.splits) done +lemma new_irq_handler_caps_are_intra_label: + "\ cte_wp_at ((=) (IRQControlCap)) slot s; pas_refined aag s; is_subject aag (fst slot) \ + \ cap_points_to_label aag (IRQHandlerCap irq) (pasSubject aag)" + apply (clarsimp simp: cap_points_to_label_def) + apply (frule cap_cur_auth_caps_of_state[rotated]) + apply assumption + apply (simp add: cte_wp_at_caps_of_state) + apply (clarsimp simp: aag_cap_auth_def cap_links_irq_def) + apply (blast intro: aag_Control_into_owns_irq) + done + lemma arch_invoke_irq_control_silc_inv[FinalCaps_assms]: "\silc_inv aag st and pas_refined aag and arch_irq_control_inv_valid arch_irq_cinv and K (arch_authorised_irq_ctl_inv aag arch_irq_cinv)\ @@ -249,6 +294,7 @@ lemma arch_invoke_irq_control_silc_inv[FinalCaps_assms]: apply (wp cap_insert_silc_inv'' hoare_vcg_ex_lift slots_holding_overlapping_caps_lift | simp add: authorised_irq_ctl_inv_def arch_irq_control_inv_valid_def)+ apply (fastforce dest: new_irq_handler_caps_are_intra_label) + apply (wpsimp wp: cap_insert_silc_inv'' simp: cap_points_to_label_def) done crunch set_priority, set_flags @@ -256,7 +302,28 @@ crunch set_priority, set_flags (simp: tcb_cap_cases_def) crunch arch_prepare_set_domain, arch_prepare_next_domain, arch_post_set_flags - for inv[FinalCaps_assms,wp]: P + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + (wp: crunch_wps) + +lemma tcb_cap_cases_tcb_fault: + "\(getF, a, b) \ ran tcb_cap_cases. getF (tcb_fault_update F tcb) = getF tcb" + by (rule ball_tcb_cap_casesI, simp+) + +(* FIXME AARCH64 IF: move to lib *) +lemma case_option_wp_returnOk: + assumes [wp]: "\x. \P x\ f x \\_. Q\" + shows "\Q and (\s. opt \ None \ P (the opt) s)\ + case opt of None \ returnOk rv | Some x \ f x + \\_. Q\" + by (cases opt; wpsimp) + +(* FIXME AARCH64 IF: move to lib *) +lemma case_option_wp_return: + assumes [wp]: "\x. \P x\ f x \\_. Q\" + shows "\Q and (\s. opt \ None \ P (the opt) s)\ + case opt of None \ return rv | Some x \ f x + \\_. Q\" + by (cases opt; wpsimp) lemma invoke_tcb_silc_inv[FinalCaps_assms]: notes hoare_weak_lift_imp [wp] @@ -266,19 +333,21 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: invoke_tcb tinv \\_. silc_inv aag st\" apply (case_tac tinv) - apply ((wp restart_silc_inv hoare_vcg_if_lift suspend_silc_inv mapM_x_wp[OF _ subset_refl] - hoare_weak_lift_imp - | wpc - | simp split del: if_split add: authorised_tcb_inv_def check_cap_at_def - | clarsimp - | strengthen invs_mdb - | force intro: notE[rotated,OF idle_no_ex_cap,simplified])+)[3] - defer - apply ((wp suspend_silc_inv restart_silc_inv | simp add: authorised_tcb_inv_def | force)+)[2] - (* NotificationControl *) - apply (rename_tac option) - apply (case_tac option; (wp | simp)+) - (* SetTLSBase *) + apply ((wp restart_silc_inv hoare_vcg_if_lift suspend_silc_inv mapM_x_wp[OF _ subset_refl] + hoare_weak_lift_imp + | wpc + | simp split del: if_split add: authorised_tcb_inv_def check_cap_at_def + | clarsimp + | strengthen invs_mdb + | force intro: notE[rotated,OF idle_no_ex_cap,simplified])+)[3] + defer + apply ((wp suspend_silc_inv restart_silc_inv | simp add: authorised_tcb_inv_def | force)+)[2] + (* NotificationControl *) + apply (rename_tac option) + apply (case_tac option; (wp | simp)+) + (* SetTLSBase *) + apply (wpsimp split: option.splits) + (* SetFlags *) apply (wpsimp split: option.splits) (* just ThreadControl left *) apply (simp add: split_def cong: option.case_cong) @@ -286,7 +355,8 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: apply (strengthen use_no_cap_to_obj_asid_strg | clarsimp | simp only: conj_ac cong: conj_cong imp_cong - | wp checked_insert_pas_refined checked_cap_insert_silc_inv hoare_vcg_all_liftE_R + | wp case_option_wp_returnOk case_option_wp_return + checked_insert_pas_refined checked_cap_insert_silc_inv hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R cap_delete_silc_inv_not_transferable cap_delete_pas_refined' cap_delete_deletes @@ -310,10 +380,12 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: | wp (once) hoare_drop_imps | elim disjE; solves clarsimp)+ (* also slow, ~30s *) - apply (intro impI conjI - | clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def - authorised_tcb_inv_def emptyable_def - split: cap.splits option.splits)+ + prefer 1 + apply (clarsimp simp: is_cap_simps) + apply (clarsimp split: option.split_asm) + apply (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def + authorised_tcb_inv_def emptyable_def + split: cap.splits option.splits pt_type.splits arch_cap.splits)+ done end @@ -326,4 +398,59 @@ proof goal_cases by (unfold_locales; (fact FinalCaps_assms)?) qed + +context Arch begin arch_global_naming + +lemma handle_hypervisor_fault_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and invs and pas_refined aag and is_subject aag o cur_thread and K (is_subject aag t)\ + handle_hypervisor_fault t ex + \\_. silc_inv aag st\" + apply (case_tac ex; clarsimp split del: if_split) + apply (wpsimp wp: handle_fault_silc_inv simp: valid_fault_def) + done + +lemma vppi_event_silc_inv: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + vppi_event irq + \\_. silc_inv aag st\" + unfolding vppi_event_def + apply (wpsimp wp: gts_wp hoare_vcg_all_lift vcpu_update_trivial_invs maskInterrupt_invs + hoare_vcg_imp_lift | wps | wp dmo_wp)+ + apply (clarsimp simp: valid_fault_def) + using ct_active_st_tcb_at_weaken runnable_eq by blast + +lemma vgic_maintenance_silc_inv: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + vgic_maintenance + \\_. silc_inv aag st\" + unfolding vgic_maintenance_def + apply (wpsimp wp: gts_wp hoare_vcg_all_lift hoare_weak_lift_imp dmo_invs_lift + simp: crunch_simps valid_fault_def split_del: if_split + | wps | wp (once) hoare_drop_imps)+ + using ct_active_st_tcb_at_weaken runnable_eq by blast + +lemma handle_reserved_irq_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_. silc_inv aag st\" + unfolding handle_reserved_irq_def + by (cases "irq = irqVGICMaintenance"; wpsimp wp: vgic_maintenance_silc_inv vppi_event_silc_inv) + +lemma handle_reserved_irq_non_kernel_IRQs[FinalCaps_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: when_wp[where P'="\"] simp: non_kernel_IRQs_def irq_vppi_event_index_def) + done + +end + + +global_interpretation FinalCaps_3?: FinalCaps_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms)?) +qed + end diff --git a/proof/infoflow/AARCH64/ArchFinalise_IF.thy b/proof/infoflow/AARCH64/ArchFinalise_IF.thy index 8cfcf47c9d..1dde409f58 100644 --- a/proof/infoflow/AARCH64/ArchFinalise_IF.thy +++ b/proof/infoflow/AARCH64/ArchFinalise_IF.thy @@ -8,7 +8,7 @@ theory ArchFinalise_IF imports Finalise_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Finalise_IF_assms @@ -18,14 +18,7 @@ crunch arch_post_cap_deletion lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" - unfolding maskInterrupt_def - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: equiv_valid_def2) - apply (rule modify_ev2) - apply (fastforce simp: equiv_for_def) - apply (wp modify_wp | simp)+ - done + by wpsimp lemma arch_post_cap_deletion_read_respects[Finalise_IF_assms, wp]: "reads_respects aag l \ (arch_post_cap_deletion acap)" @@ -69,8 +62,8 @@ lemma set_thread_state_reads_respects[Finalise_IF_assms]: apply (rule set_thread_state_act_reads_respects) apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") apply (wp set_object_reads_respects gets_the_ev) - apply (fastforce simp: get_tcb_def split: option.splits - elim: reads_equivE affects_equivE equiv_forE) + apply fastforce + apply (clarsimp simp: equiv_for_def get_tcb_def) apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_bind) apply (rule equiv_valid_rv_trivial) @@ -96,7 +89,8 @@ lemma set_thread_state_runnable_reads_respects[Finalise_IF_assms]: apply (rule set_thread_state_act_runnable_reads_respects) apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") apply (wp set_object_reads_respects gets_the_ev) - apply (fastforce simp: get_tcb_def split: option.splits elim: reads_equivE affects_equivE equiv_forE) + apply fastforce + apply (clarsimp simp: equiv_for_def get_tcb_def) apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_bind) apply (rule equiv_valid_rv_trivial) @@ -110,7 +104,7 @@ lemma set_thread_state_runnable_reads_respects[Finalise_IF_assms]: apply (blast dest: get_tcb_not_asid_pool_at) apply (subst thread_set_def[symmetric, simplified fun_app_def]) apply (wp thread_set_st_tcb_at | simp)+ - done + done lemma set_bound_notification_none_reads_respects[Finalise_IF_assms]: assumes domains_distinct: "pas_domains_distinct aag" @@ -119,7 +113,8 @@ lemma set_bound_notification_none_reads_respects[Finalise_IF_assms]: apply (rule pre_ev(5)[where Q=\]) apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") apply (wp set_object_reads_respects gets_the_ev)[1] - apply (fastforce simp: get_tcb_def split: option.splits elim: reads_equivE affects_equivE equiv_forE) + apply fastforce + apply (clarsimp simp: equiv_for_def get_tcb_def) apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_bind) apply (rule equiv_valid_rv_trivial) @@ -152,7 +147,8 @@ lemma set_tcb_queue_modifies_at_most: "modifies_at_most aag L (\s. pasDomainAbs aag d \ L \ {}) (set_tcb_queue d prio queue)" apply (rule modifies_at_mostI) apply (simp add: set_tcb_queue_def modify_def, wp) - apply (force simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def equiv_asids_def) + apply (force simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def equiv_asids_def + equiv_hyp_def equiv_fpu_def cur_fpu_for_def get_tcb_def) done lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: @@ -165,21 +161,16 @@ lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: done lemma thread_set_reads_respects[Finalise_IF_assms]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects aag l \ (thread_set x y)" - unfolding thread_set_def fun_app_def - apply (case_tac "aag_can_read aag y \ aag_can_affect aag l y") - apply (wp set_object_reads_respects) - apply (clarsimp, rule reads_affects_equiv_get_tcb_eq, simp+)[1] - apply (simp add: equiv_valid_def2) - apply (rule equiv_valid_rv_guard_imp) - apply (rule_tac L="{pasObjectAbs aag y}" and L'="{pasObjectAbs aag y}" - in ev2_invisible[OF domains_distinct]) - apply (assumption | simp add: labels_are_invisible_def)+ - apply (rule modifies_at_mostI[where P="\"] - | wp set_object_equiv_but_for_labels - | simp - | (clarify, drule get_tcb_not_asid_pool_at))+ + "reads_respects aag l \ (thread_set f thread)" + apply (rule equiv_valid_guard_imp) + apply (rule_tac ptr=thread in reads_respects_unit_cases) + unfolding thread_set_def + apply (rule gen_asm_ev) + apply (wpsimp wp: set_object_reads_respects) + apply (wpsimp wp: set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def) + apply wpsimp+ + apply auto done lemma aag_cap_auth_ASIDPoolCap: @@ -190,7 +181,7 @@ lemma aag_cap_auth_ASIDPoolCap: cli_no_irqs pas_refined_all_auth_is_owns) lemma aag_cap_auth_PageDirectory: - "pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word (Some a))) \ + "pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t (Some a))) \ pas_refined aag s \ is_subject aag word" unfolding aag_cap_auth_def by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def @@ -213,27 +204,27 @@ lemma aag_cap_auth_PageCap_asid: intro: pas_refined_Control_into_is_subject_asid) lemma aag_cap_auth_PageTableCap: - "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word option)); pas_refined aag s \ + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t option)); pas_refined aag s \ \ is_subject aag word" unfolding aag_cap_auth_def by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def cli_no_irqs pas_refined_all_auth_is_owns) lemma aag_cap_auth_PageTableCap_asid: - "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word (Some (a, b)))); pas_refined aag s \ + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t (Some (a, b)))); pas_refined aag s \ \ is_subject_asid aag a" by (auto simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def intro: pas_refined_Control_into_is_subject_asid) lemma aag_cap_auth_PageDirectoryCap: - "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word option)); pas_refined aag s \ + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t option)); pas_refined aag s \ \ is_subject aag word" unfolding aag_cap_auth_def by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def cli_no_irqs pas_refined_all_auth_is_owns) lemma aag_cap_auth_PageDirectoryCap_asid: - "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word (Some (a,vref)))); pas_refined aag s \ + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t (Some (a,vref)))); pas_refined aag s \ \ is_subject_asid aag a" unfolding aag_cap_auth_def by (auto simp: cap_links_asid_slot_def label_owns_asid_slot_def @@ -243,11 +234,737 @@ lemmas aag_cap_auth_subject = aag_cap_auth_ASIDPoolCap_asid aag_cap_auth_PageCap_asid aag_cap_auth_PageTableCap_asid +(* Helpful groupings *) + +definition fpu_save where + "fpu_save \ do + cur_fpu_owner \ gets (arm_current_fpu_owner \ arch_state); + do_machine_op enableFpu; + maybeM save_fpu_state cur_fpu_owner + od" + +definition fpu_restore where + "fpu_restore new_owner \ do + case new_owner of None \ do_machine_op disableFpu + | Some tcb_ptr \ load_fpu_state tcb_ptr; + set_arm_current_fpu_owner new_owner + od" + +lemma dmo_enableFpu_reads_respects[wp]: + "states_equiv_valid aag L \ (do_machine_op enableFpu)" + unfolding enableFpu_def dmo_distr + apply wpsimp + apply (wpsimp wp: do_machine_op_states_equiv_valid modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_states_equiv_valid)+ + done + +lemma dmo_disableFpu_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op disableFpu)" + unfolding disableFpu_def dmo_distr + apply wpsimp + apply (wpsimp wp: do_machine_op_states_equiv_valid modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_states_equiv_valid)+ + done + +lemma switch_local_fpu_owner_def2: + "switch_local_fpu_owner new_owner = do fpu_save; fpu_restore new_owner od" + unfolding switch_local_fpu_owner_def fpu_save_def fpu_restore_def + by (clarsimp simp: bind_assoc) + +lemma valid_cur_fpu_cur_fpu_for: + "valid_cur_fpu s \ cur_fpu_for P s = (\p. P p \ is_tcb_cur_fpu p s)" + apply (clarsimp simp: cur_fpu_for_def valid_cur_fpu_def) + apply (rule iffI; erule ex_forward) + apply (clarsimp simp: valid_cur_fpu_def is_tcb_cur_fpu_def obj_at_def get_tcb_def is_arch_cur_fpu_def + split: option.splits kernel_object.splits)+ + done + +lemma equiv_kheap_equiv_current_fpu: + "\ equiv_for P kheap s t; valid_cur_fpu s; valid_cur_fpu t; cur_fpu_for P s; cur_fpu_for P t\ + \ current_fpu s = current_fpu t" + apply (clarsimp simp: valid_cur_fpu_cur_fpu_for valid_cur_fpu_def + equiv_for_def is_tcb_cur_fpu_def obj_at_def) + apply (drule_tac x=p in spec)+ + apply auto + done + +(* FIXME AARCH64 IF: move *) +lemma maybeM_when: + "maybeM f opt = when (opt \ None) (f (the opt))" + by (clarsimp simp: maybeM_def when_def) + +lemma maybeM_ev: + "\ \v. opt = Some v \ equiv_valid_inv I A (P v) (f v) \ + \ equiv_valid_inv I A (\s. \v. opt = Some v \ P v s) (maybeM f opt)" + apply (subst maybeM_when) + apply (rule equiv_valid_guard_imp) + apply (rule_tac P="P (the opt)" in when_ev) + apply auto + done + +lemma as_user_states_equiv_valid_roa: + "states_equiv_valid aag L (K (det f \ (L (pasObjectAbs aag thread)))) (as_user thread f)" + apply (simp add: as_user_def split_def) + apply (rule gen_asm_ev) + apply (wp set_object_states_equiv_valid select_f_ev gets_the_ev) + apply (auto simp: equiv_for_def get_tcb_def arch_tcb_context_set_def states_equiv_for_def) + done + +lemma states_equiv_valid_unobservable_unit_return: + assumes f: + "\P Q R S st. \states_equiv_for P Q R S st\ f \\_. states_equiv_for P Q R S st\" + shows + "states_equiv_valid aag L \ (f::(unit,det_ext) s_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid[OF _ f]) + apply (rule states_equiv_for_sym) + apply (erule use_valid[OF _ f]) + apply (rule states_equiv_for_sym) + apply simp + done + +lemma dmo_readFpuState_states_equiv_valid: + "states_equiv_valid aag L (cur_fpu_for (L o pasObjectAbs aag)) (do_machine_op readFpuState)" + (is "states_equiv_valid _ _ ?P _") + unfolding readFpuState_def dmo_distr + apply (rule_tac Q="\_. ?P" in bind_ev_pre) + apply wpsimp + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: gets_ev') + apply (clarsimp simp: pred_disj_def equiv_fpu_state_def hw_fpu_def) + apply (rule states_equiv_valid_unobservable_unit_return) + apply (wpsimp wp: dmo_wp)+ + done + +lemma det_setFPUStat[simp]: + "det (setFPUState fpu)" + by (wpsimp simp: setFPUState_def) + +lemma thread_set_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag ptr \ L)\ + thread_set f ptr + \\_. equiv_but_for_labels aag L st\" + unfolding thread_set_def + apply (wpsimp wp: set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def split: option.splits kernel_object.splits) + done + +lemma as_user_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag ptr \ L)\ + as_user ptr f + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: as_user_wp_thread_set_helper) + +lemma dmo_readFpuState_inv[wp]: + "do_machine_op readFpuState \P\" + by (wpsimp simp: readFpuState_def wp: dmo_wp) + +lemma save_fpu_state_states_equiv_valid: + "states_equiv_valid aag L (\s. current_fpu s = Some ptr) (save_fpu_state ptr)" + (is "states_equiv_valid _ _ ?P _") + unfolding save_fpu_state_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac P="?P" and ptr=ptr in states_equiv_valid_unit_cases) + apply (wpsimp wp: as_user_states_equiv_valid_roa dmo_readFpuState_states_equiv_valid) + apply (clarsimp simp: cur_fpu_for_def is_arch_cur_fpu_def) + apply wpsimp+ + done + +(* FIXME AARCH64 IF: move *) +locale_abbrev "cur_fpu_of s \ \x. arm_current_fpu_owner (arch_state s) = Some x" + +lemma equiv_fpu_def2: + "equiv_fpu P s s' \ (\x. P x \ + (current_fpu s = Some x \ current_fpu s' = Some x) \ + (current_fpu s = Some x \ machine_fpu s = machine_fpu s'))" + apply (rule eq_reflection) + apply (clarsimp simp: equiv_fpu_def equiv_for_def valid_cur_fpu_cur_fpu_for) + apply (clarsimp simp: hw_fpu_def is_arch_cur_fpu_def) + apply auto + done + +lemma dmo_disableFpu_machine_fpu[wp]: + "do_machine_op disableFpu \\s. P (machine_fpu s)\" + by (wpsimp wp: dmo_wp) + +lemma dmo_enableFpu_machine_fpu[wp]: + "do_machine_op enableFpu \\s. P (machine_fpu s)\" + by (wpsimp wp: dmo_wp) + +lemma tcb_at_typ_at': + "(\P T p. \\s. P (typ_at T p s)\ f \\rv s. P (typ_at T p s)\) + \ \\s. P (tcb_at c s)\ f \\rv s. P (tcb_at c s)\" + by (simp add: tcb_at_typ) + +lemma as_user_not_tcb_at[wp]: + "as_user t m \\s. \tcb_at t' s\" + by (wpsimp wp: tcb_at_typ_at'[OF as_user_typ_at]) + +crunch save_fpu_state + for not_tcb_at[wp]: "\s. \tcb_at t s" + +lemma fpu_of_Some_True[simp]: + "fpu_of (Some True) fopt fpu = Some fpu" + by (clarsimp simp: fpu_of_def) + +lemma fpu_of_Some_False[simp]: + "fpu_of (Some False) fopt fpu = fopt" + by (clarsimp simp: fpu_of_def) + +lemma fpu_of_None[simp]: + "fpu_of None fopt fpu = None" + by (clarsimp simp: fpu_of_def) + +lemma valid_cur_fpu_current_fpu_Some: + "\ valid_cur_fpu s; current_fpu s = Some t \ + \ tcb_cur_fpu_of s t = Some True" + apply (clarsimp simp: valid_cur_fpu_def) + apply (erule_tac x=t in allE) + apply (clarsimp simp: get_tcb_def is_tcb_cur_fpu_def obj_at_def) + done + +lemma save_fpu_state_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag ptr \ L\ + save_fpu_state ptr + \\_. equiv_but_for_labels aag L st\" + unfolding save_fpu_state_def + by wpsimp + +lemma dmo_enableFpu_equiv_but_for_labels[wp]: + "do_machine_op enableFpu \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_disableFpu_equiv_but_for_labels[wp]: + "do_machine_op disableFpu \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma fpu_save_states_equiv_valid: + "states_equiv_valid aag L valid_cur_fpu fpu_save" + unfolding fpu_save_def + apply (rule_tac P="cur_fpu_for (L o pasObjectAbs aag)" in equiv_valid_cases'') + apply (fastforce simp: states_equiv_for_def comp_def equiv_fpu_cur_fpu_for) + apply (wpsimp wp: maybeM_ev gets_ev'' save_fpu_state_states_equiv_valid + hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (rename_tac s t) + apply (prop_tac "valid_cur_fpu s \ cur_fpu_for (L o pasObjectAbs aag) s") + apply assumption + apply (prop_tac "valid_cur_fpu t \ cur_fpu_for (L o pasObjectAbs aag) t") + apply assumption + apply clarsimp + apply (prop_tac "equiv_for (L o pasObjectAbs aag) kheap s t") + apply (fastforce simp: states_equiv_for_def comp_def) + apply (clarsimp simp: equiv_kheap_equiv_current_fpu) + apply wpsimp + apply clarsimp + apply (rule wp_pre) + apply (simp add: equiv_valid_def2) + apply (rule_tac R'="\\" + and Q="\rv. (\s. current_fpu s = rv \ valid_cur_fpu s) + and K (\vr. rv = Some vr \ \ L (pasObjectAbs aag vr))" + and Q'="\rv. (\s. current_fpu s = rv \ valid_cur_fpu s) + and K (\vr. rv = Some vr \ \ L (pasObjectAbs aag vr))" + in equiv_valid_2_bind) + apply (rule EquivValid.gen_asm_ev2_l) + apply (rule EquivValid.gen_asm_ev2_r) + prefer 2 + apply (rule gets_any_evrv) + apply (rule equiv_valid_2_guard_imp) + apply (rule states_equiv_valid_2_invisible) + apply (rule modifies_at_mostI) + apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift) + apply (rule modifies_at_mostI) + apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift) + apply (wp | simp)+ + apply (auto simp: cur_fpu_for_def is_arch_cur_fpu_def) + done + +lemma equiv_valid_lift: + assumes "\P. f \\s. P (i s)\" + shows "equiv_valid (equiv_for P i) \\ \\ \ (f :: ('s state, unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid) + apply (wpsimp wp: assms equiv_for_lift) + apply (erule use_valid) + apply (wpsimp wp: assms equiv_for_lift) + apply clarsimp + done + +crunch getFPUState + for inv[wp]: P + +crunch load_fpu_state + for kheap[wp]: "\s. P (kheap s)" + (wp: as_user_inv) + +lemma set_object_equiv_kheap: + "equiv_valid_inv (equiv_for P kheap) \\ \ (set_object ptr obj)" + by (clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + bind_def' get_def gets_def put_def return_def fail_def assert_def equiv_for_def) + +lemma thread_set_kheap_equiv: + "equiv_valid_inv (equiv_for P kheap) \\ \ (thread_set f thread)" + unfolding thread_set_def + apply (case_tac "P thread") + apply (wpsimp wp: set_object_equiv_kheap) + apply (clarsimp simp: get_tcb_def equiv_for_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + gets_the_def assert_opt_def get_tcb_def bind_def' get_def gets_def + put_def return_def fail_def assert_def equiv_for_def + split: option.splits kernel_object.splits) + done + +lemma arch_thread_set_kheap_equiv: + "equiv_valid_inv (equiv_for P kheap) \\ \ (arch_thread_set f thread)" + by (wpsimp simp: arch_thread_set_is_thread_set wp: thread_set_kheap_equiv) + +lemma gets_current_fpu_owner_equiv_kheap: + "equiv_valid (equiv_for P kheap) (equiv_for P cur_fpu_of) (\_ _. True) + (valid_cur_fpu and cur_fpu_for P) + (gets (arm_current_fpu_owner \ arch_state))" + (is "equiv_valid_inv _ _ ?P _") + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def gets_def get_def return_def bind_def) + apply (clarsimp simp: equiv_for_def cur_fpu_for_def is_arch_cur_fpu_def) + done + +lemma equiv_valid_make_inv: + assumes "equiv_valid_inv I A P f" + shows "equiv_valid I A \\ P f" + using assms + by (fastforce simp: equiv_valid_def2 equiv_valid_2_def) + +lemma arch_thread_set_equiv_for_kheap: + "\equiv_for P kheap st and K (\P thread)\ + arch_thread_set f thread + \\_. equiv_for P kheap st\" + apply (wpsimp wp: arch_thread_set_wp) + apply (clarsimp simp: equiv_for_def) + done + +lemma set_arm_current_fpu_owner_ev: + "equiv_valid (equiv_for P kheap) (equiv_for P cur_fpu_of) \\ (valid_cur_fpu) + (do cur_fpu_owner <- gets (arm_current_fpu_owner \ arch_state); + maybeM (arch_thread_set (tcb_cur_fpu_update (\_. False))) cur_fpu_owner + od)" + apply (rule_tac P="cur_fpu_for P" in equiv_valid_cases'') + apply (fastforce simp: equiv_for_def cur_fpu_for_def is_arch_cur_fpu_def) + apply (rule wp_pre) + apply (rule bind_ev_general) + apply (wp maybeM_ev) + apply (wpsimp wp: maybeM_ev arch_thread_set_kheap_equiv) + apply (wp gets_current_fpu_owner_equiv_kheap) + apply wpsimp + apply clarsimp + apply (rule equiv_valid_make_inv) + apply (rule equiv_valid_inv_lift) + apply (wpsimp wp: arch_thread_set_equiv_for_kheap equiv_for_lift) + apply (clarsimp simp: equiv_for_def cur_fpu_for_def is_arch_cur_fpu_def) + apply (auto simp: equiv_for_sym) + done + +crunch load_fpu_state + for valid_cur_fpu[wp]: valid_cur_fpu + +lemma fpu_restore_equiv_kheap': + "equiv_valid (equiv_for P kheap) (equiv_for P cur_fpu_of) \\ valid_cur_fpu (fpu_restore new_owner)" + unfolding fpu_restore_def set_arm_current_fpu_owner_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac A=B and B=B for B in bind_ev_general) + prefer 2 + apply (rule equiv_valid_inv_lift) + apply (wpsimp wp: equiv_for_lift)+ + apply (fastforce simp: equiv_for_def)+ + apply simp + apply (subst bind_assoc[symmetric]) + apply (rule bind_ev_general) + prefer 2 + apply (rule set_arm_current_fpu_owner_ev) + apply clarsimp + apply (rule bind_ev_general) + prefer 2 + apply (rule equiv_valid_lift) + apply wpsimp + apply (rule maybeM_ev) + apply (rule arch_thread_set_kheap_equiv) + apply wpsimp+ + done + +lemma fpu_restore_equiv_kheap: + "equiv_valid (equiv_for P kheap) (equiv_fpu P) \\ valid_cur_fpu (fpu_restore new_owner)" + apply (rule equiv_valid_conseq) + apply (rule_tac P=P in fpu_restore_equiv_kheap') + apply (clarsimp simp: equiv_fpu_def2 equiv_for_def) + apply clarsimp + done + +crunch fpu_save + for valid_cur_fpu[wp]: "valid_cur_fpu" + (wp: crunch_wps) + +lemma switch_local_fpu_owner_equiv_kheap: + "equiv_valid \\ (states_equiv_for_labels aag L) (equiv_for (L o pasObjectAbs aag) kheap) + valid_cur_fpu (switch_local_fpu_owner new_owner :: (det_state,unit) nondet_monad)" + unfolding switch_local_fpu_owner_def2 + apply (rule equiv_valid_guard_imp) + apply (rule_tac B="\s t. equiv_for (L \ pasObjectAbs aag) kheap s t \ + equiv_fpu (L \ pasObjectAbs aag) s t" + and P'=valid_cur_fpu in bind_ev_general) + by (wpsimp wp: fpu_restore_equiv_kheap[where P="L o pasObjectAbs aag"] + fpu_save_states_equiv_valid[where aag=aag and L=L] + simp: comp_def states_equiv_for_def equiv_for_disj equiv_fpu_def + | rule equiv_valid_conseq[where P=valid_cur_fpu] | fastforce)+ + +definition states_equiv_for_non_fpu :: + "(obj_ref \ bool) \ (irq \ bool) \ (asid \ bool) \ + (domain \ bool) \ det_state \ det_state \ bool" where + "states_equiv_for_non_fpu P Q R S s s' \ + equiv_machine_state P (machine_state s) (machine_state s') \ + equiv_for (P \ fst) cdt s s' \ + equiv_for (P \ fst) cdt_list s s' \ + equiv_for (P \ fst) is_original_cap s s' \ + equiv_for Q interrupt_states s s' \ + equiv_for Q interrupt_irq_node s s' \ + equiv_for S ready_queues s s' \ + equiv_asids R s s' \ + equiv_hyp P s s'" + +lemma states_equiv_for_non_fpu_refl: + "states_equiv_for_non_fpu P Q R S s s" + by (auto simp: states_equiv_for_non_fpu_def intro: equiv_for_refl equiv_asids_refl equiv_hyp_refl) + +lemma states_equiv_for_non_fpu_sym: + "states_equiv_for_non_fpu P Q R S s t \ states_equiv_for_non_fpu P Q R S t s" + by (auto simp: states_equiv_for_non_fpu_def intro: equiv_for_sym equiv_asids_sym equiv_fpu_sym equiv_hyp_sym) + +lemma states_equiv_for_non_fpu_trans: + "\ states_equiv_for_non_fpu P Q R S s t; states_equiv_for_non_fpu P Q R S t u \ + \ states_equiv_for_non_fpu P Q R S s u" + by (auto simp: states_equiv_for_non_fpu_def + intro: equiv_for_trans equiv_asids_trans equiv_fpu_trans equiv_hyp_trans equiv_forI + elim: equiv_forE) + +abbreviation states_equiv_for_labels_non_fpu :: + "'a PAS \ ('a \ bool) \ det_state \ det_state \ bool" where + "states_equiv_for_labels_non_fpu aag P \ + states_equiv_for_non_fpu (\x. P (pasObjectAbs aag x)) (\x. P (pasIRQAbs aag x)) + (\x. P (pasASIDAbs aag x)) (\x. \l\pasDomainAbs aag x. P l)" + +abbreviation states_equiv_valid_non_fpu where + "states_equiv_valid_non_fpu aag L P f \ equiv_valid_inv \\ (states_equiv_for_labels_non_fpu aag L) P f" + +lemma states_equiv_for_non_fpu_symmetric: + "states_equiv_for_non_fpu P Q R S s t \ states_equiv_for_non_fpu P Q R S t s" + by (auto simp: states_equiv_for_non_fpu_sym) + +lemma states_equiv_valid_non_fpu_unobservable: + assumes "\P Q R S st. f \states_equiv_for_non_fpu P Q R S st\" + assumes "\P. f \\s. P (cur_thread s)\" + assumes "\P. f \\s. P (cur_domain s)\" + assumes "\P. f \\s. P (scheduler_action s)\" + assumes "\P. f \\s. P (work_units_completed s)\" + assumes l: "\P. f \\s. P (irq_state (machine_state s))\" + shows "states_equiv_valid_non_fpu aag l \ (f :: (det_state,unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule states_equiv_for_non_fpu_symmetric) + apply (erule use_valid) + apply (wp assms) + apply (rule states_equiv_for_non_fpu_symmetric) + apply (erule use_valid) + apply (wp assms) + apply simp + done + +lemma equiv_hyp_lift: + assumes "\P. f \\s. P (vcpu_state (machine_state s))\" + assumes "\P. f \\s. P (current_vcpu s)\" + assumes "\P. f \\s. P (numlistregs s)\" + shows "f \\s. equiv_hyp P st s\" + unfolding equiv_hyp_def + apply (wpsimp wp: equiv_for_lift assms) + apply (rule hoare_weaken_pre) + apply (wps assms) + apply wpsimp+ + done + +lemma switch_local_fpu_owner_states_equiv_for_non_hyp[wp]: + "switch_local_fpu_owner vopt \states_equiv_for_non_fpu P Q R S st\" + unfolding states_equiv_for_non_fpu_def + by (wpsimp wp: equiv_machine_state_lift equiv_asids_lift equiv_hyp_lift equiv_for_lift dmo_wp) + +lemma valid_cur_fpu_hw_fpu_of: + "valid_cur_fpu s \ + hw_fpu_of s t = (if current_fpu s = Some t + then fpu_of (tcb_cur_fpu_of s t) (tcb_fpu_of s t) (machine_fpu s) + else None)" + supply if_split[split del] + apply (subst fpu_of_def) + apply (clarsimp simp: is_arch_cur_fpu_def hw_fpu_def) + apply (case_tac "current_fpu s = Some t"; clarsimp) + apply (frule (1) current_fpu_owner_Some_tcb_at) + apply (clarsimp simp: tcb_at_def get_tcb_def split: option.splits kernel_object.splits) + apply (clarsimp simp: valid_cur_fpu_def) + apply (erule_tac x=t in allE) + apply (clarsimp simp: is_tcb_cur_fpu_def obj_at_def) + done + +lemma set_arm_current_fpu_owner_current_fpu[wp]: + "\\s. P (new_owner)\ + set_arm_current_fpu_owner new_owner + \\_ s. P (current_fpu s)\" + unfolding set_arm_current_fpu_owner_def + apply wpsimp + apply auto + done + +crunch switch_local_fpu_owner + for valid_cur_fpu[wp]: valid_cur_fpu + (wp: hoare_drop_imps) + +lemma switch_local_fpu_owner_current_fpu[wp]: + "\\s. P (new_owner)\ + switch_local_fpu_owner new_owner + \\_ s. P (current_fpu s)\" + unfolding switch_local_fpu_owner_def + by wpsimp + +lemma switch_local_fpu_owner_hw_fpu_of: + "\\s. valid_cur_fpu s \ fopt = (if new_owner \ Some ptr then None + else if hw_fpu_of s ptr = None then tcb_fpu_of s ptr + else hw_fpu_of s ptr)\ + switch_local_fpu_owner new_owner + \\_ s. fopt = hw_fpu_of s ptr\" + apply (rule_tac Q'="\_ s. valid_cur_fpu s \ + (current_fpu s = Some ptr \ fopt = fpu_of (tcb_cur_fpu_of s ptr) + (tcb_fpu_of s ptr) (machine_fpu s)) \ + (current_fpu s \ Some ptr \ fopt = None)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: valid_cur_fpu_hw_fpu_of) + apply (rule wp_pre) + apply (rule hoare_vcg_conj_lift) + apply wpsimp + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_vcg_imp_lift') + apply wp + apply (wp switch_local_fpu_owner_fpu_of) + apply wp + apply (clarsimp simp: valid_cur_fpu_hw_fpu_of split: if_splits) + apply (simp add: valid_cur_fpu_current_fpu_Some) + apply (clarsimp simp: fpu_of_def get_tcb_def split: option.splits bool.splits kernel_object.splits) + by (simp add: valid_cur_fpu_defs(1,2,3)) + +lemma switch_local_fpu_owner_equiv_fpu: + "equiv_valid (equiv_fpu P) (equiv_for P kheap) \\ valid_cur_fpu (switch_local_fpu_owner new_owner)" + apply (clarsimp simp: equiv_fpu_def equiv_valid_def2 equiv_valid_2_def) + apply (rename_tac s' t') + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=x in allE)+ + apply clarsimp + apply (rule sym) + apply (erule use_valid) + apply (rule switch_local_fpu_owner_hw_fpu_of) + apply (rule conjI, simp) + apply (rule sym) + apply (erule use_valid) + apply (rule switch_local_fpu_owner_hw_fpu_of) + apply (rule conjI, simp) + apply (case_tac "new_owner \ Some x") + apply clarsimp + apply (case_tac "hw_fpu_of s x = None") + apply (clarsimp simp: get_tcb_def) + apply clarsimp + done + +lemma switch_local_fpu_owner_states_equiv_valid[wp]: + "states_equiv_valid aag L (valid_cur_fpu) (switch_local_fpu_owner new_owner)" + apply (rule equiv_valid_conseq) + apply (rule equiv_valid_split) + apply (rule states_equiv_valid_non_fpu_unobservable[of _ L aag]) + apply ((wpsimp simp: fpu_restore_def wp: dmo_wp)+)[6] + apply (rule equiv_valid_split) + apply (rule_tac aag=aag and L=L in switch_local_fpu_owner_equiv_kheap) + apply (rule_tac P="L o pasObjectAbs aag" in switch_local_fpu_owner_equiv_fpu) + apply (clarsimp simp: states_equiv_for_def states_equiv_for_non_fpu_def comp_def)+ + done + +lemma switch_local_fpu_owner_reads_respects[wp]: + "reads_respects aag l (valid_cur_fpu) (switch_local_fpu_owner new_owner)" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_from_labels) + apply (rule switch_local_fpu_owner_states_equiv_valid) + apply wpsimp+ + done + +lemma arch_thread_set_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag t \ L)\ + arch_thread_set f t + \\_. equiv_but_for_labels aag L st\" + unfolding arch_thread_set_def + apply (wpsimp wp: set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def split: option.splits kernel_object.splits) + done + +lemma modify_current_fpu_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ + (\t. current_fpu s = Some t \ pasObjectAbs aag t \ L) \ + (\t. new_owner = Some t \ pasObjectAbs aag t \ L)\ + modify (\s. s\arch_state := arch_state s\arm_current_fpu_owner := new_owner\\) + \\_. equiv_but_for_labels aag L st\" + apply wp + apply (subst equiv_but_for_labels_def) + apply (subst states_equiv_for_def) + apply (intro conjI; (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def; fail)?) + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (prop_tac "equiv_fpu (\x. pasObjectAbs aag x \ L) st s") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (erule equiv_fpu_trans) + apply (clarsimp simp: equiv_fpu_def) + apply (clarsimp simp: equiv_for_def) + apply (clarsimp simp: is_arch_cur_fpu_def) + apply (clarsimp simp: hw_fpu_def) + apply auto + done + +lemma set_arm_current_fpu_owner_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ (\t. new_owner = Some t \ pasObjectAbs aag t \ L) \ + (\t. current_fpu s = Some t \ pasObjectAbs aag t \ L)\ + set_arm_current_fpu_owner new_owner + \\_. equiv_but_for_labels aag L st\" + unfolding set_arm_current_fpu_owner_def + by (wpsimp wp_del: modify_wp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift modify_current_fpu_equiv_but_for_labels) + +lemma dmo_equiv_but_for_labels_fpu: + assumes "\P. f \\ms. P (underlying_memory ms)\" + assumes "\P. f \\ms. P (device_state ms)\" + assumes "\P. f \\ms. P (irq_state ms)\" + assumes "\P. f \\ms. P (vcpu_state ms)\" + shows "\\s. equiv_but_for_labels aag L st s \ \cur_fpu_for (\x. pasObjectAbs aag x \ L) s\ + do_machine_op f + \\_. equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def states_equiv_for_def equiv_asids_def cur_fpu_for_def + apply wp + apply clarsimp + apply (rule hoare_vcg_conj_lift, solves "wpsimp wp: equiv_for_lift equiv_hyp_lift assms dmo_wp")+ + apply (rule hoare_vcg_conj_lift) + apply (clarsimp simp: equiv_fpu_def) + apply (rule_tac Q'="\_ s. (\x. pasObjectAbs aag x \ L \ hw_fpu_of st x = None) \ + \cur_fpu_for (\x. pasObjectAbs aag x \ L) s" + in hoare_strengthen_post) + apply (wpsimp wp: equiv_for_lift2 assms dmo_wp simp: cur_fpu_for_def) + apply (clarsimp simp: equiv_for_def hw_fpu_def) + apply (erule_tac x=x in allE) + apply (clarsimp split: if_splits) + apply (fastforce simp: cur_fpu_for_def) + apply (wpsimp wp: equiv_for_lift equiv_hyp_lift assms dmo_wp) + apply clarsimp + apply (clarsimp simp: equiv_fpu_def) + apply (fastforce simp: equiv_for_def cur_fpu_for_def hw_fpu_def split: if_splits) + done + +lemma as_user_cur_fpu_for[wp]: + "as_user t f \\s. P (cur_fpu_for R s)\" + apply (wpsimp wp: as_user_wp_thread_set_helper thread_set_wp) + apply (auto elim!: rsubst[where P=P] + simp: get_tcb_def cur_fpu_for_def arch_tcb_context_get_def arch_tcb_context_set_def) + done + +lemma dmo_cur_fpu_for[wp]: + "do_machine_op f \\s. P (cur_fpu_for R s)\" + by (wpsimp wp: dmo_wp simp: cur_fpu_for_def) + +crunch save_fpu_state + for cur_fpu_for[wp]: "\s. P (cur_fpu_for R s)" + +lemma load_fpu_state_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ \cur_fpu_for (\a. pasObjectAbs aag a \ L) s\ + load_fpu_state t + \\_. equiv_but_for_labels aag L st\" + unfolding load_fpu_state_def + by (wpsimp wp: dmo_equiv_but_for_labels_fpu as_user_inv) + +lemma switch_local_fpu_owner_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ (\t. cur_fpu_of s t \ pasObjectAbs aag t \ L) \ + (\t. new_owner = Some t \ pasObjectAbs aag t \ L)\ + switch_local_fpu_owner new_owner + \\_. equiv_but_for_labels aag L st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (prop_tac "equiv_fpu (\a. pasObjectAbs aag a \ L) st s") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def) + apply (clarsimp simp: cur_fpu_for_def is_arch_cur_fpu_def) + done + +lemma fpu_release_reads_respects: + "reads_respects aag l valid_cur_fpu (fpu_release t)" + unfolding fpu_release_def + apply (rule equiv_valid_guard_imp) + apply (subst gets_comp) + apply (rule_tac P=valid_cur_fpu and ptr=t in reads_respects_unit_cases) + apply (rule equiv_valid_guard_imp) + apply wp + apply (wpsimp wp: when_ev) + prefer 2 + apply wpsimp + apply (wpsimp wp: gets_ev'') + apply (prop_tac "valid_cur_fpu x \ aag_can_read_or_affect aag l t") + apply assumption + apply (prop_tac "valid_cur_fpu xa \ aag_can_read_or_affect aag l t") + apply assumption + apply (prop_tac "equiv_fpu (aag_can_read_or_affect aag l) x xa \ + equiv_for (aag_can_read_or_affect aag l) kheap x xa ") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 + states_equiv_for_def equiv_for_disj equiv_fpu_def) + apply clarsimp + apply (clarsimp simp: valid_cur_fpu_def equiv_for_def is_tcb_cur_fpu_def obj_at_def) + apply fastforce + apply clarsimp + apply wpsimp+ + apply (wp switch_local_fpu_owner_equiv_but_for_labels) + apply (clarsimp split del: if_split cong: if_cong conj_cong) + apply wp + apply clarsimp + apply wpsimp+ + done + +lemma prepare_thread_delete_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and valid_arch_state and valid_cur_fpu and K (is_subject aag thread)) + (prepare_thread_delete thread)" + unfolding prepare_thread_delete_def + apply (wpsimp wp: fpu_release_reads_respects dissociate_vcpu_tcb_reads_respects hoare_vcg_imp_lift' + | rule arch_thread_get_wp)+ + apply (subgoal_tac "is_subject aag x") + apply fastforce + apply (erule associated_vcpu_is_subject) + apply (simp add: get_tcb_ko_at) + apply simp + apply simp + done + lemma prepare_thread_delete_reads_respects_f[Finalise_IF_assms]: - "reads_respects_f aag l \ (prepare_thread_delete thread)" - unfolding prepare_thread_delete_def by wp + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_f aag l (silc_inv aag st and pas_refined aag and valid_arch_state + and valid_cur_fpu and K (is_subject aag thread)) + (prepare_thread_delete thread)" + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: reads_respects_f[OF prepare_thread_delete_reads_respects, where st=st])+ + done + +lemma vcpu_finalise_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and valid_arch_state and K (is_subject aag vr)) (vcpu_finalise vr)" + unfolding vcpu_finalise_def + apply (rule gen_asm_ev) + apply (wpsimp wp: dissociate_vcpu_tcb_reads_respects get_vcpu_wp) + apply (fastforce dest: associated_tcb_is_subject) + done lemma arch_finalise_cap_reads_respects[Finalise_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot and K (pas_cap_cur_auth aag (ArchObjectCap cap))) (arch_finalise_cap cap final)" @@ -257,15 +974,27 @@ lemma arch_finalise_cap_reads_respects[Finalise_IF_assms]: apply simp apply (simp split: bool.splits) apply (intro impI conjI) - by (wp delete_asid_pool_reads_respects unmap_page_reads_respects unmap_page_table_reads_respects - delete_asid_reads_respects find_vspace_for_asid_reads_respects - | simp add: invs_psp_aligned invs_vspace_objs invs_valid_objs valid_cap_def - valid_arch_state_asid_table invs_arch_state wellformed_mapdata_def - split: option.splits bool.splits - | intro impI conjI allI - | elim conjE - | drule cte_wp_valid_cap - | fastforce dest: aag_can_read_own_asids aag_cap_auth_subject)+ + apply (wp delete_asid_pool_reads_respects unmap_page_reads_respects unmap_page_table_reads_respects + delete_asid_reads_respects find_vspace_for_asid_reads_respects vcpu_finalise_reads_respects + | simp add: invs_psp_aligned invs_vspace_objs invs_valid_objs valid_cap_def + valid_arch_state_asid_table invs_arch_state wellformed_mapdata_def + split: option.splits bool.splits pt_type.splits + | intro impI conjI allI + | elim conjE + | drule cte_wp_valid_cap + | fastforce dest: aag_can_read_own_asids aag_cap_auth_subject)+ + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (drule (1) pas_refined_Control, clarsimp) + apply (wp delete_asid_pool_reads_respects unmap_page_reads_respects unmap_page_table_reads_respects + delete_asid_reads_respects find_vspace_for_asid_reads_respects vcpu_finalise_reads_respects + | simp add: invs_psp_aligned invs_vspace_objs invs_valid_objs valid_cap_def + valid_arch_state_asid_table invs_arch_state wellformed_mapdata_def + split: option.splits bool.splits pt_type.splits + | intro impI conjI allI + | elim conjE + | drule cte_wp_valid_cap + | fastforce dest: aag_can_read_own_asids aag_cap_auth_subject)+ + done (*NOTE: Required to dance around the issue of the base potentially being zero and thus we can't conclude it is in the current subject.*) @@ -277,15 +1006,16 @@ lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': apply (case_tac "b = 0") apply (subgoal_tac "is_subject_asid aag 1") apply ((fastforce intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq - aag_cap_auth_ASIDPoolCap_asid)+)[2] + aag_cap_auth_ASIDPoolCap_asid + simp del: asid_high_bits_of_0)+)[2] apply (auto intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq aag_cap_auth_ASIDPoolCap_asid)[1] apply (simp add: asid_high_bits_of_def asid_low_bits_def) done lemma pt_cap_aligned: - "\ caps_of_state s p = Some (ArchObjectCap (PageTableCap word x)); valid_caps (caps_of_state s) s \ - \ is_aligned word pt_bits" + "\ caps_of_state s p = Some (ArchObjectCap (PageTableCap word pt_t x)); valid_caps (caps_of_state s) s \ + \ is_aligned word (pt_bits pt_t)" by (auto simp: obj_ref_of_def pt_bits_def pageBits_def dest!: cap_aligned_valid[OF valid_capsD, unfolded cap_aligned_def, THEN conjunct1]) @@ -321,7 +1051,37 @@ lemma delete_asid_globals_equiv: delete_asid asid pt \\_. globals_equiv st\" unfolding delete_asid_def - by (wpsimp wp: set_vm_root_globals_equiv set_asid_pool_globals_equiv simp: hwASIDFlush_def) + by (wpsimp wp: set_vm_root_globals_equiv set_asid_pool_globals_equiv hoare_drop_imps) + +lemma vcpu_finalise_globals_equiv[wp]: + "\globals_equiv s and invs\ + vcpu_finalise vr + \\_. globals_equiv s\" + unfolding vcpu_finalise_def + apply (wpsimp wp: dissociate_vcpu_tcb_globals_equiv get_vcpu_wp) + apply (rule conjI, fastforce) + (* FIXME AARCH64 IF: boilerplate *) + apply (rename_tac s' vcpu tcb) + apply clarsimp + apply (prop_tac "(idle_thread s', HypTCBRef) \ state_hyp_refs_of s' vr") + apply (clarsimp simp: state_hyp_refs_of_def opt_map_def split: option.splits) + apply (drule sym_refsD) + apply (erule invs_hyp_sym_refs) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] is_vcpu_def + state_hyp_refs_of_def obj_at_def hyp_live_def hyp_refs_of_def + tcb_vcpu_refs_def refs_of_ao_def arch_live_def vcpu_tcb_refs_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def) + apply (frule invs_iflive) + apply (frule invs_valid_global_refs) + apply (frule invs_valid_objs) + apply (drule (1) idle_no_ex_cap) + apply (erule swap, erule if_live_then_nonz_capD) + apply simp + apply clarsimp + apply (clarsimp simp: live_def hyp_live_def) + done lemma arch_finalise_cap_globals_equiv[Finalise_IF_assms]: "\globals_equiv st and invs and valid_arch_cap cap\ @@ -330,13 +1090,123 @@ lemma arch_finalise_cap_globals_equiv[Finalise_IF_assms]: apply (induct cap; simp add: arch_finalise_cap_def) by (wp delete_asid_pool_globals_equiv case_option_wp unmap_page_globals_equiv unmap_page_table_globals_equiv delete_asid_globals_equiv - | wpc | clarsimp simp: valid_arch_cap_def wellformed_mapdata_def)+ + | wpc | fastforce simp: valid_arch_cap_def wellformed_mapdata_def)+ -declare arch_get_sanitise_register_info_def[simp] +lemma arch_thread_set_fpu_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + arch_thread_set (tcb_cur_fpu_update f) t + \\_. globals_equiv s\" + unfolding arch_thread_set_is_thread_set + by (wpsimp wp: thread_set_globals_equiv simp: arch_tcb_context_get_def) -crunch prepare_thread_delete - for globals_equiv[Finalise_IF_assms, wp]: "globals_equiv st" - (wp: dxo_wp_weak) +lemma globals_equiv_fpu_owner_update[simp]: + "globals_equiv st (s\arch_state := arch_state s\arm_current_fpu_owner := cf\\) = globals_equiv st s" + by (auto simp: globals_equiv_def) + +lemma set_arm_current_fpu_owner_globals_equiv: + "\globals_equiv st and valid_arch_state\ + set_arm_current_fpu_owner new_owner + \\_. globals_equiv st\" + unfolding set_arm_current_fpu_owner_def + by (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift)+ + +lemma load_fpu_state_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. t \ idle_thread s)\ + load_fpu_state t + \\_. globals_equiv st\" + unfolding load_fpu_state_def + by (wpsimp wp: dmo_globals_equiv) + +lemma save_fpu_state_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. t \ idle_thread s)\ + save_fpu_state t + \\_. globals_equiv st\" + unfolding save_fpu_state_def + by (wpsimp wp: dmo_globals_equiv) + +crunch load_fpu_state, save_fpu_state + for valid_arch_state[wp]: valid_arch_state + +(* FIXME AARCH64 IF: move *) +lemma switch_local_fpu_owner_Some_globals_equiv: + "\globals_equiv st and invs and (\s. t \ idle_thread s)\ + switch_local_fpu_owner (Some t) + \\_. globals_equiv st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: set_arm_current_fpu_owner_globals_equiv dmo_globals_equiv + load_fpu_state_globals_equiv save_fpu_state_globals_equiv + hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_cur_fpu_def + is_tcb_cur_fpu_def live_def arch_tcb_live_def + dest: idle_no_ex_cap if_live_then_nonz_capD) + done + +lemma switch_local_fpu_owner_None_globals_equiv: + "\globals_equiv st and invs\ + switch_local_fpu_owner None + \\_. globals_equiv st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: set_arm_current_fpu_owner_globals_equiv dmo_globals_equiv + load_fpu_state_globals_equiv save_fpu_state_globals_equiv + hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_cur_fpu_def + is_tcb_cur_fpu_def live_def arch_tcb_live_def + dest: idle_no_ex_cap if_live_then_nonz_capD) + done + +declare dissociate_vcpu_tcb_globals_equiv[wp del] + +(* FIXME AARCH64 IF: consolidate *) +lemma dissociate_vcpu_tcb_globals_equiv[wp]: + "\globals_equiv s and invs\ + dissociate_vcpu_tcb vr t + \\_. globals_equiv s\" + unfolding dissociate_vcpu_tcb_def + apply (wpsimp wp: as_user_globals_equiv simp: arch_tcb_context_get_def as_user_bind) + apply (rule_tac Q'="\_ s. arm_current_vcpu (arch_state s) = None" in hoare_post_add) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: get_vcpu_wp arch_thread_get_wp)+ + apply (subgoal_tac "(\tcb. ko_at (TCB tcb) t sa \ + (\v. vcpus_of sa vr = Some v \ + tcb_vcpu (tcb_arch tcb) = Some vr \ vcpu_tcb v = Some t \ + t \ idle_thread sa))") + apply fastforce + apply clarsimp + (* FIXME AARCH64 IF: boilerplate *) + apply (rename_tac s' tcb vcpu) + apply (prop_tac "(idle_thread s', HypTCBRef) \ state_hyp_refs_of s' vr") + apply (clarsimp simp: state_hyp_refs_of_def opt_map_def split: option.splits) + apply (drule sym_refsD) + apply (erule invs_hyp_sym_refs) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] is_vcpu_def + state_hyp_refs_of_def obj_at_def hyp_live_def hyp_refs_of_def + tcb_vcpu_refs_def refs_of_ao_def arch_live_def vcpu_tcb_refs_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def) + apply (frule invs_iflive) + apply (frule invs_valid_global_refs) + apply (frule invs_valid_objs) + apply (drule (1) idle_no_ex_cap) + apply (erule swap, erule if_live_then_nonz_capD) + apply simp + apply clarsimp + apply (clarsimp simp: live_def hyp_live_def) + done + +lemma fpu_release_globals_equiv: + "\globals_equiv st and invs\ + fpu_release t + \\_. globals_equiv st\" + unfolding fpu_release_def + by (wpsimp wp: switch_local_fpu_owner_None_globals_equiv) + +lemma prepare_thread_delete_globals_equiv[Finalise_IF_assms, wp]: + "\globals_equiv s and invs\ prepare_thread_delete t \\_. globals_equiv s\" + unfolding prepare_thread_delete_def + by (wpsimp wp: fpu_release_globals_equiv hoare_drop_imps) + +declare arch_get_sanitise_register_info_def[simp] lemma set_bound_notification_globals_equiv[Finalise_IF_assms]: "\globals_equiv s and valid_arch_state\ diff --git a/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy b/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy index a76aeae8e2..4fea890212 100644 --- a/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy +++ b/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy @@ -8,7 +8,7 @@ theory ArchIRQMasks_IF imports IRQMasks_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems IRQMasks_IF_assms @@ -30,10 +30,14 @@ crunch invoke_untyped wp: mapME_x_inv_wp preemption_point_inv simp: crunch_simps no_irq_clearMemory mapM_x_def_bak unless_def) +lemma vcpu_invalidate_active_irq_masks[wp]: + "vcpu_invalidate_active \\s. P (irq_masks_of_state s)\" + unfolding vcpu_invalidate_active_def vcpu_disable_def + by (wpsimp wp: dmo_wp) + crunch finalise_cap for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" - ( wp: crunch_wps dmo_wp no_irq - simp: crunch_simps no_irq_setVSpaceRoot no_irq_hwASIDFlush) + (wp: crunch_wps dmo_wp simp: crunch_simps) crunch send_signal, timer_tick for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" @@ -53,21 +57,16 @@ lemma handle_interrupt_irq_masks[IRQMasks_IF_assms]: apply (wp dmo_wp | simp add: ackInterrupt_def maskInterrupt_def when_def split del: if_split | wpc - | simp add: get_irq_state_def handle_reserved_irq_def - | wp (once) hoare_drop_imp)+ + | simp add: get_irq_state_def + | wp (once) hoare_drop_imp hoare_pre_cont)+ + apply (fastforce simp: domain_sep_inv_def) done lemma arch_invoke_irq_control_irq_masks[IRQMasks_IF_assms]: "\domain_sep_inv False st and arch_irq_control_inv_valid invok\ arch_invoke_irq_control invok \\_ s. P (irq_masks_of_state s)\" - apply (case_tac invok) - apply (clarsimp simp: arch_irq_control_inv_valid_def domain_sep_inv_def valid_def) - done - -crunch handle_vm_fault, handle_hypervisor_fault - for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" - (wp: dmo_wp no_irq) + by (cases invok) (auto simp: arch_irq_control_inv_valid_def domain_sep_inv_def valid_def) lemma dmo_getActiveIRQ_irq_masks[IRQMasks_IF_assms, wp]: "do_machine_op (getActiveIRQ in_kernel) \\s. P (irq_masks_of_state s)\" @@ -81,15 +80,12 @@ lemma dmo_getActiveIRQ_return_axiom[IRQMasks_IF_assms, wp]: apply (rule hoare_pre, rule dmo_wp) apply (insert irq_oracle_max_irq) apply (wp dmo_getActiveIRQ_irq_masks) - apply clarsimp + apply (clarsimp simp: maxIRQ_def) done -crunch activate_thread, handle_spurious_irq - for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" - -crunch schedule +crunch activate_thread, handle_spurious_irq, handle_vm_fault for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" - (wp: dmo_wp crunch_wps dxo_wp_weak simp: crunch_simps) + (wp: dmo_wp no_irq) end @@ -102,15 +98,24 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming + +crunch handle_vm_fault, handle_hypervisor_fault + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp no_irq) crunch do_reply_transfer, set_priority, set_flags, arch_post_set_flags for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" - (wp: crunch_wps empty_slot_irq_masks simp: crunch_simps unless_def) + (wp: crunch_wps dmo_wp empty_slot_irq_masks simp: crunch_simps unless_def) -crunch arch_perform_invocation +lemma no_irq_do_flush[wp,simp]: + "no_irq (do_flush type vstart vend pstart)" + by (wpsimp simp: do_flush_def) + +crunch perform_vspace_invocation, perform_page_table_invocation, perform_asid_control_invocation, + perform_asid_pool_invocation, perform_sgi_invocation, perform_page_invocation for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" - (wp: dmo_wp crunch_wps no_irq) + (wp: dmo_wp crunch_wps no_irq simp: crunch_simps) (* FIXME: remove duplication in this proof -- requires getting the wp automation to do the right thing with dropping imps in validE goals *) @@ -124,7 +129,7 @@ lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: | simp split del: if_split add: check_cap_at_def | clarsimp)+)[3] defer - apply ((wp | simp )+)[2] + apply ((wp | simp)+)[2] (* NotificationControl *) apply (rename_tac option) apply (case_tac option) @@ -151,12 +156,126 @@ lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: apply (simp add: option_update_thread_def | wp hoare_weak_lift_imp hoare_vcg_all_lift | wpc)+ by fastforce+ -lemma init_arch_objects_irq_masks: - "init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_masks_of_state s)\" - by (rule init_arch_objects_inv) +crunch arch_prepare_set_domain, + invoke_vcpu_inject_irq, invoke_vcpu_read_register, + invoke_vcpu_write_register, invoke_vcpu_ack_vppi + for irq_masks[IRQMasks_IF_assms,wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp mapM_x_wp_inv mapM_wp_inv) + +lemma inactive_irqVTimerEvent: + "\domain_sep_inv False st and R False\ + is_irq_active irqVTimerEvent + \\rv. if rv then Q rv else R rv\" + unfolding is_irq_active_def get_irq_state_def + apply wpsimp + apply (fastforce simp: domain_sep_inv_def non_kernel_IRQs_def) + done + +crunch vcpu_restore_reg, vcpu_restore_reg_range + for irq_masks[wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp mapM_x_wp) + +lemma restore_virt_timer_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + restore_virt_timer vcpu_ptr + \\rv s. P (irq_masks_of_state s)\" + unfolding restore_virt_timer_def + by (wpsimp wp: inactive_irqVTimerEvent[where st=st] | wp hoare_pre_cont)+ + +lemma vcpu_enable_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + vcpu_enable vr + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_enable_def + by (wpsimp wp: restore_virt_timer_irq_masks[where st=st] dmo_wp) + +lemma vcpu_restore_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + vcpu_restore vr + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_restore_def + by (wpsimp wp: vcpu_enable_irq_masks[where st=st] mapM_wp_inv dmo_wp) + +lemma vcpu_switch_Some_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + vcpu_switch (Some vcpu) + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_switch_def + by (wpsimp wp: vcpu_restore_irq_masks[where st=st] vcpu_enable_irq_masks[where st=st] dmo_wp) + +lemma associate_vcpu_tcb_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + associate_vcpu_tcb vcpu_ptr t + \\rv s. P (irq_masks_of_state s)\" + unfolding associate_vcpu_tcb_def + by (wpsimp wp: vcpu_switch_Some_irq_masks[where st=st] hoare_weak_lift_imp | wps)+ + +lemma perform_vcpu_invocation_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + perform_vcpu_invocation i + \\rv s. P (irq_masks_of_state s)\" + unfolding perform_vcpu_invocation_def + by (wpsimp wp: associate_vcpu_tcb_irq_masks[where st=st]) + +lemma perform_smc_invocation_irq_masks[wp]: + "\(\s. P (irq_masks_of_state s))\ + perform_smc_invocation i + \\rv s. P (irq_masks_of_state s)\" + unfolding perform_smc_invocation_def doSMC_mop_def + by (wpsimp simp: dmo_distr wp: hoare_drop_imps dmo_wp) + +lemma arch_perform_invocation_irq_masks[IRQMasks_IF_assms, wp]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + arch_perform_invocation i + \\rv s. P (irq_masks_of_state s)\" + unfolding arch_perform_invocation_def fun_app_def + by (wpsimp wp: perform_vcpu_invocation_irq_masks[where st=st]) + +lemma maskVTimer_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + do_machine_op (maskInterrupt True irqVTimerEvent) + \\rv s. P (irq_masks_of_state s)\" + unfolding maskInterrupt_def + apply (wpsimp wp: dmo_machine_state_lift) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: domain_sep_inv_def non_kernel_IRQs_def valid_irq_states_def valid_irq_masks_def) + done -crunch arch_prepare_set_domain - for inv[IRQMasks_IF_assms,wp]: P +lemma vcpu_disable_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + vcpu_disable vo + \\rv s. P (irq_masks_of_state s)\" + by (wpsimp wp: maskVTimer_irq_masks[where st=st] hoare_drop_imps dmo_machine_state_lift + simp: vcpu_disable_def dmo_distr) + +lemma vcpu_switch_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + vcpu_switch vo + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_switch_def + by (wpsimp wp: vcpu_disable_irq_masks[where st=st] + vcpu_restore_irq_masks[where st=st] + vcpu_enable_irq_masks[where st=st] + dmo_machine_state_lift) + +lemma arch_switch_to_idle_thread_irq_masks[IRQMasks_IF_assms]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_idle_thread + \\rv s. P (irq_masks_of_state s)\" + unfolding arch_switch_to_idle_thread_def + by (wpsimp wp: vcpu_switch_irq_masks[where st=st]) + +lemma arch_switch_to_thread_irq_masks[IRQMasks_IF_assms]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_thread t + \\rv s. P (irq_masks_of_state s)\" + unfolding arch_switch_to_thread_def + by (wpsimp wp: vcpu_switch_irq_masks[where st=st]) + +crunch arch_prepare_next_domain + for irq_masks[IRQMasks_IF_assms,wp]: "\s. P (irq_masks_of_state s)" + and valid_irq_states[IRQMasks_IF_assms,wp]: "valid_irq_states" + (wp: crunch_wps) end @@ -169,10 +288,11 @@ proof goal_cases qed -requalify_facts - AARCH64.init_arch_objects_irq_masks - AARCH64.arch_activate_idle_thread_irq_masks - AARCH64.retype_region_irq_masks +(* FIXME AARCH64 IF: add to interface *) +arch_requalify_facts + init_arch_objects_irq_masks + arch_activate_idle_thread_irq_masks + retype_region_irq_masks declare init_arch_objects_irq_masks[wp] diff --git a/proof/infoflow/AARCH64/ArchInfoFlow.thy b/proof/infoflow/AARCH64/ArchInfoFlow.thy index 20ed8281a3..7a2bc30a41 100644 --- a/proof/infoflow/AARCH64/ArchInfoFlow.thy +++ b/proof/infoflow/AARCH64/ArchInfoFlow.thy @@ -10,7 +10,10 @@ imports "Lib.EquivValid" begin -context Arch begin global_naming AARCH64 +(* Declare here and define in InfoFlow_IF *) +consts equiv_for :: "('a \ bool) \ ('b \ 'a \ 'c) \ 'b \ 'b \ bool" + +context Arch begin arch_global_naming section \Arch-specific equivalence properties\ @@ -48,14 +51,71 @@ definition non_asid_pool_kheap_update where \ kheap s x = kh x" -subsection \Exclusive machine state equivalence\ +subsection \VCPU equivalence\ + +(* FIXME AARCH64 IF: move *) +locale_abbrev numlistregs :: "'s state \ nat" where + "numlistregs s \ arm_gicvcpu_numlistregs (arch_state s)" + +(* FIXME AARCH64 IF: move *) +locale_abbrev current_vcpu :: "'s state \ obj_ref \ bool" where + "current_vcpu s \ arm_current_vcpu (arch_state s)" + +definition hw_vcpu :: "nat \ bool option \ vcpu_state \ vcpu_state" where + "hw_vcpu n cv vcpu \ case cv of + None \ None + | Some enabled \ Some + \vcpu_vgic = \vgic_hcr = if \enabled then undefined else vgic_hcr (vcpu_vgic vcpu), + vgic_vmcr = vgic_vmcr (vcpu_vgic vcpu), + vgic_apr = vgic_apr (vcpu_vgic vcpu), + vgic_lr = \r. if r < n then vgic_lr (vcpu_vgic vcpu) r else undefined\, + vcpu_regs = \r. if \enabled \ vcpuRegSavedWhenDisabled r + then undefined + else vcpu_regs vcpu r\" + +locale_abbrev hw_vcpu_of :: "'s state \ obj_ref \ vcpu_state" where + "hw_vcpu_of s p \ hw_vcpu (numlistregs s) (cur_vcpu_of s p) (vcpu_state (machine_state s))" + +lemmas hw_vcpu_of_def = hw_vcpu_def + +definition equiv_hyp :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_hyp P s s' \ equiv_for P (K \ numlistregs) s s' \ + equiv_for P cur_vcpu_of s s' \ + equiv_for P hw_vcpu_of s s'" + + +subsection \FPU equivalence\ + +(* FIXME AARCH64 IF: move *) +locale_abbrev current_fpu :: "'s state \ obj_ref" where + "current_fpu s \ arm_current_fpu_owner (arch_state s)" + +definition is_arch_cur_fpu_2 :: "obj_ref \ obj_ref option \ bool" where + "is_arch_cur_fpu_2 ptr fopt \ fopt = Some ptr" + +locale_abbrev is_arch_cur_fpu :: "obj_ref \ 's state \ bool" where + "is_arch_cur_fpu ptr s \ is_arch_cur_fpu_2 ptr (arm_current_fpu_owner (arch_state s))" + +lemmas is_arch_cur_fpu_def = is_arch_cur_fpu_2_def + +definition hw_fpu :: "bool \ fpu_state \ fpu_state option" where + "hw_fpu cf fpu \ if cf then Some fpu else None" + +locale_abbrev hw_fpu_of :: "'s state \ 64 word \ fpu_state" where + "hw_fpu_of s t \ hw_fpu (is_arch_cur_fpu t s) (fpu_state (machine_state s))" + +definition equiv_fpu :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_fpu P s s' \ equiv_for P hw_fpu_of s s'" + subsection \Global (Kernel) VSpace equivalence\ (* globals_equiv should be maintained by everything except the scheduler, since nothing else touches the globals frame *) -definition arch_globals_equiv :: "obj_ref \ obj_ref \ kheap \ kheap \ arch_state \ - arch_state \ machine_state \ machine_state \ bool" where +definition arch_globals_equiv :: + "obj_ref \ obj_ref \ kheap \ kheap \ arch_state \ + arch_state \ machine_state \ machine_state \ bool" + where "arch_globals_equiv ct it kh kh' as as' ms ms' \ arm_us_global_vspace as = arm_us_global_vspace as' \ kh (arm_us_global_vspace as) = kh' (arm_us_global_vspace as)" @@ -64,10 +124,11 @@ declare arch_globals_equiv_def[simp] end -requalify_consts - AARCH64.equiv_asid - AARCH64.equiv_asid' - AARCH64.arch_globals_equiv - AARCH64.non_asid_pool_kheap_update +(* FIXME AARCH64 IF: requalify elsewhere *) +arch_requalify_consts + equiv_asid + equiv_asid' + arch_globals_equiv + non_asid_pool_kheap_update end diff --git a/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy b/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy index 84c2780a23..e9640f8e59 100644 --- a/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy +++ b/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy @@ -8,10 +8,24 @@ theory ArchInfoFlow_IF imports InfoFlow_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems InfoFlow_IF_assms +definition identical_hyp_state_updates :: + "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_hyp_state_updates P s s' ms ms' \ + identical_updates_for P (hw_vcpu_of s) (hw_vcpu_of s') + (hw_vcpu_of (s\machine_state := ms\)) + (hw_vcpu_of (s'\machine_state := ms'\))" + +definition identical_fpu_state_updates :: + "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_fpu_state_updates P s s' ms ms' \ + identical_updates_for P (hw_fpu_of s) (hw_fpu_of s') + (hw_fpu_of (s\machine_state := ms\)) + (hw_fpu_of (s'\machine_state := ms'\))" + lemma asid_pool_at_kheap: "asid_pool_at ptr s = (\asid_pool. kheap s ptr = Some (ArchObj (ASIDPool asid_pool)))" by (simp add: atyp_at_eq_kheap_obj) @@ -34,6 +48,10 @@ lemma equiv_asids_trans[InfoFlow_IF_assms]: "\ equiv_asids R s t; equiv_asids R t u \ \ equiv_asids R s u" by (fastforce simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap asid_pools_of_ko_at obj_at_def) +lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" + by (auto simp: equiv_asids_def) + lemma equiv_asids_non_asid_pool_kheap_update[InfoFlow_IF_assms]: "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" @@ -49,10 +67,6 @@ lemma equiv_asids_identical_kheap_updates[InfoFlow_IF_assms]: apply (case_tac "kh pool_ptr = kh' pool_ptr"; fastforce) done -lemma equiv_asids_trivial[InfoFlow_IF_assms]: - "(\x. P x \ False) \ equiv_asids P x y" - by (auto simp: equiv_asids_def) - lemma equiv_asids_triv': "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; arm_asid_table (arch_state t) = arm_asid_table (arch_state s); @@ -66,6 +80,80 @@ lemma equiv_asids_triv[InfoFlow_IF_assms]: \ equiv_asids R t t'" by (fastforce simp: equiv_asids_triv') +lemma equiv_hyp_refl[InfoFlow_IF_assms]: + "equiv_hyp P s s" + by (auto simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_sym[InfoFlow_IF_assms]: + "equiv_hyp P s t \ equiv_hyp P t s" + by (auto simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_trans[InfoFlow_IF_assms]: + "\ equiv_hyp P s t; equiv_hyp P t u \ \ equiv_hyp P s u" + by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_guard_imp[InfoFlow_IF_assms]: + "\ equiv_hyp P s s'; \x. Q x \ P x \ \ equiv_hyp Q s s'" + by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_triv': + "\ equiv_hyp P s s'; + arm_current_vcpu (arch_state t) = arm_current_vcpu (arch_state s); + arm_current_vcpu (arch_state t') = arm_current_vcpu (arch_state s'); + vcpu_state (machine_state t) = vcpu_state (machine_state s); + vcpu_state (machine_state t') = vcpu_state (machine_state s'); + arm_gicvcpu_numlistregs (arch_state t) = arm_gicvcpu_numlistregs (arch_state s); + arm_gicvcpu_numlistregs (arch_state t') = arm_gicvcpu_numlistregs (arch_state s') \ + \ equiv_hyp P t t'" + by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_triv[InfoFlow_IF_assms]: + "\ equiv_hyp P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_hyp P t t'" + by (fastforce simp: equiv_hyp_triv') + +lemma equiv_hyp_machine_state_update[InfoFlow_IF_assms]: + "\ equiv_hyp P s s'; identical_hyp_state_updates P s s' ms ms' \ + \ equiv_hyp P (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (fastforce simp: equiv_hyp_def equiv_for_def identical_hyp_state_updates_def identical_updates_def) + +lemma equiv_fpu_refl[InfoFlow_IF_assms]: + "equiv_fpu P s s" + by (auto simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_sym[InfoFlow_IF_assms]: + "equiv_fpu P s t \ equiv_fpu P t s" + by (auto simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_trans[InfoFlow_IF_assms]: + "\ equiv_fpu P s t; equiv_fpu P t u \ \ equiv_fpu P s u" + by (fastforce simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_guard_imp[InfoFlow_IF_assms]: + "\ equiv_fpu P s s'; \x. Q x \ P x \ \ equiv_fpu Q s s'" + by (auto simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_triv': + "\ equiv_fpu P s s'; current_fpu t = current_fpu s; current_fpu t' = current_fpu s'; + fpu_state (machine_state t) = fpu_state (machine_state s); + fpu_state (machine_state t') = fpu_state (machine_state s') \ + \ equiv_fpu P t t'" + by (auto simp: equiv_fpu_def equiv_for_def get_tcb_def hw_fpu_def) + +lemma equiv_fpu_triv[InfoFlow_IF_assms]: + "\ equiv_fpu P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_fpu P t t'" + by (fastforce simp: equiv_fpu_triv') + +lemma equiv_fpu_machine_state_update[InfoFlow_IF_assms]: + "\ equiv_fpu P s s'; identical_fpu_state_updates P s s' ms ms' \ + \ equiv_fpu P (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (fastforce simp: equiv_fpu_def equiv_for_def hw_fpu_def + identical_fpu_state_updates_def identical_updates_def + split: if_splits) + lemma globals_equiv_refl[InfoFlow_IF_assms]: "globals_equiv s s" by (simp add: globals_equiv_def idle_equiv_refl) @@ -79,9 +167,32 @@ lemma globals_equiv_trans[InfoFlow_IF_assms]: unfolding globals_equiv_def arch_globals_equiv_def by clarsimp (metis idle_equiv_trans idle_equiv_def) -lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: - "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" - by (auto simp: equiv_asids_def) +lemma equiv_hypI[InfoFlow_IF_assms]: + assumes "\x. P x \ equiv_hyp ((=) x) s t" + shows "equiv_hyp P s t" + using assms by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_fpuI[InfoFlow_IF_assms]: + assumes "\x. P x \ equiv_fpu ((=) x) s t" + shows "equiv_fpu P s t" + using assms by (fastforce simp: equiv_fpu_def equiv_for_def) + +end + +arch_requalify_consts + identical_hyp_state_updates + identical_fpu_state_updates + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 identical_hyp_state_updates identical_fpu_state_updates +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms)?) +qed + + +context Arch begin arch_global_naming lemma dmo_loadWord_rev[InfoFlow_IF_assms]: "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) @@ -109,10 +220,335 @@ lemma dmo_loadWord_rev[InfoFlow_IF_assms]: apply (wp wp_post_taut loadWord_inv | simp)+ done +definition cur_vcpu_for_2 :: "(obj_ref \ bool) \ (obj_ref \ bool) option \ bool" where + "cur_vcpu_for_2 P cv \ case cv of + None \ None + | Some (ptr,b) \ if P ptr then Some b else None" + +locale_abbrev cur_vcpu_for :: "(obj_ref \ bool) \ 's state \ bool" where + "cur_vcpu_for P s \ cur_vcpu_for_2 P (current_vcpu s)" + +lemmas cur_vcpu_for_def = cur_vcpu_for_2_def + +lemma hw_vcpu_None[simp]: + "hw_vcpu n None vst = None" + by (simp add: hw_vcpu_def) + +definition equiv_hyp_state :: "nat \ bool option \ machine_state \ machine_state \ bool" where + "equiv_hyp_state n cv ms ms' \ hw_vcpu n cv (vcpu_state ms) = hw_vcpu n cv (vcpu_state ms')" + +definition equiv_fpu_state :: "bool \ machine_state \ machine_state \ bool" where + "equiv_fpu_state cf ms ms' \ hw_fpu cf (fpu_state ms) = hw_fpu cf (fpu_state ms')" + +definition no_hyp :: "'a machine_monad \ bool" where + "no_hyp f \ \P. \\s. P (vcpu_state s)\ f \\_ s. P (vcpu_state s)\" + +definition no_fpu :: "'a machine_monad \ bool" where + "no_fpu f \ \P. \\s. P (fpu_state s)\ f \\_ s. P (fpu_state s)\" + +lemma equiv_hyp_state_identical_hyp_state_updates: + "\ equiv_hyp_state (numlistregs s) (cur_vcpu_for P s) ms ms'; equiv_hyp P s t \ + \ identical_hyp_state_updates P s t ms ms'" + apply (clarsimp simp: equiv_hyp_state_def equiv_for_def identical_hyp_state_updates_def equiv_hyp_def) + apply (erule_tac x=x in allE)+ + apply (drule mp, fastforce) + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def identical_updates_rv_def + split: option.splits if_splits) + done + +lemma cur_vcpu_for_None: + "cur_vcpu_for_2 P None = None" + by (clarsimp simp: cur_vcpu_for_def) + +lemma cur_vcpu_for_Some: + "cur_vcpu_for_2 P (Some (a,b)) = (if P a then Some b else None)" + by (clarsimp simp: cur_vcpu_for_def) + +lemma cur_vcpu_for_equiv: + "\ reads_equiv aag st s; affects_equiv aag l st s \ + \ cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) st = cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) s" + apply (prop_tac "equiv_for (aag_can_read aag or aag_can_affect aag l) cur_vcpu_of st s") + apply (simp add: equiv_hyp_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (case_tac "current_vcpu st"; case_tac "current_vcpu s"; clarsimp) + apply (clarsimp simp: cur_vcpu_for_None) + apply (case_tac "(aag_can_read aag or aag_can_affect aag l) a") + prefer 2 + apply (clarsimp simp: cur_vcpu_for_Some) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def) + apply (clarsimp simp: cur_vcpu_for_None) + apply (case_tac "(aag_can_read aag or aag_can_affect aag l) a") + prefer 2 + apply (clarsimp simp: cur_vcpu_for_Some) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def) + apply (case_tac "(aag_can_read aag or aag_can_affect aag l) a"; case_tac "(aag_can_read aag or aag_can_affect aag l) aa") + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def split: if_splits) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def split: if_splits) + apply (erule equiv_forE) + apply (erule_tac x=aa in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def split: if_splits) + apply (clarsimp simp: cur_vcpu_for_Some) + done + +lemma aequiv_get_tcb_eq'[intro]: + "\ affects_equiv aag l s t; aag_can_affect aag l thread \ + \ get_tcb thread s = get_tcb thread t" + by (auto simp: affects_equiv_def2 get_tcb_def elim: states_equiv_forE_kheap) + +definition cur_fpu_for :: "(obj_ref \ bool) \ 's state \ bool" where + "cur_fpu_for P s \ \ptr. P ptr \ is_arch_cur_fpu ptr s" + +lemma equiv_fpu_cur_fpu_for: + "equiv_fpu P st s \ cur_fpu_for P st = cur_fpu_for P s" + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def) + apply (rule iffI; erule ex_forward; erule_tac x=ptr in allE; clarsimp simp: hw_fpu_def split: if_splits) + done + +lemma cur_fpu_for_equiv: + "\ reads_equiv aag st s; affects_equiv aag l st s \ + \ cur_fpu_for (aag_can_read aag or aag_can_affect aag l) st = + cur_fpu_for (aag_can_read aag or aag_can_affect aag l) s" + apply (prop_tac "equiv_fpu (aag_can_read aag or aag_can_affect aag l) st s") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_fpu_def equiv_for_def) + apply (simp add: equiv_fpu_cur_fpu_for) + done + +lemma equiv_fpu_state_identical_fpu_state_updates: + "\ equiv_fpu_state (cur_fpu_for P s) ms ms'; equiv_fpu P s t \ + \ identical_fpu_state_updates P s t ms ms'" + unfolding identical_fpu_state_updates_def + apply (clarsimp simp: identical_fpu_state_updates_def identical_updates_def) + apply (clarsimp simp: equiv_fpu_state_def equiv_for_def equiv_fpu_def) + apply (erule_tac x=x in allE, clarsimp) + apply (auto simp: cur_fpu_for_def hw_fpu_def get_tcb_def identical_updates_rv_def split: if_splits option.splits kernel_object.splits) + done + +definition numlistregs_for :: "(obj_ref \ bool) \ 's state \ nat" where + "numlistregs_for P s \ if \p. P p then numlistregs s else undefined" + +lemma numlistregs_for_equiv: + "\ reads_equiv aag st s; affects_equiv aag l st s \ + \ numlistregs_for (aag_can_read aag or aag_can_affect aag l) st = numlistregs_for (aag_can_read aag or aag_can_affect aag l) s" + by (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def numlistregs_for_def) + +lemma equiv_hyp_state_sym: + "equiv_hyp_state n cv ms' ms \ equiv_hyp_state n cv ms ms'" + by (simp add: equiv_hyp_state_def) + +lemma equiv_fpu_state_sym: + "equiv_fpu_state cf ms' ms \ equiv_fpu_state cf ms ms'" + by (simp add: equiv_fpu_state_def) + +lemma spec_equiv_valid_add_inv: + assumes "spec_equiv_valid st I A B (P and I st) f" + and "\s. I s s" + shows "spec_equiv_valid st I A B P f" + using assms by (fastforce simp: spec_equiv_valid_def equiv_valid_2_def) + +lemma spec_equiv_valid_add_A: + assumes "spec_equiv_valid st I A B (P and A st) f" + and "\s. A s s" + shows "spec_equiv_valid st I A B P f" + using assms by (fastforce simp: spec_equiv_valid_def equiv_valid_2_def) + +lemma do_machine_op_reads_respects'': + assumes equiv_dmo: + "\n cv cf. equiv_valid_inv (equiv_irq_state and equiv_machine_state (aag_can_read aag) + and equiv_hyp_state n cv and equiv_fpu_state cf) + (equiv_machine_state (aag_can_affect aag l)) (Q n cv cf) f" + assumes guard: + "\s. P s \ Q (numlistregs_for (aag_can_read aag or aag_can_affect aag l) s) + (cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) s) + (cur_fpu_for (aag_can_read aag or aag_can_affect aag l) s) + (machine_state s)" + (is "\s. P s \ Q (?nlf s) (?cvf s) (?cff s) (machine_state s)") + shows + "reads_respects aag l P (do_machine_op f)" + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_add_inv) + prefer 2 + apply (simp add: reads_equiv_refl) + apply (rule spec_equiv_valid_add_A) + prefer 2 + apply (simp add: affects_equiv_refl) + apply (unfold do_machine_op_def spec_equiv_valid_def) + supply equiv_for_disj[simp] + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (aag_can_read_or_affect aag l) rv rv' \ + equiv_irq_state rv rv' \ + equiv_hyp_state (?nlf st) (?cvf st) rv rv' \ + equiv_fpu_state (?cff st) rv rv'" + and Q="\r s. st = s \ Q (?nlf st) (?cvf st) (?cff st) r" + and Q'="\r s. Q (?nlf st) (?cvf st) + (?cff st) r" + and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r, ms') (r', ms''). r = r' + \ equiv_machine_state (aag_can_read_or_affect aag l) ms' ms'' + \ equiv_irq_state ms' ms'' + \ equiv_hyp_state (?nlf st) (?cvf st) ms' ms'' + \ equiv_fpu_state (?cff st) ms' ms''" + and Q="\r s. s = st" + and Q'="\\" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (rule conjI) + apply (rule reads_equiv_machine_state_update; clarsimp?) + apply (rule equiv_hyp_state_identical_hyp_state_updates) + apply (clarsimp simp: equiv_hyp_state_def cur_vcpu_for_def numlistregs_for_def + split: option.splits if_splits) + apply (erule reads_equivE, clarsimp simp: equiv_hyp_def) + apply (rule equiv_fpu_state_identical_fpu_state_updates) + apply (fastforce simp: equiv_fpu_state_def cur_fpu_for_def hw_fpu_def + split: option.splits if_splits) + apply (erule reads_equivE, clarsimp simp: equiv_fpu_def) + apply (rule affects_equiv_machine_state_update; clarsimp?) + apply (rule equiv_hyp_state_identical_hyp_state_updates) + apply (clarsimp simp: equiv_hyp_state_def cur_vcpu_for_def numlistregs_for_def + split: option.splits if_splits) + apply (erule affects_equivE, clarsimp simp: equiv_hyp_def) + apply (rule equiv_fpu_state_identical_fpu_state_updates) + apply (fastforce simp: equiv_fpu_state_def cur_fpu_for_def hw_fpu_def + split: option.splits if_splits) + apply (erule affects_equivE, clarsimp simp: equiv_fpu_def) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or + simp: split_def split: prod.splits simp: equiv_for_def)[1] + apply (erule_tac x="?nlf st" in meta_allE) + apply (erule_tac x="?cvf st" in meta_allE) + apply (erule_tac x="?cff st" in meta_allE) + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) + apply clarsimp + apply (drule (1) bspec)+ + apply clarsimp + apply wp + apply wp + apply clarsimp + apply clarsimp + apply (clarsimp simp: equiv_valid_2_def in_monad) + apply (intro conjI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (frule (1) cur_vcpu_for_equiv) + apply (clarsimp simp: equiv_hyp_state_def) + apply (prop_tac "equiv_for (aag_can_read aag or aag_can_affect aag l) (K \ numlistregs) st t") + apply (simp add: equiv_hyp_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (prop_tac "equiv_for (aag_can_read aag or aag_can_affect aag l) hw_vcpu_of st t") + apply (simp add: equiv_hyp_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (case_tac "cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) t"; clarsimp) + apply (clarsimp simp: cur_vcpu_for_def split: option.splits if_splits) + apply (erule equiv_forE)+ + apply (erule_tac x=aa in meta_allE, clarsimp)+ + apply (clarsimp simp: cur_vcpu_of_def hw_vcpu_def numlistregs_for_def split: if_splits) + apply (frule (1) cur_fpu_for_equiv) + apply (clarsimp simp: equiv_fpu_state_def) + apply (prop_tac "equiv_for ((aag_can_read aag or aag_can_affect aag l)) hw_fpu_of st t") + apply (simp add: equiv_fpu_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (fastforce simp: equiv_for_def hw_fpu_def cur_fpu_for_def split: if_splits) + apply (wp | simp add: guard)+ + using guard cur_fpu_for_equiv cur_vcpu_for_equiv numlistregs_for_equiv apply fastforce + done + +lemma do_machine_op_reads_respects'[InfoFlow_IF_assms]: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f" + assumes guard: "\s. P s \ Q (machine_state s)" + assumes no_hyp: "no_hyp f" + assumes no_fpu: "no_fpu f" + shows "reads_respects aag l P (do_machine_op f)" + apply (rule do_machine_op_reads_respects''[where Q="\_ _ _. Q"]) + apply (insert equiv_dmo no_hyp no_fpu) + apply (clarsimp simp: equiv_valid_2_def equiv_valid_def2 equiv_for_or no_hyp_def no_fpu_def + equiv_for_def split_def) + apply (rename_tac rv st rv' st') + apply (drule_tac x=s in spec, drule_tac x=t in spec) + apply clarsimp + apply (drule (1) bspec)+ + apply clarsimp + apply (rule conjI) + apply (clarsimp simp: equiv_hyp_state_def) + apply (erule use_valid, erule spec)+ + apply clarsimp + apply (clarsimp simp: equiv_fpu_state_def) + apply (erule use_valid, erule spec)+ + apply clarsimp + apply (simp add: guard) + done + +lemma equiv_hyp_state_upds[simp]: + "\f. equiv_hyp_state n cv ms (underlying_memory_update f ms') = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv (underlying_memory_update f ms) ms' = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv ms (device_state_update f ms') = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv (device_state_update f ms) ms' = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv ms (machine_state_rest_update f ms') = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv (machine_state_rest_update f ms) ms' = equiv_hyp_state n cv ms ms'" + by (auto simp: equiv_hyp_state_def) + +lemma equiv_fpu_state_upds[simp]: + "\f. equiv_fpu_state cf ms (underlying_memory_update f ms') = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf (underlying_memory_update f ms) ms' = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf ms (device_state_update f ms') = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf (device_state_update f ms) ms' = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf ms (machine_state_rest_update f ms') = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf (machine_state_rest_update f ms) ms' = equiv_fpu_state cf ms ms'" + by (auto simp: equiv_fpu_state_def) + +lemma no_hyp_bind: + "\ no_hyp f; \rv. no_hyp (g rv) \ \ no_hyp (f >>= g)" + unfolding no_hyp_def + by (wpsimp, blast+) + +lemma no_fpu_bind: + "\ no_fpu f; \rv. no_fpu (g rv) \ \ no_fpu (f >>= g)" + unfolding no_fpu_def + by (wpsimp, blast+) + +lemma equiv_hyp_state_lift[wp]: + assumes "\P. f \\s. P (vcpu_state s)\" + shows "f \equiv_hyp_state n cv st\" + unfolding equiv_hyp_state_def + by (wp assms) + +lemma equiv_fpu_state_lift[wp]: + assumes "\P. f \\s. P (fpu_state s)\" + shows "f \equiv_fpu_state cf st\" + unfolding equiv_fpu_state_def + by (wp assms) + +lemma no_hyp_lift[wp]: + assumes "\P. f \\s. P (vcpu_state s)\" + shows "no_hyp f" + using assms by (simp add: no_hyp_def) + +lemma no_fpu_lift[wp]: + assumes "\P. f \\s. P (fpu_state s)\" + shows "no_fpu f" + using assms by (simp add: no_fpu_def) + end +arch_requalify_consts + no_hyp no_fpu + -global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 +global_interpretation InfoFlow_IF_2?: InfoFlow_IF_2 identical_hyp_state_updates identical_fpu_state_updates no_hyp no_fpu proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/AARCH64/ArchInterrupt_IF.thy b/proof/infoflow/AARCH64/ArchInterrupt_IF.thy index ae4a9dcb45..1862a1affd 100644 --- a/proof/infoflow/AARCH64/ArchInterrupt_IF.thy +++ b/proof/infoflow/AARCH64/ArchInterrupt_IF.thy @@ -8,39 +8,46 @@ theory ArchInterrupt_IF imports Interrupt_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Interrupt_IF_assms lemma arch_invoke_irq_handler_reads_respects[Interrupt_IF_assms, wp]: "reads_respects_f aag l (silc_inv aag st) (arch_invoke_irq_handler irq)" - apply (cases irq; wpsimp simp: plic_complete_claim_def) - apply (rule reads_respects_f[OF dmo_mol_reads_respects, where Q=\, simplified]) - apply wpsimp + apply (cases irq) + apply (wpsimp simp: deactivateInterrupt_def maskInterrupt_def) + apply (rule reads_respects_f[where P=\ and Q=\, simplified]) + apply (rule do_machine_op_reads_respects) + apply (simp add: equiv_valid_def2) + apply (rule modify_ev2) + apply (fastforce simp: equiv_for_def) + apply wpsimp+ done lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: "reads_respects aag (l :: 'a subject_label) (K (arch_authorised_irq_ctl_inv aag i)) (arch_invoke_irq_control i)" apply (cases i) - apply (simp add: setIRQTrigger_def) - apply (wp cap_insert_reads_respects set_irq_state_reads_respects dmo_mol_reads_respects | simp)+ + apply (simp add: setIRQTrigger_def) + apply (wp cap_insert_reads_respects set_irq_state_reads_respects dmo_mol_reads_respects | simp)+ + apply (clarsimp simp: arch_authorised_irq_ctl_inv_def) + apply (wpsimp wp: equiv_valid_guard_imp[OF cap_insert_reads_respects]) apply (clarsimp simp: arch_authorised_irq_ctl_inv_def) done lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" apply (induct ai) - apply (simp add: setIRQTrigger_def) - apply (wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs - cap_insert_globals_equiv'' dmo_mol_globals_equiv) + apply (simp add: setIRQTrigger_def) + apply (wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs + cap_insert_globals_equiv dmo_mol_globals_equiv)+ done lemma arch_invoke_irq_handler_globals_equiv[Interrupt_IF_assms, wp]: "arch_invoke_irq_handler irq \globals_equiv st\" - by (cases irq; wpsimp wp: dmo_no_mem_globals_equiv simp: plic_complete_claim_def) + by (cases irq; wpsimp wp: dmo_no_mem_globals_equiv simp: deactivateInterrupt_def) end diff --git a/proof/infoflow/AARCH64/ArchIpc_IF.thy b/proof/infoflow/AARCH64/ArchIpc_IF.thy index fe762a1192..8da6ab896d 100644 --- a/proof/infoflow/AARCH64/ArchIpc_IF.thy +++ b/proof/infoflow/AARCH64/ArchIpc_IF.thy @@ -8,7 +8,7 @@ theory ArchIpc_IF imports Ipc_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Ipc_IF_assms @@ -36,24 +36,26 @@ lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: apply (wp modify_wp) apply (clarsimp simp: equiv_but_for_labels_def) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) - apply (simp add: states_equiv_for_def) - apply (rule conjI) - apply (rule equiv_forI) - apply clarsimp - apply (drule_tac f=underlying_memory in equiv_forD,fastforce) - apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right - simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) - apply (rule equiv_forI) - apply clarsimp - apply (drule_tac f=device_state in equiv_forD,fastforce) - apply clarsimp - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) - apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) + apply (simp add: states_equiv_for_def) + apply (rule conjI) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=underlying_memory in equiv_forD,fastforce) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=device_state in equiv_forD,fastforce) + apply clarsimp + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply (fastforce simp: equiv_hyp_def equiv_for_def elim: states_equiv_forE) + apply (fastforce simp: equiv_fpu_def equiv_for_def cur_fpu_for_def elim: states_equiv_forE) apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) done @@ -202,9 +204,7 @@ lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) (do_machine_op (loadWord p))" apply (rule gen_asm_ev) - apply (rule use_spec_ev) - apply (rule spec_equiv_valid_hoist_guard) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) @@ -234,8 +234,15 @@ lemma handle_arch_fault_reply_reads_respects[Ipc_IF_assms, wp]: "reads_respects aag l (K (aag_can_read aag thread)) (handle_arch_fault_reply afault thread x y)" by (simp add: handle_arch_fault_reply_def, wp) +lemma arch_thread_get_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (arch_thread_get f t)" + unfolding arch_thread_get_def + apply (wpsimp) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE simp: get_tcb_def split: option.splits) + done + lemma arch_get_sanitise_register_info_reads_respects[Ipc_IF_assms, wp]: - "reads_respects aag l \ (arch_get_sanitise_register_info t)" + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (arch_get_sanitise_register_info t)" by wpsimp declare arch_get_sanitise_register_info_inv[Ipc_IF_assms] @@ -291,7 +298,7 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma copy_mrs_reads_respects[Ipc_IF_assms]: assumes domains_distinct[wp]: "pas_domains_distinct aag" @@ -322,7 +329,7 @@ lemma copy_mrs_reads_respects[Ipc_IF_assms]: apply (simp add: msg_align_bits word_bits_def) apply (simp add: word_size_def word_size_bits_def) apply (subst upto_enum_step_shift_red[where us=3, simplified]) - apply (simp add: msg_align_bits word_bits_def aag_can_read_or_affect_ipc_buffer_def )+ + apply (simp add: msg_align_bits word_bits_def aag_can_read_or_affect_ipc_buffer_def)+ apply (fastforce simp: image_def) done @@ -441,7 +448,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_guard_imp) apply (case_tac buf) - apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in ev_invisible[OF domains_distinct]) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in revrv_invisible[OF domains_distinct]) apply (clarsimp simp: labels_are_invisible_def) apply (rule modifies_at_mostI) apply (simp add: set_mrs_def) @@ -451,7 +458,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (rename_tac buf') apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) ` (ptr_range buf' msg_align_bits)" - in ev_invisible[OF domains_distinct]) + in revrv_invisible[OF domains_distinct]) apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] apply (rule modifies_at_mostI) diff --git a/proof/infoflow/AARCH64/ArchNoninterference.thy b/proof/infoflow/AARCH64/ArchNoninterference.thy index 2d5183e5ab..4fd3011b5b 100644 --- a/proof/infoflow/AARCH64/ArchNoninterference.thy +++ b/proof/infoflow/AARCH64/ArchNoninterference.thy @@ -8,7 +8,7 @@ theory ArchNoninterference imports Noninterference begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Noninterference_assms @@ -66,14 +66,14 @@ lemma do_user_op_if_partitionIntegrity[Noninterference_assms]: "\partitionIntegrity aag st and pas_refined aag and invs and is_subject aag \ cur_thread\ do_user_op_if tc uop \\_. partitionIntegrity aag st\" - apply (rule_tac Q'="\rv s. integrity (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) - (scheduler_affects_globals_frame st) st s \ - domain_fields_equiv st s \ idle_thread s = idle_thread st \ - globals_equiv_scheduler st s \ silc_dom_equiv aag st s" - in hoare_strengthen_post) - apply (wp hoare_vcg_conj_lift do_user_op_if_integrity do_user_op_if_globals_equiv_scheduler - hoare_vcg_all_lift domain_fields_equiv_lift[where Q="\" and R="\"] | simp)+ - apply (clarsimp simp: partitionIntegrity_def)+ + apply (rule_tac Q'="\rv s. integrity (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + (scheduler_affects_globals_frame st) st s \ + domain_fields_equiv st s \ idle_thread s = idle_thread st \ + globals_equiv_scheduler st s \ silc_dom_equiv aag st s" + in hoare_strengthen_post) + apply (wpsimp wp: do_user_op_if_globals_equiv_scheduler + do_user_op_if_integrity domain_fields_equiv_lift) + apply (auto simp: partitionIntegrity_def) done lemma arch_activate_idle_thread_reads_respects_g[Noninterference_assms, wp]: @@ -107,6 +107,114 @@ lemma integrity_asids_update_reference_state[Noninterference_assms]: \ integrity_asids aag {pasSubject aag} x a s (s\kheap := (kheap s)(t \ blah)\)" by (clarsimp simp: integrity_asids_def opt_map_def) +lemma partitionIntegrity_cur_vcpu_None: + "\ partitionIntegrity aag s s'; valid_objs s; valid_objs s'; + cur_vcpu_of s x = None; cur_vcpu_of s' x = None; vcpu_at x s \ + \ is_subject aag x \ kheap s x = kheap s' x" + apply (prop_tac "integrity_obj (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + False {pasSubject aag} (pasObjectAbs aag x) (kheap s x) (kheap s' x)") + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (prop_tac "integrity_hyp (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} x s s'") + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (rule disjCI2) + apply (drule tro_tro_alt) + apply (clarsimp simp: obj_at_def) + apply (erule integrity_obj_alt.cases; clarsimp) + apply (erule arch_integrity_obj_alt.cases; clarsimp) + apply (rename_tac vcpu vcpu') + apply (prop_tac "valid_vcpu vcpu s") + apply (erule valid_objsE, simp, fastforce simp: valid_obj_def) + apply (prop_tac "valid_vcpu vcpu' s'") + apply (erule valid_objsE, simp, fastforce simp: valid_obj_def) + apply (prop_tac "vcpus_of s x = Some vcpu") + apply (clarsimp simp: opt_map_def) + apply (prop_tac "vcpus_of s' x = Some vcpu'") + apply (clarsimp simp: opt_map_def) + apply (prop_tac "integrity_obj (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) False + {pasSubject aag} (pasObjectAbs aag x) (kheap s x) (kheap s' x)") + apply (thin_tac "kheap _ x = _")+ + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (erule integrity_objE; fastforce?) + apply (erule arch_integrity_obj_alt.cases; fastforce?) + apply clarsimp + apply (clarsimp simp: integrity_hyp_def vcpu_integrity_def vcpu_extra_lrs_def vcpu_of_state_def) + apply (case_tac vcpu; case_tac vcpu'; clarsimp) + apply (case_tac vcpu_vgic; case_tac vcpu_vgica; clarsimp) + apply (rule ext) + apply (drule_tac x=xa in fun_cong)+ + apply (auto split: if_splits) + done + +lemma partitionIntegrity_cur_vcpu_Some: + "\ invs s; pas_refined aag s; pas_cur_domain aag s; pas_domains_distinct aag; + cur_vcpu_in_cur_domain s; current_vcpu s = Some (vr,b) \ + \ is_subject aag vr" + apply (clarsimp simp: cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def split: option.splits) + defer + apply (rename_tac t) + apply (prop_tac "is_subject aag vr") + apply (prop_tac "\tcb. ko_at (TCB tcb) t s") + apply (prop_tac "valid_objs s") + apply fastforce + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_vcpu_def obj_at_def) + apply (prop_tac "is_subject aag t") + apply clarsimp + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + apply (prop_tac "pasDomainAbs aag (cur_domain s) = {pasSubject aag}") + apply (clarsimp simp: pas_domains_distinct_def) + apply (metis singletonD) + apply blast + apply clarsimp + apply (clarsimp simp: opt_map_def split: option.splits) + apply (prop_tac "sym_refs (state_hyp_refs_of s)") + apply fastforce + apply (drule_tac x=vr in sym_refsD[rotated]) + apply (simp add: state_hyp_refs_of_def) + apply (clarsimp simp: state_hyp_refs_of_def hyp_refs_of_def obj_at_def tcb_vcpu_refs_def split: option.splits) + apply (erule associated_vcpu_is_subject) + apply (simp add: get_tcb_Some_ko_at obj_at_def) + apply simp+ + apply (prop_tac "cur_vcpu s") + apply (prop_tac "valid_arch_state s") + apply fastforce + apply (clarsimp simp: valid_arch_state_def) + apply (clarsimp simp: cur_vcpu_def opt_map_def opt_pred_def) + done + +lemma cur_vcpu_of_Some: + "cur_vcpu_of s vr = Some b \ current_vcpu s = Some (vr,b)" + by (auto simp: cur_vcpu_of_def split: option.splits) + +lemma partitionIntegrity_subjectAffects_vcpu: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (ArchObj (VCPU vcpu))" + and kh_neq: "kheap s x \ kheap s' x" + and "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_vcpu_in_cur_domain s" "cur_vcpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (rule ssubst[where s="pasSubject aag", OF _ affects_lrefl]) + apply (case_tac "cur_vcpu_of s x = None \ cur_vcpu_of s' x = None"; clarsimp) + apply (drule (1) partitionIntegrity_cur_vcpu_None[OF par_inte, rotated 2]) + apply (simp_all add: assms obj_at_def invs_valid_objs)[3] + apply (fastforce simp: kh_neq) + apply (elim disjE; clarsimp; rule partitionIntegrity_cur_vcpu_Some + ; simp add: assms cur_vcpu_of_Some pas_wellformed_noninterference_domains_distinct) + done + lemma inte_obj_arch: assumes inte_obj: "(integrity_obj_atomic aag activate subjects l)\<^sup>*\<^sup>* ko ko'" assumes "ko = Some (ArchObj ao)" @@ -131,7 +239,7 @@ next using False inte_obj assms by (auto elim!: rtranclp_induct integrity_obj_atomic.cases) then show ?case using step.hyps - by (fastforce intro: troa_arch arch_troa_asidpool_clear integrity_obj_atomic.intros + by (fastforce intro: arch_integrity_obj_atomic.intros integrity_obj_atomic.intros elim!: integrity_obj_atomic.cases arch_integrity_obj_atomic.cases) qed then show ?thesis @@ -140,20 +248,20 @@ qed lemma asid_pool_into_aag: "\ pool_for_asid asid s = Some p; kheap s p = Some (ArchObj (ASIDPool pool)); - pool r = Some p'; pas_refined aag s \ + pool r = Some entry; ap_vspace entry = p'; pas_refined aag s \ \ abs_has_auth_to aag Control p p'" apply (rule pas_refined_mem [rotated], assumption) apply (rule sta_vref) apply (rule state_vrefsD) apply (erule pool_for_asid_vs_lookupD) - apply (fastforce simp: aobjs_of_Some) + apply (fastforce simp: opt_map_def) apply fastforce apply (fastforce simp: vs_refs_aux_def graph_of_def image_iff) done lemma owns_mapping_owns_asidpool: "\ pool_for_asid asid s = Some p; kheap s p = Some (ArchObj (ASIDPool pool)); - pool r = Some p'; pas_refined aag s; is_subject aag p'; + pool r = Some entry; ap_vspace entry = p'; pas_refined aag s; is_subject aag p'; pas_wellformed (aag\pasSubject := (pasObjectAbs aag p)\) \ \ is_subject aag p" apply (frule asid_pool_into_aag) @@ -163,34 +271,40 @@ lemma owns_mapping_owns_asidpool: apply simp done -lemma partitionIntegrity_subjectAffects_aobj': +lemma partitionIntegrity_subjectAffects_asid_pool': "\ pool_for_asid asid s = Some x; kheap s x = Some (ArchObj ao); ao \ ao'; - pas_refined aag s; silc_inv aag st s; pas_wellformed_noninterference aag; + pas_refined aag s; silc_inv aag st s; pas_wellformed_noninterference aag; valid_arch_state s; arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) - {pasSubject aag} (pasObjectAbs aag x) ao ao' \ + {pasSubject aag} (pasObjectAbs aag x) ao ao' \ \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" unfolding arch_integrity_obj_atomic.simps asid_pool_integrity_def + apply (elim disjE) + apply clarsimp + apply (rule ccontr) + apply (drule fun_noteqD) + apply (erule exE, rename_tac r) + apply (drule_tac x=r in spec) + apply (clarsimp dest!: not_sym[where t=None]) + apply (subgoal_tac "is_subject aag x", force intro: affects_lrefl) + apply (frule (1) aag_Control_into_owns) + apply (frule (2) asid_pool_into_aag) + apply simp + apply simp + apply (frule (1) pas_wellformed_noninterference_control_to_eq) + apply (fastforce elim!: silc_inv_cnode_onlyE obj_atE simp: is_cap_table_def) + apply clarsimp apply clarsimp - apply (rule ccontr) - apply (drule fun_noteqD) - apply (erule exE, rename_tac r) - apply (drule_tac x=r in spec) - apply (clarsimp dest!: not_sym[where t=None]) - apply (subgoal_tac "is_subject aag x", force intro: affects_lrefl) - apply (frule (1) aag_Control_into_owns) - apply (frule (3) asid_pool_into_aag) - apply simp - apply (frule (1) pas_wellformed_noninterference_control_to_eq) - apply (fastforce elim!: silc_inv_cnode_onlyE obj_atE simp: is_cap_table_def) - apply clarsimp + apply (drule (1) pool_for_asid_ap_at) + apply (clarsimp simp: obj_at_def) done -lemma partitionIntegrity_subjectAffects_aobj[Noninterference_assms]: +lemma partitionIntegrity_subjectAffects_asid_pool: assumes par_inte: "partitionIntegrity aag s s'" - and "kheap s x = Some (ArchObj ao)" + and "kheap s x = Some (ArchObj (ASIDPool pool))" "kheap s x \ kheap s' x" "silc_inv aag st s" "pas_refined aag s" + "valid_arch_state s" "pas_wellformed_noninterference aag" notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, THEN spec[where x=x], simplified integrity_obj_def, simplified] @@ -205,7 +319,7 @@ next by (auto elim: integrity_obj_atomic.cases) have arch_tro: "arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) - {pasSubject aag} (pasObjectAbs aag x) ao ao'" + {pasSubject aag} (pasObjectAbs aag x) (ASIDPool pool) ao'" using assms False ao' inte_obj_arch[OF inte_obj] by (auto elim: integrity_obj_atomic.cases) obtain asid where asid: "pool_for_asid asid s = Some x" @@ -215,9 +329,194 @@ next simp: integrity_asids_def aobjs_of_Some opt_map_def pool_for_asid_def)+ show ?thesis using assms ao' asid arch_tro - by (fastforce dest: partitionIntegrity_subjectAffects_aobj') + by (fastforce dest: partitionIntegrity_subjectAffects_asid_pool') +qed + +lemma partitionIntegrity_subjectAffects_aobj: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (ArchObj ao)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_vcpu_in_cur_domain s" "cur_vcpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" +proof (cases "pasObjectAbs aag x = pasSubject aag") + case True + then show ?thesis by (simp add: subjectAffects.intros(1)) +next + case False + obtain ao' where ao': "kheap s' x = Some (ArchObj ao')" + using assms False inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + have arch_tro: + "arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} (pasObjectAbs aag x) ao ao'" + using assms False ao' inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + show ?thesis + apply (case_tac ao) + apply (insert partitionIntegrity_subjectAffects_asid_pool[of aag s s' x _ st]) + using assms apply (simp add: invs_arch_state) + using arch_tro apply (fastforce elim: arch_integrity_obj_atomic.cases) + using arch_tro apply (fastforce elim: arch_integrity_obj_atomic.cases) + apply (insert partitionIntegrity_subjectAffects_vcpu[of aag s s' x _ st]) + using assms apply (simp add: invs_arch_state) + done qed +declare cur_vcpu_for_None[simp] + +lemma cur_vcpu_of_None[simp]: + "cur_vcpu_of_2 None vst = None" + by (clarsimp simp: cur_vcpu_of_def) + +lemma partitionIntegrity_subjectAffects_numlistregs: + "partitionIntegrity aag s s' \ equiv_for (\x. pasObjectAbs aag x = da) (K \ numlistregs) s s'" + by (clarsimp simp: partitionIntegrity_def integrity_subjects_def integrity_hyp_def equiv_for_def) + +lemma partitionIntegrity_subjectAffects_cur_vcpu_of: + "\ invs s; invs s'; + cur_vcpu_in_cur_domain s; cur_vcpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_for (\x. pasObjectAbs aag x = a) cur_vcpu_of s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s' = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply clarsimp + apply (erule swap) + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def split: option.splits) + done + +lemma partitionIntegrity_subjectAffects_hw_vcpu: + "\ invs s; invs s'; + cur_vcpu_in_cur_domain s; cur_vcpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_for (\x. pasObjectAbs aag x = a) hw_vcpu_of s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s' = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply clarsimp + apply (clarsimp simp: equiv_for_def) + apply (clarsimp simp: cur_vcpu_of_def cur_vcpu_for_def split: option.splits if_splits) + done + +lemma partitionIntegrity_subjectAffects_hyp: + "\ partitionIntegrity aag s s'; + invs s; invs s'; + cur_vcpu_in_cur_domain s; cur_vcpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_hyp (\x. pasObjectAbs aag x = a) s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + unfolding equiv_hyp_def + using partitionIntegrity_subjectAffects_numlistregs + partitionIntegrity_subjectAffects_cur_vcpu_of + partitionIntegrity_subjectAffects_hw_vcpu + by (metis (mono_tags)) + +lemma cur_fpu_is_subject: + "\ invs s; pas_refined aag s; pas_cur_domain aag s; pas_domains_distinct aag; + cur_fpu_in_cur_domain s; current_fpu s = Some t \ + \ is_subject aag t" + apply (clarsimp simp: cur_fpu_in_cur_domain_def split: option.splits) + apply (frule current_fpu_owner_Some_tcb_at, fastforce) + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + apply (prop_tac "pasDomainAbs aag (cur_domain s) = {pasSubject aag}") + apply (clarsimp simp: pas_domains_distinct_def) + apply (metis singletonD) + apply blast + done + +lemma partitionIntegrity_subjectAffects_fpu: + "\ partitionIntegrity aag s s'; + invs s; invs s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_fpu (\x. pasObjectAbs aag x = a) s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + unfolding equiv_fpu_def + apply (clarsimp simp: equiv_for_def) + apply (case_tac "is_arch_cur_fpu x s") + apply (frule (4) cur_fpu_is_subject[of s]) + apply (simp add: is_arch_cur_fpu_def) + apply (clarsimp simp: affects_lrefl) + apply (case_tac "is_arch_cur_fpu x s'") + apply (frule (4) cur_fpu_is_subject[of s']) + apply (simp add: is_arch_cur_fpu_def) + apply (clarsimp simp: affects_lrefl) + apply (clarsimp simp: hw_fpu_def) + done + +lemma partitionIntegrity_subjectAffects_tcb_fpu': + "\ partitionIntegrity aag s s'; valid_cur_fpu s; valid_cur_fpu s'; + kheap s x = Some (TCB tcb); kheap s' x = Some (TCB tcb'); + tcb' = tcb\tcb_arch := new_arch\; + arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb); + tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb); + current_fpu s \ Some x; current_fpu s' \ Some x \ + \ is_subject aag x \ kheap s x = kheap s' x" + apply clarsimp + apply (erule_tac P="tcb = tcb\tcb_arch := new_arch\" in swap) + apply (prop_tac "integrity_fpu (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} x s s'") + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (clarsimp simp: integrity_fpu_def) + apply (clarsimp simp: fpu_of_state_def) + apply (clarsimp simp: valid_cur_fpu_def) + apply (erule_tac x=x in allE)+ + apply (clarsimp simp: is_tcb_cur_fpu_def obj_at_def) + apply (subgoal_tac "tcb_arch tcb = new_arch") + apply (case_tac tcb; clarsimp) + apply (subgoal_tac "tcb_context (tcb_arch tcb) = tcb_context new_arch") + apply (case_tac "tcb_arch tcb"; case_tac new_arch; clarsimp simp: tcb_vcpu_refs_def split: option.splits) + apply (case_tac "tcb_context (tcb_arch tcb)"; case_tac "tcb_context new_arch"; clarsimp simp: arch_tcb_get_registers_def) + done + +lemma partitionIntegrity_subjectAffects_tcb_fpu: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (TCB tcb)" + "kheap s' x = Some (TCB tcb')" + "tcb' = tcb\tcb_arch := new_arch\" + "arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb)" + "tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (rule ssubst[where s="pasSubject aag", OF _ affects_lrefl]) + apply (case_tac "current_fpu s \ Some x \ current_fpu s' \ Some x"; clarsimp) + using assms apply (fastforce dest!: partitionIntegrity_subjectAffects_tcb_fpu'[OF par_inte, rotated 7]) + apply (elim disjE; rule cur_fpu_is_subject; simp add: assms pas_wellformed_noninterference_domains_distinct) + done + lemma partitionIntegrity_subjectAffects_asid[Noninterference_assms]: "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; valid_arch_state s; valid_arch_state s'; pas_wellformed_noninterference aag; @@ -258,7 +557,7 @@ lemma partitionIntegrity_subjectAffects_asid[Noninterference_assms]: apply (drule owns_mapping_owns_asidpool[rotated]) apply ((simp | blast intro: pas_refined_Control[THEN sym] | fastforce simp: pool_for_asid_def - intro: pas_wellformed_pasSubject_update[simplified])+)[5] + intro: pas_wellformed_pasSubject_update[simplified])+)[6] apply (drule_tac t="pasSubject aag" in sym)+ apply simp apply (rule sata_asidpool) @@ -282,31 +581,54 @@ lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: apply (rule ev_modify) apply (rule conjI) apply (fastforce simp: reads_equiv_g_def globals_equiv_def reads_equiv_def2 states_equiv_for_def - equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def upto.simps) + equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def + upto.simps equiv_hyp_def equiv_fpu_def cur_fpu_for_def) apply (rule affects_equiv_machine_state_update, assumption) apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def upto.simps) + apply (clarsimp simp: identical_hyp_state_updates_def identical_updates_rv_def) + apply (clarsimp simp: identical_fpu_state_updates_def identical_updates_rv_def cur_fpu_for_def) apply (simp add: equiv_valid_def2 equiv_valid_2_def) done +declare set_vm_root_states_equiv_for[wp] + lemma set_vm_root_reads_respects: "reads_respects aag l \ (set_vm_root tcb)" by (rule reads_respects_unobservable_unit_return) wp+ lemmas set_vm_root_reads_respects_g[wp] = reads_respects_g[OF set_vm_root_reads_respects, - OF doesnt_touch_globalsI[where P="\"], - simplified, - OF set_vm_root_globals_equiv] + OF doesnt_touch_globalsI[where P="valid_global_arch_objs"], + simplified, OF set_vm_root_globals_equiv] + +lemmas lazy_fpu_restore_reads_respects_g[wp] = + reads_respects_g[OF lazy_fpu_restore_reads_respects, + OF doesnt_touch_globalsI[where P=invs], + simplified, OF lazy_fpu_restore_globals_equiv] + +lemmas vcpu_switch_reads_respects_g[wp] = + reads_respects_g[OF vcpu_switch_reads_respects, + OF doesnt_touch_globalsI[where P=valid_arch_state], + simplified, OF vcpu_switch_globals_equiv] + +crunch vcpu_switch + for global_pt[wp]: "\s. P (global_pt s)" + (wp: valid_global_arch_objs_lift) + +crunch vcpu_switch + for valid_global_arch_objs[wp]: "valid_global_arch_objs" + (wp: valid_global_arch_objs_lift) lemma arch_switch_to_thread_reads_respects_g'[Noninterference_assms]: "equiv_valid (reads_equiv_g aag) (affects_equiv aag l) (\s s'. affects_equiv aag l s s' \ arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (\s. is_subject aag t) + (\s. invs s \ is_subject aag t) (arch_switch_to_thread t)" apply (simp add: arch_switch_to_thread_def) - apply (rule equiv_valid_guard_imp) - by (wp bind_ev_general thread_get_reads_respects_g | simp)+ + apply (wp bind_ev_general thread_get_reads_respects_g) + apply (auto intro: sym_refs_VCPU_hyp_live simp: reads_equiv_g_def) + done (* consider rewriting the return-value assumption using equiv_valid_rv_inv *) lemma ev2_invisible'[Noninterference_assms]: @@ -340,11 +662,23 @@ lemma ev2_invisible'[Noninterference_assms]: affects_equiv_sym globals_equiv_trans globals_equiv_sym) done +lemmas dmo_mol_reads_respects_g[wp] = + reads_respects_g[OF dmo_mol_reads_respects, + OF doesnt_touch_globalsI[where P="\"], + simplified, + OF dmo_mol_globals_equiv] + +lemma set_global_user_vspace_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (set_global_user_vspace)" + unfolding set_global_user_vspace_def setVSpaceRoot_def + apply wpsimp + apply (clarsimp simp: reads_equiv_g_def globals_equiv_def) + done + lemma arch_switch_to_idle_thread_reads_respects_g[Noninterference_assms, wp]: - "reads_respects_g aag l \ (arch_switch_to_idle_thread)" + "reads_respects_g aag l valid_arch_state (arch_switch_to_idle_thread)" apply (simp add: arch_switch_to_idle_thread_def) apply wp - apply (clarsimp simp: reads_equiv_g_def globals_equiv_idle_thread_ptr) done lemma arch_globals_equiv_threads_eq[Noninterference_assms]: @@ -364,7 +698,7 @@ lemma getActiveIRQ_ret_no_dmo[Noninterference_assms, wp]: apply (rule hoare_pre) apply (insert irq_oracle_max_irq) apply (wp dmo_getActiveIRQ_irq_masks) - apply clarsimp + apply (clarsimp simp: maxIRQ_def) done (*FIXME: Move to scheduler_if*) @@ -378,7 +712,7 @@ lemma dmo_getActive_IRQ_reads_respect_scheduler[Noninterference_assms]: apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def scheduler_affects_equiv_def arch_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def - scheduler_globals_frame_equiv_def silc_dom_equiv_def idle_equiv_def) + scheduler_globals_frame_equiv_def silc_dom_equiv_def idle_equiv_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def) apply wp apply (rule_tac P="\s. irq_masks_of_state st = irq_masks_of_state s" in gets_ev') apply wp @@ -386,31 +720,93 @@ lemma dmo_getActive_IRQ_reads_respect_scheduler[Noninterference_assms]: apply (simp add: scheduler_equiv_def) done -lemma getActiveIRQ_no_non_kernel_IRQs[Noninterference_assms]: - "getActiveIRQ True = getActiveIRQ False" - by (clarsimp simp: getActiveIRQ_def non_kernel_IRQs_def) +lemma integrity_hyp_update_reference_state[Noninterference_assms]: + "is_subject aag t + \ integrity_hyp aag {pasSubject aag} x s (s\kheap := (kheap s)(t \ blah)\)" + by (auto simp: integrity_hyp_def vcpu_integrity_def vcpu_of_state_def opt_map_def) + +lemma integrity_fpu_update_reference_state[Noninterference_assms]: + "is_subject aag t + \ integrity_fpu aag {pasSubject aag} x s (s\kheap := (kheap s)(t \ blah)\)" + by (auto simp: integrity_fpu_def fpu_of_state_def) + +definition irq_at' :: "bool \ nat \ (irq \ bool) \ irq option" where + "irq_at' in_kernel pos masks \ + let i = irq_oracle pos in (if masks i \ in_kernel \ i \ non_kernel_IRQs then None else Some i)" + +lemma dmo_getActiveIRQ_wp': + "\\s. P (irq_at' in_kernel (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at'_def split: if_splits) + done + +lemma getActiveIRQ_ev2[Noninterference_assms]: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid, rule dmo_getActiveIRQ_wp')+ + apply (intro conjI) + apply (clarsimp simp: scheduler_equiv_def irq_at'_def Let_def) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI impI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + done + +crunch arch_prepare_next_domain + for work_units_completed[wp]: "\s. P (work_units_completed s)" + +lemma arch_prepare_next_domain_reads_respects: + "reads_respects aag l invs arch_prepare_next_domain" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_from_labels) + apply (rule arch_prepare_next_domain_states_equiv_valid) + apply wpsimp+ + done -lemma valid_cur_hyp_triv[Noninterference_assms]: - "valid_cur_hyp s" - by (simp add: valid_cur_hyp_def) +lemma arch_prepare_next_domain_reads_respects_g: + "reads_respects_g aag l invs arch_prepare_next_domain" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_g[OF arch_prepare_next_domain_reads_respects doesnt_touch_globalsI]) + apply wpsimp + apply assumption + apply clarsimp + done -lemma arch_tcb_get_registers_equality[Noninterference_assms]: - "arch_tcb_get_registers (tcb_arch tcb) = arch_tcb_get_registers (tcb_arch tcb') - \ tcb_arch tcb = tcb_arch tcb'" - by (auto simp: arch_tcb_get_registers_def intro: arch_tcb.equality user_context.expand) +lemmas [Noninterference_assms] = + arch_prepare_next_domain_reads_respects_g + partitionIntegrity_subjectAffects_aobj[folded cur_hyp_in_cur_domain_def] + partitionIntegrity_subjectAffects_hyp[folded cur_hyp_in_cur_domain_def] + partitionIntegrity_subjectAffects_fpu + partitionIntegrity_subjectAffects_tcb_fpu end -requalify_consts AARCH64.arch_globals_equiv_strengthener -requalify_facts AARCH64.arch_globals_equiv_strengthener_thread_independent +arch_requalify_consts arch_globals_equiv_strengthener +arch_requalify_facts arch_globals_equiv_strengthener_thread_independent global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv_strengthener proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\)?) + by (unfold_locales; (fact Noninterference_assms)?) qed diff --git a/proof/infoflow/AARCH64/ArchPasUpdates.thy b/proof/infoflow/AARCH64/ArchPasUpdates.thy index b4d143b856..cafef0519e 100644 --- a/proof/infoflow/AARCH64/ArchPasUpdates.thy +++ b/proof/infoflow/AARCH64/ArchPasUpdates.thy @@ -12,38 +12,6 @@ context Arch begin named_theorems PasUpdates_assms -crunch arch_post_cap_deletion, arch_finalise_cap, prepare_thread_delete - for domain_fields[PasUpdates_assms, wp]: "domain_fields P" - ( wp: syscall_valid crunch_wps rec_del_preservation cap_revoke_preservation modify_wp - simp: crunch_simps check_cap_at_def filterM_mapM unless_def - ignore: without_preemption filterM rec_del check_cap_at cap_revoke - ignore_del: create_cap_ext cap_insert_ext cap_move_ext - empty_slot_ext cap_swap_ext set_thread_state_act tcb_sched_action reschedule_required) - -end - - -global_interpretation PasUpdates_1?: PasUpdates_1 -proof goal_cases - interpret Arch . - case 1 show ?case - by (unfold_locales; (fact PasUpdates_assms)?) -qed - - -context Arch begin - -crunch arch_perform_invocation, arch_post_modify_registers, init_arch_objects, - arch_invoke_irq_control, arch_invoke_irq_handler, handle_arch_fault_reply - for domain_fields[PasUpdates_assms, wp]: "domain_fields P" - (wp: syscall_valid crunch_wps mapME_x_inv_wp - simp: crunch_simps check_cap_at_def detype_def mapM_x_defsym - ignore: check_cap_at syscall - ignore_del: set_domain set_priority possible_switch_to - rule: transfer_caps_loop_pres) - -declare init_arch_objects_inv[PasUpdates_assms] - lemma state_asids_to_policy_aux_pasSubject_update: "state_asids_to_policy_aux (aag\pasSubject := x\) caps asid vrefs = state_asids_to_policy_aux aag caps asid vrefs" @@ -107,13 +75,10 @@ lemma state_asids_to_policy_pasMayEditReadyQueues_update[PasUpdates_assms]: state_asids_to_policy aag s" by (simp add: state_asids_to_policy_aux_pasMayEditReadyQueues_update) -declare arch_post_set_flags_inv[PasUpdates_assms] -declare arch_prepare_set_domain_inv[PasUpdates_assms] - end -global_interpretation PasUpdates_2?: PasUpdates_2 +global_interpretation PasUpdates_1?: PasUpdates_1 proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/AARCH64/ArchRetype_IF.thy b/proof/infoflow/AARCH64/ArchRetype_IF.thy index 7c11b27129..0b9248747f 100644 --- a/proof/infoflow/AARCH64/ArchRetype_IF.thy +++ b/proof/infoflow/AARCH64/ArchRetype_IF.thy @@ -8,17 +8,45 @@ theory ArchRetype_IF imports Retype_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Retype_IF_assms +crunch clearMemory, freeMemory + for vcpu_state[wp]: "\ms. P (vcpu_state ms)" + and fpu_state[wp]: "\ms. P (fpu_state ms)" + (wp: mapM_x_wp_inv ignore_del: storeWord clearMemory) + +lemma machine_op_lift_no_hyp[Retype_IF_assms]: + "no_hyp (machine_op_lift mop)" + by wp + +lemma machine_op_lift_no_fpu[Retype_IF_assms]: + "no_fpu (machine_op_lift mop)" + by wp + +lemma clearMemory_no_hyp[Retype_IF_assms]: + "no_hyp (clearMemory ptr bits)" + by wp + +lemma freeMemory_no_hyp[Retype_IF_assms]: + "no_hyp (freeMemory ptr bits)" + by wp + +lemma clearMemory_no_fpu[Retype_IF_assms]: + "no_fpu (clearMemory ptr bits)" + by wp + +lemma freeMemory_no_fpu[Retype_IF_assms]: + "no_fpu (freeMemory ptr bits)" + by wp + lemma do_ipc_transfer_valid_arch_no_caps[wp]: "do_ipc_transfer s ep bg grt r \valid_arch_state\" by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at) lemma create_cap_valid_arch_state_no_caps[wp]: - "\valid_arch_state \ create_cap tp sz p dev ref - \\rv. valid_arch_state\" + "create_cap tp sz p dev ref \valid_arch_state\" by (wp valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at) lemma modify_underlying_memory_update_0_ev: @@ -109,15 +137,15 @@ lemma get_pt_revg: done lemma store_pte_reads_respects: - "reads_respects aag l (K (is_subject aag (ptr && ~~ mask pt_bits))) (store_pte ptr pte)" + "reads_respects aag l (K (is_subject aag (table_base pt_t ptr))) (store_pte pt_t ptr pte)" unfolding store_pte_def fun_app_def apply (wp set_pt_reads_respects get_pt_rev) apply (clarsimp) done lemma store_pte_globals_equiv: - "\globals_equiv s and (\ s. ptr && ~~ mask pt_bits \ arm_us_global_vspace (arch_state s))\ - store_pte ptr pde + "\globals_equiv s and (\ s. table_base pt_t ptr \ arm_us_global_vspace (arch_state s))\ + store_pte pt_t ptr pde \\_. globals_equiv s\" unfolding store_pte_def apply (wp set_pt_globals_equiv) @@ -125,14 +153,14 @@ lemma store_pte_globals_equiv: done lemma store_pte_reads_respects_g: - "reads_respects_g aag l (\s. is_subject aag (ptr && ~~ mask pt_bits) \ - ptr && ~~ mask pt_bits \ arm_us_global_vspace (arch_state s)) - (store_pte ptr pte)" + "reads_respects_g aag l (\s. is_subject aag (table_base pt_t ptr) \ + table_base pt_t ptr \ arm_us_global_vspace (arch_state s)) + (store_pte pt_t ptr pte)" by (fastforce intro: equiv_valid_guard_imp[OF reads_respects_g] doesnt_touch_globalsI store_pte_reads_respects store_pte_globals_equiv) lemma get_pte_rev: - "reads_equiv_valid_inv A aag (K (is_subject aag (ptr && ~~ mask pt_bits))) (get_pte ptr)" + "reads_equiv_valid_inv A aag (K (is_subject aag (table_base pt_t ptr))) (get_pte pt_t ptr)" unfolding gets_map_def fun_app_def apply (subst gets_apply) apply (wpsimp wp: gets_apply_ev) @@ -140,8 +168,8 @@ lemma get_pte_rev: done lemma get_pte_revg: - "reads_equiv_valid_g_inv A aag (\s. (ptr && ~~ mask pt_bits) = arm_us_global_vspace (arch_state s)) - (get_pte ptr)" + "reads_equiv_valid_g_inv A aag (\s. (table_base pt_t ptr) = arm_us_global_vspace (arch_state s)) + (get_pte pt_t ptr)" apply (unfold gets_map_def) apply (subst gets_apply) apply (wp gets_apply_ev') @@ -153,36 +181,6 @@ lemma get_pte_revg: apply (auto simp: reads_equiv_g_def globals_equiv_def opt_map_def ptes_of_def obind_def) done -lemma copy_global_mappings_reads_respects_g: - "reads_respects_g aag l - ((\s. x \ arm_us_global_vspace (arch_state s)) and pspace_aligned and valid_global_arch_objs - and K (is_aligned x pt_bits \ is_subject aag x)) - (copy_global_mappings x)" - unfolding copy_global_mappings_def - apply (rule gen_asm_ev) - apply clarsimp - apply (rule bind_ev_pre) - prefer 3 - apply (rule_tac P'="\s. is_subject aag x \ x \ arm_us_global_vspace (arch_state s) \ - pspace_aligned s \ valid_global_arch_objs s" in hoare_weaken_pre) - apply (rule gets_sp) - apply (assumption) - apply (wp mapM_x_ev store_pte_reads_respects_g get_pte_revg) - apply (simp only: pt_index_def) - apply (subst table_base_offset_id) - apply clarsimp - apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def - table_size_def ptTranslationBits_def mask_def) - apply (word_bitwise, fastforce) - apply (erule ssubst[OF table_base_offset_id]) - apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def - table_size_def ptTranslationBits_def mask_def) - apply (word_bitwise, fastforce) - apply clarsimp - apply (wpsimp wp: get_pte_inv store_pte_aligned)+ - apply (fastforce dest: reads_equiv_gD simp: globals_equiv_def) - done - lemma dmo_no_mem_globals_equiv: "\ \P. f \\ms. P (underlying_memory ms)\; \P. f \\ms. P (device_state ms)\; @@ -193,7 +191,6 @@ lemma dmo_no_mem_globals_equiv: apply atomize apply (erule_tac x="(=) (underlying_memory (machine_state sa))" in allE) apply (erule_tac x="(=) (device_state (machine_state sa))" in allE) - apply (erule_tac x="(=) (exclusive_state (machine_state sa))" in allE) apply (fastforce simp: valid_def globals_equiv_def idle_equiv_def) done @@ -237,26 +234,10 @@ lemma dmo_freeMemory_globals_equiv[Retype_IF_assms]: lemma init_arch_objects_reads_respects_g: "reads_respects_g aag l \ (init_arch_objects new_type dev ptr num_objects obj_sz refs)" - unfolding init_arch_objects_def by wp - -lemma copy_global_mappings_globals_equiv: - "\globals_equiv s and (\s. x \ arm_us_global_vspace (arch_state s) \ is_aligned x pt_bits)\ - copy_global_mappings x - \\_. globals_equiv s\" - unfolding copy_global_mappings_def including classic_wp_pre - apply simp - apply wp - apply (rule_tac Q'="\_. globals_equiv s and (\s. x \ arm_us_global_vspace (arch_state s) \ - is_aligned x pt_bits)" in hoare_strengthen_post) - apply (wp mapM_x_wp[OF _ subset_refl] store_pte_globals_equiv) - apply (simp only: pt_index_def) - apply (subst table_base_offset_id) - apply clarsimp - apply (clarsimp simp: pte_bits_def word_size_bits_def pt_bits_def - table_size_def ptTranslationBits_def mask_def) - apply (word_bitwise, fastforce) - apply (simp_all) - done + unfolding init_arch_objects_def cleanCacheRange_RAM_def cleanCacheRange_PoU_def + by (wpsimp wp: reads_respects_g do_machine_op_reads_respects + equiv_valid_guard_imp[OF machine_op_lift_ev] + doesnt_touch_globalsI mapM_x_ev mapM_x_wp_inv) (* FIXME: cleanup this proof *) lemma retype_region_globals_equiv[Retype_IF_assms]: @@ -356,7 +337,7 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma detype_globals_equiv: "\globals_equiv st and ((\s. arm_us_global_vspace (arch_state s) \ S) and (\s. idle_thread s \ S))\ @@ -423,7 +404,6 @@ lemma reset_untyped_cap_reads_respects_g: apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def invs_valid_global_objs) apply (simp add: aligned_add_aligned is_aligned_shiftl) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (rule hoare_pre) apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] @@ -459,20 +439,13 @@ lemma reset_untyped_cap_reads_respects_g: apply (drule ex_cte_cap_protects[OF _ _ _ _ order_refl], erule caps_of_state_cteD) apply (clarsimp simp: descendants_range_def2 empty_descendants_range_in) apply clarsimp+ - apply (fastforce dest: invs_valid_global_arch_objs valid_global_arch_objs_global_ptD + apply (fastforce dest: invs_valid_global_arch_objs simp: untyped_min_bits_def ptr_range_def) done -lemma retype_region_ret_pt_aligned: - "\K (range_cover ptr sz (obj_bits_api tp us) num_objects)\ - retype_region ptr num_objects us tp dev - \\rv. K (\ref \ set rv. tp = ArchObject PageTableObj \ is_aligned ref pt_bits)\" - apply (rule hoare_strengthen_post) - apply (rule hoare_weaken_pre) - apply (rule retype_region_aligned_for_init) - apply simp - apply (clarsimp simp: obj_bits_api_def default_arch_object_def pt_bits_def pageBits_def) - done +crunch init_arch_objects + for valid_global_objs[wp]: valid_global_objs + (wp: crunch_wps) lemma post_retype_invs_valid_global_objsI: "post_retype_invs ty rv s \ valid_global_objs s" @@ -506,7 +479,6 @@ lemma invoke_untyped_reads_respects_g_wcap[Retype_IF_assms]: for sz in hoare_strengthen_post) apply (wp retype_region_ret_is_subject[where sz=sz, simplified] retype_region_global_refs_disjoint[where sz=sz] - retype_region_ret_pt_aligned[where sz=sz] retype_region_aligned_for_init[where sz=sz] retype_region_post_retype_invs_spec[where sz=sz]) apply clarsimp @@ -583,11 +555,14 @@ lemma invoke_untyped_reads_respects_g_wcap[Retype_IF_assms]: apply (clarsimp simp: field_simps mask_out_sub_mask shiftl_t2n) apply blast apply (clarsimp simp: cte_wp_at_caps_of_state authorised_untyped_inv_def) + apply (rule conjI; clarsimp) apply (strengthen refl) apply (frule(1) cap_auth_caps_of_state) apply (simp add: aag_cap_auth_def untyped_range_def aag_has_Control_iff_owns ptr_range_def[symmetric]) - apply (erule disjE, simp_all)[1] + apply (frule(1) cap_auth_caps_of_state) + apply (simp add: aag_cap_auth_def untyped_range_def + aag_has_Control_iff_owns ptr_range_def[symmetric]) done lemma delete_objects_globals_equiv[wp]: @@ -620,7 +595,6 @@ lemma reset_untyped_cap_globals_equiv: preemption_point_inv | simp add: if_apply_def2)+ apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] cap_aligned_def bits_of_def free_index_of_def) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (strengthen invs_valid_global_objs invs_arch_state) apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def @@ -630,10 +604,14 @@ lemma reset_untyped_cap_globals_equiv: apply (frule valid_global_refsD2, clarsimp+) apply (clarsimp simp: ptr_range_def[symmetric] global_refs_def) apply (strengthen empty_descendants_range_in) - apply (cases slot) - apply (fastforce dest: valid_global_arch_objs_global_ptD[OF invs_valid_global_arch_objs]) + apply (cases slot, fastforce) done +lemma init_arch_objects_globals_equiv[wp]: + "init_arch_objects tp dev ptr n us refs \globals_equiv st\" + unfolding init_arch_objects_def cleanCacheRange_RAM_def cleanCacheRange_PoU_def + by (wpsimp wp: mapM_x_wp_inv) + lemma invoke_untyped_globals_equiv: notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost @@ -667,10 +645,10 @@ proof goal_cases qed -requalify_facts - AARCH64.reset_untyped_cap_reads_respects_g - AARCH64.reset_untyped_cap_globals_equiv - AARCH64.invoke_untyped_globals_equiv - AARCH64.storeWord_globals_equiv +arch_requalify_facts + reset_untyped_cap_reads_respects_g + reset_untyped_cap_globals_equiv + invoke_untyped_globals_equiv + storeWord_globals_equiv end diff --git a/proof/infoflow/AARCH64/ArchScheduler_IF.thy b/proof/infoflow/AARCH64/ArchScheduler_IF.thy index 5ae58b0267..3a29f3a7ce 100644 --- a/proof/infoflow/AARCH64/ArchScheduler_IF.thy +++ b/proof/infoflow/AARCH64/ArchScheduler_IF.thy @@ -9,7 +9,7 @@ imports Scheduler_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Scheduler_IF_assms @@ -70,17 +70,22 @@ lemma arch_scheduler_affects_equiv_ready_queues_update[Scheduler_IF_assms, simp] crunch arch_switch_to_thread, arch_switch_to_idle_thread for idle_thread[Scheduler_IF_assms, wp]: "\s :: det_state. P (idle_thread s)" - and kheap[Scheduler_IF_assms, wp]: "\s :: det_state. P (kheap s)" (wp: crunch_wps simp: crunch_simps) +declare arch_prepare_next_domain_idle_thread[Scheduler_IF_assms] + crunch arch_switch_to_thread, arch_switch_to_idle_thread for cur_domain[Scheduler_IF_assms, wp]: "\s. P (cur_domain s)" and domain_fields[Scheduler_IF_assms, wp]: "domain_fields P" -crunch arch_switch_to_idle_thread - for globals_equiv[Scheduler_IF_assms, wp]: "globals_equiv st" - and states_equiv_for[Scheduler_IF_assms, wp]: "states_equiv_for P Q R S st" - and work_units_completed[Scheduler_IF_assms, wp]: "\s. P (work_units_completed s)" +lemma arch_switch_to_idle_thread_globals_equiv[Scheduler_IF_assms,wp]: + "\valid_arch_state and globals_equiv st\ arch_switch_to_idle_thread \\_. globals_equiv st\" + unfolding arch_switch_to_idle_thread_def + by wpsimp + +lemma arch_switch_to_idle_thread_work_units_completed[Scheduler_IF_assms,wp]: + "arch_switch_to_idle_thread \\s. P (work_units_completed s)\" + by wp crunch arch_activate_idle_thread for cur_domain[Scheduler_IF_assms, wp]: "\s. P (cur_domain s)" @@ -129,14 +134,14 @@ lemma equiv_asid_equiv_update[Scheduler_IF_assms]: \ equiv_asid asid st (s\kheap := (kheap s)(x \ TCB y')\)" by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) -declare arch_prepare_next_domain_inv[Scheduler_IF_assms] +declare arch_activate_idle_thread_domain_fields_invs[Scheduler_IF_assms] end -requalify_consts - AARCH64.arch_globals_equiv_scheduler - AARCH64.arch_scheduler_affects_equiv +arch_requalify_consts + arch_globals_equiv_scheduler + arch_scheduler_affects_equiv global_interpretation Scheduler_IF_1?: Scheduler_IF_1 arch_globals_equiv_scheduler arch_scheduler_affects_equiv @@ -147,7 +152,119 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming + +(* scheduler_affects_equiv - states_equiv_for_labels *) +definition scheduler_affects_inv where + "scheduler_affects_inv aag l st s \ + (reads_scheduler_cur_domain aag l st \ reads_scheduler_cur_domain aag l s \ + cur_thread st = cur_thread s \ + scheduler_action st = scheduler_action s \ + work_units_completed st = work_units_completed s \ + scheduler_globals_frame_equiv st s \ + idle_thread st = idle_thread s \ + (cur_thread st \ idle_thread s \ arch_scheduler_affects_equiv st s))" + +definition scheduler_inv where + "scheduler_inv aag l s s' \ + scheduler_equiv aag s s' \ scheduler_affects_inv aag l s s'" + +abbreviation (input) scheduler_can_read where + "scheduler_can_read aag l \ \l'. l' \ reads_scheduler aag l" + +lemma domains_distinct_states_equiv_for_labels: + "pas_domains_distinct aag + \ states_equiv_for_labels aag L s s' = states_equiv_but_for_labels aag (not L) s s'" + apply (rule iffI; erule states_equiv_for_guard_imp; clarsimp) + apply (fastforce simp: pas_domains_distinct_def) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x=x in allE, clarsimp) + done + +lemma scheduler_affects_equiv_def2: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "scheduler_affects_equiv aag l s s' \ + states_equiv_but_for_labels aag (not scheduler_can_read aag l) s s' \ scheduler_affects_inv aag l s s'" + apply (rule eq_reflection) + apply (simp only: domains_distinct_states_equiv_for_labels[OF domains_distinct,symmetric]) + apply (auto simp: scheduler_affects_equiv_def scheduler_affects_inv_def) + done + +lemma scheduler_inv_def2: + "scheduler_inv aag l s s' \ + domain_fields_equiv s s' \ idle_thread s = idle_thread s' \ + globals_equiv_scheduler s s' \ silc_dom_equiv aag s s' \ + irq_state_of_state s = irq_state_of_state s' \ + (reads_scheduler_cur_domain aag l s \ reads_scheduler_cur_domain aag l s' + \ (cur_thread s = cur_thread s' \ scheduler_action s = scheduler_action s' \ + work_units_completed s = work_units_completed s' \ + scheduler_globals_frame_equiv s s' \ + (cur_thread s \ idle_thread s' \ arch_scheduler_affects_equiv s s')))" + apply (rule eq_reflection) + apply (auto simp: scheduler_inv_def scheduler_equiv_def scheduler_affects_inv_def) + done + +lemma reads_respects_scheduler_def2: + "reads_respects_scheduler aag l P f \ + equiv_valid_inv (scheduler_inv aag l) (states_equiv_for_labels aag (scheduler_can_read aag l)) P f" + apply (rule eq_reflection) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule iff_allI)+ + apply (rule iffI; clarsimp) + apply (drule mp) + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + apply (drule (1) bspec, clarsimp)+ + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + apply (drule mp) + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + apply (drule (1) bspec, clarsimp)+ + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + done + +lemma domain_fields_equiv_sym: + "domain_fields_equiv st s = domain_fields_equiv s st" + by (auto simp: domain_fields_equiv_def) + +lemma reads_respects_scheduler_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + and inv: "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\P. \\s. P (cur_thread s) \ Q s\ f \\_ s. P (cur_thread s)\" + "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (scheduler_action s) \ Q s\ f \\_ s. P (scheduler_action s)\" + "\P. \\s. P (work_units_completed s) \ Q s\ f \\_ s. P (work_units_completed s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P st. \\s. P (domain_fields_equiv st s) \ Q s\ f \\_ s. P (domain_fields_equiv st s)\" + "\P st. \\s. P (globals_equiv_scheduler st s) \ Q s\ f \\_ s. P (globals_equiv_scheduler st s)\" + "\P st. \\s. P (scheduler_globals_frame_equiv st s) \ Q s\ f \\_ s. P (scheduler_globals_frame_equiv st s)\" + "\P st. \\s. P (silc_dom_equiv aag st s) \ Q s\ f \\_ s. P (silc_dom_equiv aag st s)\" + shows "reads_respects_scheduler aag l (P and Q) f" + apply (simp add: reads_respects_scheduler_def2) + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_inv_def2 + apply (rule hoare_weaken_pre) + apply clarsimp + apply (rule hoare_lift_Pf2_pre_conj[where f=cur_domain, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=cur_thread, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=idle_thread, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=idle_thread, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=scheduler_action, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=work_units_completed, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=irq_state_of_state, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=idle_thread, rotated], wp inv) + apply (rule_tac f="domain_fields_equiv st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (rule_tac f="globals_equiv_scheduler st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (rule_tac f="scheduler_globals_frame_equiv st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (rule_tac f="silc_dom_equiv aag st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply wp + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym + scheduler_globals_frame_equiv_sym arch_scheduler_affects_equiv_sym)[2] + apply (insert ev) + apply (fastforce elim: wp_pre) + done definition swap_things where "swap_things s t \ @@ -172,12 +289,23 @@ lemma globals_equiv_scheduler_inv'[Scheduler_IF_assms]: arch_globals_equiv_scheduler_def arch_scheduler_affects_equiv_def)+ done +crunch vcpu_switch + for global_pt[wp]: "\s. P (global_pt s)" + (wp: valid_global_arch_objs_lift) + +crunch vcpu_switch + for valid_global_arch_objs[wp]: "valid_global_arch_objs" + (wp: valid_global_arch_objs_lift) + lemma arch_switch_to_thread_globals_equiv_scheduler[Scheduler_IF_assms]: "\invs and globals_equiv_scheduler sta\ arch_switch_to_thread thread \\_. globals_equiv_scheduler sta\" unfolding arch_switch_to_thread_def storeWord_def - by (wpsimp wp: dmo_wp modify_wp thread_get_wp' globals_equiv_scheduler_inv'[where P="\"]) + apply (wpsimp wp: dmo_wp modify_wp thread_get_wp' lazy_fpu_restore_globals_equiv + globals_equiv_scheduler_inv'[where P="invs"]) + apply (auto intro: sym_refs_VCPU_hyp_live) + done crunch arch_activate_idle_thread for silc_dom_equiv[Scheduler_IF_assms, wp]: "silc_dom_equiv aag st" @@ -193,7 +321,7 @@ lemmas set_vm_root_scheduler_affects_equiv[wp] = set_vm_root_arch_scheduler_affects_equiv] lemma set_vm_root_reads_respects_scheduler[wp]: - "reads_respects_scheduler aag l \ (set_vm_root thread)" + "reads_respects_scheduler aag l valid_global_arch_objs (set_vm_root thread)" apply (rule reads_respects_scheduler_unobservable'[OF scheduler_equiv_lift' [OF globals_equiv_scheduler_inv']]) apply (wp silc_dom_equiv_states_equiv_lift set_vm_root_states_equiv_for | simp)+ @@ -201,7 +329,7 @@ lemma set_vm_root_reads_respects_scheduler[wp]: lemma store_cur_thread_fragment_midstrength_reads_respects: "equiv_valid (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) - (scheduler_affects_equiv aag l) invs + (scheduler_affects_equiv aag l) \ (do x \ modify (cur_thread_update (\_. t)); set_scheduler_action resume_cur_thread od)" @@ -215,78 +343,453 @@ lemma store_cur_thread_fragment_midstrength_reads_respects: simp del: split_paired_All) done -lemma arch_switch_to_thread_globals_equiv_scheduler': +lemma set_vm_root_globals_equiv_scheduler: "\invs and globals_equiv_scheduler sta\ set_vm_root t \\_. globals_equiv_scheduler sta\" by (rule globals_equiv_scheduler_inv', wpsimp) -lemma arch_switch_to_thread_reads_respects_scheduler[wp]: - "reads_respects_scheduler aag l - ((\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)) and invs) - (arch_switch_to_thread t)" - apply (rule reads_respects_scheduler_cases) - apply (simp add: arch_switch_to_thread_def) - apply wp - apply (clarsimp simp: scheduler_equiv_def globals_equiv_scheduler_def) - apply (simp add: arch_switch_to_thread_def) - apply wp +lemma equiv_valid_inv_A_conjI: + "\ equiv_valid_inv I A P f; equiv_valid_rv_inv I A' \\ P f \ + \ equiv_valid_inv I (\s s'. A s s' \ A' s s') P f" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule_tac x=s in allE, erule_tac x=s in allE) + apply (erule_tac x=t in allE, erule_tac x=t in allE) + apply fastforce + done + +lemma scheduler_globals_frame_equiv_triv[simp]: + "scheduler_globals_frame_equiv st s" + by (clarsimp simp: scheduler_globals_frame_equiv_def) + +lemma midstrength_reads_respects_scheduler_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + assumes inv: "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P. \\s. P (work_units_completed s) \ Q s\ f \\_ s. P (work_units_completed s)\" + "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\st. \\s. domain_fields_equiv st s \ Q s\ f \\_ s. domain_fields_equiv st s\" + "\st. \\s. globals_equiv_scheduler st s \ Q s\ f \\_ s. globals_equiv_scheduler st s\" + "\st. \\s. silc_dom_equiv aag st s \ Q s\ f \\_ s. silc_dom_equiv aag st s\" + shows "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) (P and Q) f" + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_equiv_def + apply (wpsimp wp: inv) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym)[2] + unfolding midstrength_scheduler_affects_equiv_def + apply (rule equiv_valid_inv_A_conjI) + apply (rule_tac Q=P in equiv_valid_guard_imp) + apply (insert ev)[1] + apply fastforce + apply simp + apply (rule_tac Q=Q and Q'=Q in equiv_valid_2_guard_imp) + apply (rule equiv_valid_rv_inv_lift) + apply (wpsimp wp: inv hoare_vcg_imp_lift)+ + apply auto + done + +lemma weak_reads_respects_scheduler_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + and inv: "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\st. \\s. domain_fields_equiv st s \ Q s\ f \\_ s. domain_fields_equiv st s\" + "\st. \\s. globals_equiv_scheduler st s \ Q s\ f \\_ s. globals_equiv_scheduler st s\" + "\st. \\s. silc_dom_equiv aag st s \ Q s\ f \\_ s. silc_dom_equiv aag st s\" + shows "equiv_valid_inv (scheduler_equiv aag) (weak_scheduler_affects_equiv aag l) (P and Q) f" + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_equiv_def + apply (wpsimp wp: inv) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym)[2] + unfolding weak_scheduler_affects_equiv_def + apply (rule_tac Q=P in equiv_valid_guard_imp) + apply (insert ev)[1] + apply fastforce apply simp done lemmas globals_equiv_scheduler_inv = globals_equiv_scheduler_inv'[where P="\",simplified] -lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_assms, wp]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) - (do _ <- arch_switch_to_thread t; - _ <- modify (cur_thread_update (\_. t)); - modify (scheduler_action_update (\_. resume_cur_thread)) - od)" +lemmas set_global_user_vspace_globals_equiv_scheduler[wp] = + globals_equiv_scheduler_inv[OF set_global_user_vspace_globals_equiv] + +lemma set_vcpu_silc_dom_equiv: + "\silc_dom_equiv aag st and valid_silc_label aag\ set_vcpu ptr vcpu \\_. silc_dom_equiv aag st\" + unfolding set_vcpu_def + by (wpsimp wp: set_object_silc_dom_equiv simp: is_cap_table_def) + +crunch vcpu_save_reg + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +lemma vcpu_save_reg_range_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + vcpu_save_reg_range vr from to + \\_. silc_dom_equiv aag st\" + unfolding vcpu_save_reg_range_def + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp_inv) + apply (wpsimp wp: valid_silc_label_lift)+ + done + +crunch vcpu_save, vcpu_restore + for silc_dom_equiv: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch vcpu_switch + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch arch_switch_to_idle_thread + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch arch_switch_to_thread + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch arch_prepare_next_domain + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + and typ_at[wp]: "\s. P (typ_at T ptr s)" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +lemma next_domain_snippet_cur_vcpu_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; + next_domain + od + \\_. cur_vcpu_in_cur_domain\" + unfolding arch_prepare_next_domain_def + by wpsimp + +lemma next_domain_snippet_cur_fpu_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; + next_domain + od + \\_. cur_fpu_in_cur_domain\" + unfolding arch_prepare_next_domain_def + by wpsimp + +lemmas [Scheduler_IF_assms] = + arch_switch_to_thread_silc_dom_equiv + arch_switch_to_idle_thread_silc_dom_equiv + set_scheduler_action_cur_vcpu_in_cur_domain + set_scheduler_action_cur_fpu_in_cur_domain + tcb_sched_action_cur_vcpu_in_cur_domain + tcb_sched_action_cur_fpu_in_cur_domain + next_domain_snippet_cur_vcpu_in_cur_domain + next_domain_snippet_cur_fpu_in_cur_domain + arch_prepare_next_domain_silc_dom_equiv + arch_prepare_next_domain_typ_at + +lemma vcpu_switch_globals_equiv_scheduler[wp]: + "\valid_arch_state and globals_equiv_scheduler s\ vcpu_switch vr \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' vcpu_switch_globals_equiv | fastforce)+ + +lemma vcpu_switch_midstrength_reads_respects_scheduler: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) (vcpu_switch vopt)" apply (rule equiv_valid_guard_imp) - apply (rule midstrength_reads_respects_scheduler_cases[ - where Q="(invs and pas_refined aag and - (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)))", - OF domains_distinct]) - apply (simp add: arch_switch_to_thread_def bind_assoc) - apply (rule bind_ev_general) - apply (fold set_scheduler_action_def) - apply (rule store_cur_thread_fragment_midstrength_reads_respects) - apply (rule_tac P="\" and P'="\" in equiv_valid_inv_unobservable) - apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P=\]) - apply (wp globals_equiv_scheduler_inv silc_dom_lift | simp)+ - apply (wp midstrength_scheduler_affects_equiv_unobservable set_vm_root_states_equiv_for - | simp)+ - apply (wp cur_thread_update_not_subject_reads_respects_scheduler | simp | fastforce)+ + apply (rule midstrength_reads_respects_scheduler_from_labels) + apply (rule vcpu_switch_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift | erule conjunct1)+ + done + +lemma set_global_user_vspace_states_equiv_for[wp]: + "set_global_user_vspace \states_equiv_for P Q R S st\" + unfolding set_global_user_vspace_def setVSpaceRoot_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for) + +lemma set_global_user_vspace_midstrength_reads_respects: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + \ set_global_user_vspace" + apply (rule equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift') + apply wpsimp+ + apply (wp midstrength_scheduler_affects_equiv_unobservable + | simp | wps)+ + apply (auto simp: scheduler_equiv_sym midstrength_scheduler_affects_equiv_sym) done +lemma arch_switch_to_idle_thread_midstrength_reads_respects[Scheduler_IF_assms]: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + unfolding arch_switch_to_idle_thread_def + by (wp set_global_user_vspace_midstrength_reads_respects vcpu_switch_midstrength_reads_respects_scheduler) + lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" unfolding arch_switch_to_idle_thread_def storeWord_def - by (wp dmo_wp modify_wp thread_get_wp' arch_switch_to_thread_globals_equiv_scheduler') + by (wp dmo_wp modify_wp thread_get_wp' set_vm_root_globals_equiv_scheduler) + +lemma states_equiv_but_for_labels_equiv_for_lift: + assumes "\st. \\s. equiv_but_for_labels aag {l. L l} st s \ Q s\ f \\_. equiv_but_for_labels aag {l. L l} st\" + shows "\\s. states_equiv_but_for_labels aag L st s \ Q s\ f \\_. states_equiv_but_for_labels aag L st\" + apply (clarsimp simp: valid_def) + apply (prop_tac "equiv_but_for_labels aag {l. L l} s s") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_refl) + apply (insert assms) + apply (erule_tac x=s in meta_allE) + apply (drule use_valid) + apply assumption + apply simp + apply (clarsimp simp: equiv_but_for_labels_def) + apply (erule (1) states_equiv_for_trans) + done + +lemma vcpu_switch_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ + (\vr. vopt = Some vr \ pasObjectAbs aag vr \ L) \ + (\vr b. current_vcpu s = Some (vr,b) \ pasObjectAbs aag vr \ L)\ + vcpu_switch vopt + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_switch_def + apply (wpc | wp modify_current_vcpu_equiv_but_for_labels)+ + apply clarsimp + apply (rule conjI) + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (rule conjI) + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (case_tac b) + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (case_tac "a = x") + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (clarsimp simp: cur_vcpu_for_Some) + done + +lemma vcpu_switch_None_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ + (\vr b. current_vcpu s = Some (vr,True) \ pasObjectAbs aag vr \ L)\ + vcpu_switch None + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_switch_def + apply (wpc | wp modify_current_vcpu_equiv_but_for_labels)+ + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + done + +lemma tcb_invisible: + "\ \ reads_scheduler_cur_domain aag l s; pas_refined aag s; in_cur_domain t s; tcb_at t s \ + \ pasObjectAbs aag t \ reads_scheduler aag l" + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + by blast + +lemma vcpu_controls_associated_tcb: + "\ pas_refined aag s; vcpus_of s v = Some vcpu; vcpu_tcb vcpu = Some t \ + \ (v, Control, t) \ state_objs_to_policy s" + by (fastforce simp: sbta_href state_objs_to_policy_def state_hyp_refs_of_def opt_map_def + dest: pas_refined_mem is_subject_trans split: option.splits)+ + +(* FIXME AARCH64 IF: move *) +lemma invs_cur_vcpu: + "invs s \ cur_vcpu s" + by (auto simp: invs_def valid_state_def valid_arch_state_def) + +lemma vcpu_invisible: + assumes nrs: "\ reads_scheduler_cur_domain aag l s" + and pwn: "pas_wellformed_noninterference aag" + shows + "\ pas_refined aag s; valid_silc_label aag s; + invs s; current_vcpu s = Some (vr,b); cur_vcpu_in_cur_domain s \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (prop_tac "cur_vcpu s") + apply (erule invs_cur_vcpu) + apply (clarsimp simp: cur_vcpu_def opt_pred_def split: option.splits) + apply (clarsimp simp: cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (rename_tac t vcpu) + apply (prop_tac "tcb_at t s") + apply (drule invs_valid_objs) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_vcpu_def obj_at_def) + apply (frule (2) tcb_invisible[OF nrs]) + apply (frule_tac vcpu=vcpu in vcpu_controls_associated_tcb) + apply (fastforce simp: opt_map_def split: option.splits) + apply simp + apply (prop_tac "pasObjectAbs aag vr \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + using pwn apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: - "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and - scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ - arch_switch_to_idle_thread - \\_ s. scheduler_affects_equiv aag l st s\" + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + arch_switch_to_idle_thread + \\_ s. scheduler_affects_equiv aag l st s\" apply (simp add: arch_switch_to_idle_thread_def) apply wp - apply (clarsimp simp add: scheduler_equiv_def domain_fields_equiv_def invs_def valid_state_def) + apply (rule scheduler_affects_equiv_unobservable) + apply wpsimp+ + apply (unfold arch_scheduler_affects_equiv_def)[1] + apply wpsimp + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + apply (wp states_equiv_but_for_labels_equiv_for_lift) + apply (wp vcpu_switch_None_equiv_but_for_labels) + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply wps + apply wpsimp + using wellformed apply (clarsimp simp: vcpu_invisible) + done + +lemma lazy_fpu_restore_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ (\t. cur_fpu_of s t \ pasObjectAbs aag t \ L) \ + pasObjectAbs aag t \ L \ valid_cur_fpu s\ + lazy_fpu_restore t + \\_. equiv_but_for_labels aag L st\" + unfolding lazy_fpu_restore_def + apply wpsimp + apply (wp switch_local_fpu_owner_equiv_but_for_labels) + apply wpsimp+ + apply (wp thread_get_wp') + apply clarsimp + done + +lemma cur_fpu_invisible: + "\ pas_refined aag s; \ reads_scheduler_cur_domain aag l s; cur_fpu_in_cur_domain s; + valid_cur_fpu s; current_fpu s = Some t \ + \ pasObjectAbs aag t \ reads_scheduler aag l" + apply (clarsimp simp: cur_fpu_in_cur_domain_def) + apply (frule current_fpu_owner_Some_tcb_at, fastforce) + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + by blast + +lemma states_equiv_for_helper: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "states_equiv_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) + (\x. pasIRQAbs aag x \ reads_scheduler aag l) + (\x. pasASIDAbs aag x \ reads_scheduler aag l) + (\x. \la\pasDomainAbs aag x. la \ reads_scheduler aag l) + st s = + states_equiv_but_for_labels aag (\l'. l' \ reads_scheduler aag l) st s" + apply clarsimp + apply (rule iffI; erule rsubst[where P="\x. states_equiv_for _ _ _ x _ _"]; rule ext) + using domains_distinct + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x=x in allE) + apply clarsimp + using domains_distinct + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x=x in allE) + apply clarsimp + done + +lemma lazy_fpu_restore_scheduler_affects_equiv: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\\s. scheduler_affects_equiv aag l st s \ pas_refined aag s \ + \ reads_scheduler_cur_domain aag l s \ pasObjectAbs aag t \ reads_scheduler aag l \ + cur_fpu_in_cur_domain s \ valid_cur_fpu s\ + lazy_fpu_restore t + \\_. scheduler_affects_equiv aag l st\" + apply (rule wp_pre) + unfolding scheduler_affects_equiv_def + apply (rule hoare_vcg_conj_lift) + defer + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply (wpsimp wp: hoare_vcg_imp_lift' simp: scheduler_globals_frame_equiv_def) + apply (rule conjI) + prefer 2 + apply clarsimp + defer + apply (rule_tac Q'="\_. states_equiv_but_for_labels aag (\l'. l' \ reads_scheduler aag l) st" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp:) + apply (subst states_equiv_for_helper[OF domains_distinct]) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (wp states_equiv_but_for_labels_equiv_for_lift) + apply (wp lazy_fpu_restore_equiv_but_for_labels) + apply (subst (asm) states_equiv_for_helper[OF domains_distinct]) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (clarsimp simp: cur_fpu_invisible) + done + +lemma vcpu_switch_scheduler_affects_equiv: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + K (\vr. vopt = Some vr \ pasObjectAbs aag vr \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + vcpu_switch vopt + \\_ s. scheduler_affects_equiv aag l st s\" + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + apply (wp states_equiv_but_for_labels_equiv_for_lift) + apply (wp vcpu_switch_equiv_but_for_labels) + apply (unfold scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply simp + apply wps + apply wpsimp + apply simp + using wellformed apply (clarsimp simp: vcpu_invisible) + done + +lemma tcb_controls_associated_vcpu: + "\ pas_refined aag s; get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some v \ + \ (t, Control, v) \ state_objs_to_policy s" + by (fastforce simp: sbta_href state_objs_to_policy_def state_hyp_refs_of_def get_tcb_def + dest: pas_refined_mem is_subject_trans split: option.splits kernel_object.splits)+ + +lemma associated_vcpu_invisible: + "\ pas_wellformed_noninterference aag; pasObjectAbs aag t \ reads_scheduler aag l; + pas_refined aag s; valid_silc_label aag s; invs s; + get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some vr \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (frule (2) tcb_controls_associated_vcpu) + apply (prop_tac "pasObjectAbs aag t \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def get_tcb_Some) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp done lemma arch_switch_to_thread_unobservable[Scheduler_IF_assms]: + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "\(\s. \ reads_scheduler_cur_domain aag l s) and - scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and cur_fpu_in_cur_domain and + valid_silc_label aag and pas_refined aag\ arch_switch_to_thread t \\_ s. scheduler_affects_equiv aag l st s\" apply (simp add: arch_switch_to_thread_def) - apply (wp set_vm_root_scheduler_affects_equiv | simp)+ - done + apply (wp set_vm_root_scheduler_affects_equiv lazy_fpu_restore_scheduler_affects_equiv + vcpu_switch_scheduler_affects_equiv | simp)+ + apply clarsimp + apply (rule conjI) + prefer 2 + apply fastforce + using wellformed by (clarsimp simp: associated_vcpu_invisible) (* Can split, but probably more effort to generalise *) lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: @@ -301,7 +804,7 @@ lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: apply (clarsimp simp: equiv_for_def equiv_asid_def equiv_asids_def Let_def scheduler_equiv_def globals_equiv_scheduler_def silc_dom_equiv_def domain_fields_equiv_def weak_scheduler_affects_equiv_def midstrength_scheduler_affects_equiv_def - states_equiv_for_def idle_equiv_def) + states_equiv_for_def idle_equiv_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def get_tcb_def) done lemma resetTimer_irq_state[wp]: @@ -310,6 +813,26 @@ lemma resetTimer_irq_state[wp]: apply (wp | wpc| simp)+ done +lemma dmo_resetTimer_underlying_memory[wp]: + "do_machine_op resetTimer \\s. P (underlying_memory (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_device_state[wp]: + "do_machine_op resetTimer \\s. P (device_state (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_vcpu_state[wp]: + "do_machine_op resetTimer \\s. P (vcpu_state (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_fpu_state[wp]: + "do_machine_op resetTimer \\s. P (fpu_state (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_tcb_cur_fpu_of[wp]: + "do_machine_op resetTimer \\s. P (tcb_cur_fpu_of s)\" + by (wpsimp wp: dmo_wp simp: comp_def) + lemma dmo_resetTimer_reads_respects_scheduler[Scheduler_IF_assms]: "reads_respects_scheduler aag l \ (do_machine_op resetTimer)" apply (rule reads_respects_scheduler_unobservable) @@ -318,9 +841,9 @@ lemma dmo_resetTimer_reads_respects_scheduler[Scheduler_IF_assms]: apply (wpsimp wp: dmo_wp) apply ((wp silc_dom_lift dmo_wp | simp)+)[5] apply (rule scheduler_affects_equiv_unobservable) - apply (simp add: states_equiv_for_def[abs_def] equiv_for_def equiv_asids_def equiv_asid_def) - apply (rule hoare_pre) - apply (wp | simp add: arch_scheduler_affects_equiv_def | wp dmo_wp)+ + unfolding states_equiv_for_def[abs_def] + apply (wp equiv_for_lift equiv_machine_state_lift equiv_asids_lift equiv_hyp_lift equiv_fpu_lift)+ + apply (wpsimp wp: dmo_wp simp: arch_scheduler_affects_equiv_def) done lemma ackInterrupt_reads_respects_scheduler[Scheduler_IF_assms]: @@ -354,48 +877,681 @@ lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: apply (clarsimp simp: arch_scheduler_affects_equiv_def) apply (elim states_equiv_forE equiv_forE) apply (rule states_equiv_forI,simp_all add: equiv_for_def equiv_asids_def equiv_asid_def) - apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) apply (clarsimp simp: idle_context_def get_tcb_def split: option.splits kernel_object.splits) apply (subst arch_tcb_update_aux) apply simp apply (subgoal_tac "s = (s\kheap := (kheap s)(idle_thread s \ TCB y)\)", simp) apply (rule state.equality) - apply (rule ext) - apply simp+ + apply (rule ext) + apply simp+ done -lemma set_object_reads_respects_scheduler[Scheduler_IF_assms, wp]: - "reads_respects_scheduler aag l \ (set_object ptr obj)" - unfolding equiv_valid_def2 equiv_valid_2_def - by (auto simp: set_object_def bind_def get_def put_def return_def get_object_def assert_def - fail_def gets_def scheduler_equiv_def domain_fields_equiv_def equiv_for_def - globals_equiv_scheduler_def arch_globals_equiv_scheduler_def silc_dom_equiv_def - scheduler_affects_equiv_def arch_scheduler_affects_equiv_def - scheduler_globals_frame_equiv_def identical_kheap_updates_def - intro: states_equiv_for_identical_kheap_updates idle_equiv_identical_kheap_updates) + +lemma thread_set_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" + apply (rule gen_asm_ev) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + unfolding thread_set_def gets_the_def gets_def get_def put_def return_def fail_def + set_object_def get_object_def assert_def assert_opt_def + apply (clarsimp simp: bind_def split: option.splits if_splits) + apply (clarsimp simp: get_tcb_ko_at obj_at_def) + unfolding valid_tcb_context_update_def + apply (rename_tac s' tcb tcb') + apply (erule_tac x=tcb in allE) + apply (erule_tac x=tcb' in allE) + apply (rule conjI) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def) + apply (intro conjI) + apply (clarsimp simp: valid_global_arch_objs_def arch_globals_equiv_scheduler_def) + apply (clarsimp simp: idle_equiv_def tcb_at_def get_tcb_def arch_tcb_context_get_def) + apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI; clarsimp?) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def) + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def arch_tcb_context_set_def arch_tcb_context_get_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def arch_scheduler_affects_equiv_def) + done lemma arch_activate_idle_thread_reads_respects_scheduler[Scheduler_IF_assms, wp]: "reads_respects_scheduler aag l \ (arch_activate_idle_thread rv)" unfolding arch_activate_idle_thread_def by wpsimp -lemma arch_prepare_next_domain_ev[Scheduler_IF_assms]: - "equiv_valid_inv I A (\_. True) arch_prepare_next_domain" - unfolding arch_prepare_next_domain_def by wp +lemma tcb_visible: + "\ reads_scheduler_cur_domain aag l s; pas_refined aag s; + pas_domains_distinct aag; in_cur_domain t s; tcb_at t s \ + \ pasObjectAbs aag t \ reads_scheduler aag l" + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE) + apply clarsimp + done + +lemma associated_vcpu_visible: + assumes nrs: "reads_scheduler_cur_domain aag l s" + and pwn: "pas_wellformed_noninterference aag" + shows + "\ pasObjectAbs aag t \ reads_scheduler aag l; + pas_refined aag s; valid_silc_label aag s; invs s; + get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some vr \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (frule (2) tcb_controls_associated_vcpu) + apply (prop_tac "pasObjectAbs aag t \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def get_tcb_Some) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + using pwn apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done + +lemma vcpu_visible: + assumes rs: "reads_scheduler_cur_domain aag l s" + and wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\ pas_refined aag s; valid_silc_label aag s; + invs s; current_vcpu s = Some (vr,b); cur_vcpu_in_cur_domain s \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (prop_tac "cur_vcpu s") + apply (erule invs_cur_vcpu) + apply (clarsimp simp: cur_vcpu_def opt_pred_def split: option.splits) + apply (clarsimp simp: cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (rename_tac t vcpu) + apply (prop_tac "tcb_at t s") + apply (drule invs_valid_objs) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_vcpu_def obj_at_def) + apply (frule (2) tcb_visible[OF rs _ domains_distinct]) + apply (frule_tac vcpu=vcpu in vcpu_controls_associated_tcb) + apply (fastforce simp: opt_map_def split: option.splits) + apply simp + apply (prop_tac "pasObjectAbs aag vr \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + using wellformed apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done + +lemma gets_current_vcpu_weak_reads_respects_scheduler: + assumes wellformed[simp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "weak_reads_respects_scheduler aag l + (reads_scheduler_cur_domain aag l and pas_refined aag and valid_silc_label aag + and invs and cur_vcpu_in_cur_domain) + (gets (arm_current_vcpu \ arch_state))" + apply (wp gets_ev'') + prefer 2 + apply assumption + apply clarsimp + apply (prop_tac "equiv_for (\vr. pasObjectAbs aag vr \ reads_scheduler aag l) cur_vcpu_of s t") + apply (clarsimp simp: weak_scheduler_affects_equiv_def states_equiv_for_def equiv_hyp_def) + apply (case_tac "\vr b. current_vcpu s = Some (vr,b)", clarsimp) + apply (subgoal_tac "pasObjectAbs aag vr \ reads_scheduler aag l") + apply (fastforce simp: equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + apply (erule vcpu_visible) + apply simp+ + apply (case_tac "\vr b. current_vcpu t = Some (vr,b)", clarsimp) + apply (subgoal_tac "pasObjectAbs aag vr \ reads_scheduler aag l") + apply (fastforce simp: equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + apply (erule_tac s=t in vcpu_visible) + apply simp+ + done + +lemma vcpu_disable_None_states_equiv_valid: + "states_equiv_valid aag L (\s. \vr. current_vcpu s = Some (vr,True)) (vcpu_disable None)" + apply (simp only: vcpu_disable_def fun_app_def bind_assoc[symmetric] vcpu_save_vgic_defs[symmetric]) + apply (clarsimp simp: dmo_distr) + apply wpsimp + done + +lemma vcpu_disable_globals_equiv_scheduler[wp]: + "\valid_arch_state and globals_equiv_scheduler s\ vcpu_disable vr \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' | fastforce)+ + +lemma vcpu_disable_None_weak_reads_respects_scheduler: + "weak_reads_respects_scheduler aag l + (\s. valid_arch_state s \ valid_silc_label aag s \ (\vr. current_vcpu s = Some (vr,True))) + (vcpu_disable None)" + apply (rule equiv_valid_guard_imp) + apply (rule weak_reads_respects_scheduler_from_labels[where Q="valid_arch_state and valid_silc_label aag"]) + apply (rule vcpu_disable_None_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift)+ + done + +lemma modify_current_vcpu_None_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\))" + apply (wpsimp wp: modify_ev) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (auto simp: equiv_asids_def equiv_asid_def)[1] + apply (clarsimp simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: option.split) + apply (auto simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + done + +lemma disable_current_vcpu_weak_reads_respects_scheduler: + "weak_reads_respects_scheduler aag l \ (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\))" + apply (rule equiv_valid_guard_imp) + apply (rule weak_reads_respects_scheduler_from_labels) + by (wpsimp wp: domain_fields_equiv_lift simp: globals_equiv_scheduler_def arch_globals_equiv_scheduler_def)+ + +lemma vcpu_disable_None_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_disable None \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_disable_def + apply (clarsimp simp: dmo_distr) + apply wpsimp + done + +lemma modify_current_vcpu_equiv_but_for_labels'': + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\) + \\_ s. equiv_but_for_labels aag L st s\" + apply wp + apply (clarsimp simp: cur_vcpu_for_def equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + defer + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (intro context_conjI; clarsimp) + apply (erule_tac x=x in allE)+ + apply clarsimp + apply (case_tac "\b. current_vcpu s = Some (x, b)") + apply clarsimp + apply (fastforce simp: cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_invalidate_active_unobservable: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + vcpu_invalidate_active + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: vcpu_invalidate_active_def) + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + supply modify_wp[wp del] + apply (wp states_equiv_but_for_labels_equiv_for_lift modify_current_vcpu_equiv_but_for_labels'' | wpc)+ + apply clarsimp + apply (clarsimp simp: cur_vcpu_for_def del: notI) + apply (prop_tac "cur_vcpu_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) s = None") + apply assumption + apply (clarsimp simp: cur_vcpu_for_def) + prefer 2 + apply (rule conjI) + defer 2 + apply clarsimp + apply (case_tac "current_vcpu s") + apply (clarsimp simp: cur_vcpu_for_def split: option.splits) + apply (clarsimp simp: cur_vcpu_for_def del: notI) + apply (rule vcpu_invisible[OF _ wellformed]) + apply simp+ + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply (wpsimp wp: modify_wp hoare_vcg_imp_lift) + apply clarsimp + done + +lemma vcpu_invalidate_active_weak_scheduler_reads_respects: + assumes wellformed[wp,simp]: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "weak_reads_respects_scheduler aag l + (invs and ct_in_cur_domain and valid_cur_vcpu and pas_refined aag + and cur_vcpu_in_cur_domain and valid_silc_label aag) + vcpu_invalidate_active" + apply (rule equiv_valid_cases[where P="\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {}"]) + prefer 3 + apply (simp add: scheduler_equiv_def domain_fields_equiv_def) + prefer 2 + defer + apply (unfold vcpu_invalidate_active_def)[1] + apply (rule equiv_valid_guard_imp) + apply (wpc | wp disable_current_vcpu_weak_reads_respects_scheduler + vcpu_disable_None_weak_reads_respects_scheduler + gets_current_vcpu_weak_reads_respects_scheduler)+ + apply clarsimp + apply (rule equiv_valid_guard_imp) + apply (rule_tac weak_cur_domain_unobservable) + apply (rule reads_respects_scheduler_unobservable'') + apply (rule wp_pre) + apply (rule scheduler_equiv_lift' [OF globals_equiv_scheduler_inv']) + apply (wpsimp | erule conjunct1)+ + apply (rule wp_pre) + apply (wp vcpu_invalidate_active_unobservable) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def domain_fields_equiv_def) + apply assumption + apply clarsimp + apply assumption + apply clarsimp + apply auto + done + +lemma gets_arm_current_vcpu_states_equiv_valid: + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s \ None) + (gets (arm_current_vcpu \ arch_state))" + apply (wp gets_ev'') + prefer 2 + apply assumption + apply clarsimp + apply (clarsimp simp: states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + done + +lemma vcpu_save_weak_reads_respects_scheduler: + "weak_reads_respects_scheduler aag l + (\s. current_vcpu s = cv \ valid_arch_state s \ valid_silc_label aag s) (vcpu_save cv)" + apply (rule equiv_valid_guard_imp) + apply (rule weak_reads_respects_scheduler_from_labels) + apply (rule vcpu_save_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift globals_equiv_scheduler_inv' vcpu_save_silc_dom_equiv | erule conjunct1)+ + apply (clarsimp simp: valid_arch_state_def) + done + +crunch vcpu_save + for pas_refined[wp]: "pas_refined aag" + (simp: pas_refined_def state_objs_to_policy_def ignore: vcpu_save) + +crunch vcpu_save + for cur_vcpu_in_cur_domain[wp]: cur_vcpu_in_cur_domain + (wp: cur_vcpu_in_cur_domain_lift) + +lemma vcpu_invalidate_active_unobservable': + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\\s. \ reads_scheduler_cur_domain aag l s \ + scheduler_affects_equiv aag l st s \ + cur_domain st = cur_domain s \ + cur_vcpu_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) s = None\ + vcpu_invalidate_active + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: vcpu_invalidate_active_def) + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + supply modify_wp[wp del] + apply (wp states_equiv_but_for_labels_equiv_for_lift modify_current_vcpu_equiv_but_for_labels'' | wpc)+ + apply clarsimp + apply (clarsimp simp: cur_vcpu_for_def del: notI) + apply (prop_tac "cur_vcpu_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) s = None") + apply assumption + apply (clarsimp simp: cur_vcpu_for_def) + prefer 2 + apply (rule conjI) + defer 2 + apply clarsimp + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply (wpsimp wp: modify_wp hoare_vcg_imp_lift) + apply clarsimp + done + +lemma vcpu_save_unobservable: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\\s. \ reads_scheduler_cur_domain aag l s \ + scheduler_affects_equiv aag l st s \ + cur_domain st = cur_domain s \ + current_vcpu s = vopt \ + (\vr b. vopt = Some (vr,b) \ pasObjectAbs aag vr \ reads_scheduler aag l) + \ + vcpu_save vopt + \\_ s. scheduler_affects_equiv aag l st s\" + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + supply modify_wp[wp del] + apply (wp states_equiv_but_for_labels_equiv_for_lift modify_current_vcpu_equiv_but_for_labels'' | wpc)+ + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply (wpsimp wp: modify_wp hoare_vcg_imp_lift) + apply clarsimp + done + +lemma vcpu_flush_unobservable: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + vcpu_flush + \\_. scheduler_affects_equiv aag l st\" + unfolding vcpu_flush_def + apply (wpsimp wp: vcpu_invalidate_active_unobservable' vcpu_save_unobservable) + apply (rule context_conjI) + prefer 2 + apply (clarsimp simp: cur_vcpu_for_Some) + using wellformed apply (clarsimp simp: vcpu_invisible) + done + +lemma vcpu_flush_weak_scheduler_reads_respects: + assumes wellformed[wp,simp]: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "weak_reads_respects_scheduler aag l + (pas_refined aag and valid_silc_label aag and invs and ct_in_cur_domain + and valid_cur_vcpu and cur_vcpu_in_cur_domain) + vcpu_flush" + apply (rule equiv_valid_cases[where P="\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {}"]) + prefer 3 + apply (simp add: scheduler_equiv_def domain_fields_equiv_def) + apply (simp add: vcpu_flush_def) + apply wp + apply (wpsimp wp: ct_in_cur_domain_lift when_ev valid_silc_label_lift + vcpu_invalidate_active_weak_scheduler_reads_respects + vcpu_save_weak_reads_respects_scheduler + gets_current_vcpu_weak_reads_respects_scheduler) + apply (wp gets_current_vcpu_weak_reads_respects_scheduler) + apply wp + apply clarsimp + apply (rule equiv_valid_guard_imp) + apply (rule_tac weak_cur_domain_unobservable) + apply (rule reads_respects_scheduler_unobservable'') + apply (rule wp_pre) + apply (rule scheduler_equiv_lift' [OF globals_equiv_scheduler_inv']) + apply (wpsimp | erule conjunct1)+ + apply (rule wp_pre) + apply (wp vcpu_flush_unobservable) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def domain_fields_equiv_def) + apply assumption + apply clarsimp + apply assumption + apply clarsimp + apply auto + done + +lemma switch_local_fpu_owner_globals_equiv_scheduler[wp]: + "\invs and globals_equiv_scheduler s\ switch_local_fpu_owner vr \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' switch_local_fpu_owner_globals_equiv | fastforce)+ + +lemma vcpu_flush_globals_equiv_scheduler[wp]: + "\valid_arch_state and globals_equiv_scheduler s\ vcpu_flush \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' vcpu_flush_globals_equiv | fastforce)+ + +lemma arch_prepare_next_domain_globals_equiv_scheduler[Scheduler_IF_assms]: + "\invs and globals_equiv_scheduler st\ arch_prepare_next_domain \\_. globals_equiv_scheduler st\" + unfolding arch_prepare_next_domain_def + by wpsimp + +lemma vcpu_invalidate_active_states_equiv_valid: + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s \ None) vcpu_invalidate_active" + unfolding vcpu_invalidate_active_def + by (wpsimp wp: vcpu_disable_None_states_equiv_valid gets_arm_current_vcpu_states_equiv_valid) + +lemma vcpu_invalidate_active_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ (\vr b. current_vcpu s = Some (vr,b) \ pasObjectAbs aag vr \ L)\ + vcpu_invalidate_active + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_invalidate_active_def + by (wpsimp wp: modify_current_vcpu_equiv_but_for_labels'') + (auto simp: cur_vcpu_for_def) + +lemma vcpu_flush_states_equiv_valid[wp]: + "states_equiv_valid aag L (valid_numlistregs) vcpu_flush" + unfolding vcpu_flush_def + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s \ None" in equiv_valid_cases) + prefer 3 + apply (prop_tac "equiv_for (L o pasObjectAbs aag) cur_vcpu_of s t") + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_hyp_def) + apply (rule iffI; clarsimp simp: equiv_for_def) + apply (erule_tac x=ptr in allE, clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (erule_tac x=ptr in allE, clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply wp + apply (wpsimp wp: when_ev vcpu_invalidate_active_states_equiv_valid) + apply (rule gets_arm_current_vcpu_states_equiv_valid) + apply wpsimp + apply clarsimp + apply (subst pred_conj_comm) + apply (rule states_equiv_valid_invisible[OF modifies_at_mostI]) + apply wpsimp + apply wpsimp + apply clarsimp + done + +lemma invs_valid_numlistregs [elim!]: + "invs s \ valid_numlistregs s" + by (drule invs_arch_state) + (simp add: valid_arch_state_def) + +lemma arch_prepare_next_domain_states_equiv_valid: + "states_equiv_valid aag L invs arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def + by wpsimp fastforce + +crunch arch_prepare_next_domain + for domain_time[wp]: "\s. P (domain_time s)" + and domain_index[wp]: "\s. P (domain_index s)" + (simp : crunch_simps wp: crunch_wps) + +crunch arch_prepare_next_domain + for globals_equiv[wp]: "globals_equiv st" + (wp: valid_silc_label_lift) + +lemma arch_prepare_next_domain_weak_scheduler_reads_respects[Scheduler_IF_assms]: + "weak_reads_respects_scheduler aag l (invs and valid_silc_label aag) arch_prepare_next_domain" + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q="invs and valid_silc_label aag" in weak_reads_respects_scheduler_from_labels) + apply (rule arch_prepare_next_domain_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift globals_equiv_scheduler_inv'[where P="invs"])+ + done + +lemma gets_cur_fpu_of_states_equiv_valid: + "states_equiv_valid aag L (valid_cur_fpu and K (L (pasObjectAbs aag t))) (gets (\s. cur_fpu_of s t))" + apply (wpsimp wp: gets_ev'') + prefer 2 + apply (rule conjI) + apply assumption+ + apply (prop_tac "equiv_fpu (\x. L (pasObjectAbs aag x)) x xa") + apply (clarsimp simp: states_equiv_for_def) + apply (clarsimp simp: equiv_fpu_def2) + done + +lemma thread_get_states_equiv_valid: + "states_equiv_valid aag L (K (L (pasObjectAbs aag thread))) (thread_get f thread)" + unfolding thread_get_def fun_app_def + apply (wp gets_the_ev) + apply (auto simp: states_equiv_for_def equiv_for_def get_tcb_def) + done + +lemma lazy_fpu_restore_states_equiv_valid[wp]: + "states_equiv_valid aag L (valid_cur_fpu and K (L (pasObjectAbs aag t))) (lazy_fpu_restore t)" + unfolding lazy_fpu_restore_def + apply (subst gets_comp) + apply (unfold comp_def) + apply (wpsimp wp: gets_cur_fpu_of_states_equiv_valid thread_get_states_equiv_valid thread_get_wp') + done + +lemma set_vm_root_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (set_vm_root t)" + apply (rule states_equiv_valid_unobservable_unit_return) + apply (wp set_vm_root_states_equiv_for) + done + +lemma arch_switch_to_thread_states_equiv_valid: + "states_equiv_valid aag L (invs and K (L (pasObjectAbs aag t))) (arch_switch_to_thread t)" + unfolding arch_switch_to_thread_def + apply (wpsimp wp: vcpu_switch_states_equiv_valid) + apply (auto simp: states_equiv_for_def get_tcb_def equiv_for_def) + done + +lemma midstrength_reads_respects_scheduler_from_labels': + assumes ev: "\L. states_equiv_valid aag L (P (L o pasObjectAbs aag)) f" + and inv: "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P. \\s. P (work_units_completed s) \ Q s\ f \\_ s. P (work_units_completed s)\" + "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\st. \\s. domain_fields_equiv st s \ Q s\ f \\_ s. domain_fields_equiv st s\" + "\st. \\s. globals_equiv_scheduler st s \ Q s\ f \\_ s. globals_equiv_scheduler st s\" + "\st. \\s. silc_dom_equiv aag st s \ Q s\ f \\_ s. silc_dom_equiv aag st s\" + shows "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (P (\x. pasObjectAbs aag x \ reads_scheduler aag l) and Q) f" + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_equiv_def + apply (wpsimp wp: inv) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym)[2] + unfolding midstrength_scheduler_affects_equiv_def + apply (rule equiv_valid_inv_A_conjI) + apply (rule_tac equiv_valid_guard_imp) + apply (insert ev)[1] + apply fastforce + apply (clarsimp simp: comp_def) + apply (rule_tac Q=Q and Q'=Q in equiv_valid_2_guard_imp) + apply (rule equiv_valid_rv_inv_lift) + apply (wpsimp wp: inv hoare_vcg_imp_lift)+ + apply auto + done + +lemma lazy_fpu_restore_unobservable: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_equiv aag st and scheduler_affects_equiv aag l st and + invs and cur_fpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + lazy_fpu_restore t + \\_ s. scheduler_affects_equiv aag l st s\" + by (wpsimp wp: set_vm_root_scheduler_affects_equiv + lazy_fpu_restore_scheduler_affects_equiv + vcpu_switch_scheduler_affects_equiv) + +lemma midstrength_cur_domain_unobservable': + "reads_respects_scheduler aag l (P and (\s. \ reads_scheduler_cur_domain aag l s)) f + \ equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + ((\s. \ reads_scheduler_cur_domain aag l s) and P) f" + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def scheduler_affects_equiv_def + equiv_valid_def2 equiv_valid_2_def midstrength_scheduler_affects_equiv_def) + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply clarsimp + apply (drule_tac x="(a,b)" in bspec,clarsimp+) + apply (drule_tac x="(aa,ba)" in bspec,clarsimp+) + done + +lemma lazy_fpu_restore_midstrength_scheduler_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + ((\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)) and invs and + pas_refined aag and valid_silc_label aag and cur_fpu_in_cur_domain) + (lazy_fpu_restore t)" + apply (rule_tac P="reads_scheduler_cur_domain aag l" in equiv_valid_cases) + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q="invs and valid_silc_label aag" in midstrength_reads_respects_scheduler_from_labels') + apply (rule equiv_valid_guard_imp) + apply (rule lazy_fpu_restore_states_equiv_valid) + apply (clarsimp simp: comp_def) + apply assumption + apply (wpsimp wp: domain_fields_equiv_lift lazy_fpu_restore_globals_equiv globals_equiv_scheduler_inv' | erule conjunct1)+ + apply (rule conjI) + apply clarsimp + apply (insert domains_distinct) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + apply (rule midstrength_cur_domain_unobservable') + apply (rule reads_respects_scheduler_unobservable'') + apply (wp_pre) + apply (rule_tac P="invs and valid_silc_label aag" in scheduler_equiv_lift') + apply (wpsimp wp: arch_switch_to_thread_globals_equiv_scheduler + lazy_fpu_restore_globals_equiv globals_equiv_scheduler_inv' + | erule conjunct1)+ + apply (wp lazy_fpu_restore_unobservable) + apply clarsimp + apply assumption + apply clarsimp + apply (rule conjI) + apply simp + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) + done + +lemma arch_switch_to_thread_midstrength_reads_respects_scheduler': + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + ((\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)) and invs and pas_refined aag and + valid_silc_label aag and cur_vcpu_in_cur_domain and cur_fpu_in_cur_domain) + (arch_switch_to_thread t)" + apply (rule_tac P="reads_scheduler_cur_domain aag l" in equiv_valid_cases) + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q="invs and valid_silc_label aag" in midstrength_reads_respects_scheduler_from_labels') + apply (rule equiv_valid_guard_imp) + apply (rule arch_switch_to_thread_states_equiv_valid) + apply (clarsimp simp: comp_def) + apply assumption + apply (wpsimp wp: domain_fields_equiv_lift arch_switch_to_thread_globals_equiv_scheduler)+ + apply (insert domains_distinct) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + prefer 2 + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) + apply (rule midstrength_cur_domain_unobservable') + apply (rule reads_respects_scheduler_unobservable'') + apply (wp_pre) + apply (rule_tac P="invs and valid_silc_label aag" in scheduler_equiv_lift') + apply (wpsimp wp: arch_switch_to_thread_globals_equiv_scheduler globals_equiv_scheduler_inv' + | erule conjunct1)+ + apply (wp arch_switch_to_thread_unobservable) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) + apply assumption + apply clarsimp + apply (rule conjI, simp) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + done + +lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_assms, wp]: + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "midstrength_reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag + and cur_vcpu_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (do _ <- arch_switch_to_thread t; + _ <- modify (cur_thread_update (\_. t)); + modify (scheduler_action_update (\_. resume_cur_thread)) + od)" + apply (rule equiv_valid_guard_imp) + apply (rule bind_ev_general) + apply (fold set_scheduler_action_def) + apply (rule store_cur_thread_fragment_midstrength_reads_respects) + apply (rule arch_switch_to_thread_midstrength_reads_respects_scheduler') + apply wpsimp+ + done + +definition cur_hyp_in_cur_domain where + "cur_hyp_in_cur_domain \ cur_vcpu_in_cur_domain" end +arch_requalify_consts cur_hyp_in_cur_domain cur_fpu_in_cur_domain + global_interpretation Scheduler_IF_2?: - Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv _ cur_hyp_in_cur_domain cur_fpu_in_cur_domain proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms[folded cur_hyp_in_cur_domain_def])?) qed +(* FIXME AARCH64 IF: add comment *) hide_fact Scheduler_IF_2.globals_equiv_scheduler_inv' -requalify_facts AARCH64.globals_equiv_scheduler_inv' +arch_requalify_facts globals_equiv_scheduler_inv' end diff --git a/proof/infoflow/AARCH64/ArchSyscall_IF.thy b/proof/infoflow/AARCH64/ArchSyscall_IF.thy index 32965aafdc..098417e4d1 100644 --- a/proof/infoflow/AARCH64/ArchSyscall_IF.thy +++ b/proof/infoflow/AARCH64/ArchSyscall_IF.thy @@ -8,7 +8,7 @@ theory ArchSyscall_IF imports Syscall_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Syscall_IF_assms @@ -65,18 +65,126 @@ lemma arch_mask_irq_signal_globals_equiv[Syscall_IF_assms, wp]: "arch_mask_irq_signal irq \globals_equiv st\" by wpsimp +lemma vppi_update_valid_objs[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vppi_masked := f vcpu\) \valid_objs\" + unfolding vcpu_update_def + by (wpsimp simp: valid_vcpu_def) + +lemma vppi_update_valid_arch_state[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vppi_masked := f vcpu\) \valid_arch_state\" + unfolding vcpu_update_def + apply (wpsimp wp: set_vcpu_valid_arch_eq_hyp get_vcpu_wp) + apply (auto simp: obj_at_def opt_map_def vcpu_tcb_refs_def split: option.splits) + done + +lemma vgic_update_valid_objs[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vgic := f vcpu\) \valid_objs\" + unfolding vcpu_update_def + by (wpsimp simp: valid_vcpu_def) + +lemma vgic_update_valid_arch_state[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vgic := f vcpu\) \valid_arch_state\" + unfolding vcpu_update_def + apply (wpsimp wp: set_vcpu_valid_arch_eq_hyp get_vcpu_wp) + apply (auto simp: obj_at_def opt_map_def vcpu_tcb_refs_def split: option.splits) + done + +crunch vcpu_update + for valid_global_objs[wp]: valid_global_objs + (wp: crunch_wps simp: crunch_simps) + +lemma vppi_event_globals_equiv[wp]: + "\globals_equiv st and invs\ vppi_event irq \\_. globals_equiv st\" + unfolding vppi_event_def + apply (wpsimp wp: handle_fault_globals_equiv gts_wp hoare_vcg_all_lift hoare_drop_imps + simp: crunch_simps split_del: if_split) + apply (auto simp: valid_fault_def) + done + +lemma vgic_maintenance_globals_equiv[wp]: + "\globals_equiv st and invs\ vgic_maintenance \\_. globals_equiv st\" + unfolding vgic_maintenance_def vgic_update_lr_def vgic_update_def + apply (wpsimp wp: handle_fault_globals_equiv gts_wp hoare_vcg_all_lift hoare_drop_imps dmo_globals_equiv + split_del: if_split simp: crunch_simps valid_fault_def) + apply auto + done + lemma handle_reserved_irq_globals_equiv[Syscall_IF_assms, wp]: - "handle_reserved_irq irq \globals_equiv st\" - unfolding handle_reserved_irq_def by wpsimp + "\globals_equiv st and invs\ handle_reserved_irq irq \\_. globals_equiv st\" + unfolding handle_reserved_irq_def + by wpsimp + +(* FIXME AARCH64 IF: move *) +lemma gets_compE: + "doE x <- liftE (gets f); + m (g x) + odE = + doE x <- liftE (gets (g \ f)); + m x + odE" + by (clarsimp simp: liftE_def bind_bindE_assoc gets_def return_bindE) + +definition is_subject_cur_vcpu_2 where + "is_subject_cur_vcpu_2 aag cf \ \ptr. cf = Some (ptr,True) \ is_subject aag ptr" + +locale_abbrev is_subject_cur_vcpu where + "is_subject_cur_vcpu aag \ \s. is_subject_cur_vcpu_2 aag (arm_current_vcpu (arch_state s))" + +lemmas is_subject_cur_vcpu_def = is_subject_cur_vcpu_2_def + +lemma active_vcpu_is_subject: + "\ pas_refined aag s; is_subject aag (cur_thread s); + valid_cur_vcpu s; schact_is_rct s; ct_in_cur_domain s \ + \ is_subject_cur_vcpu aag s" + apply (prop_tac "arch_tcb_at (\itcb. itcb_vcpu itcb = active_cur_vcpu_of s) (cur_thread s) s") + apply (clarsimp simp: valid_cur_vcpu_def schact_is_rct_def) + apply (case_tac "cur_thread s = idle_thread s") + apply (auto simp: ct_in_cur_domain_resume_cur_thread_not_idle)[2] + apply (clarsimp simp: pred_tcb_at_def obj_at_def is_subject_cur_vcpu_def) + apply (clarsimp simp: active_cur_vcpu_of_def split: option.splits) + apply (erule associated_vcpu_is_subject) + apply (fastforce simp: get_tcb_ko_at obj_at_def) + apply auto + done + +lemma gets_current_vcpu_reads_respects: + "reads_respects aag l (\s. pas_refined aag s \ valid_cur_vcpu s \ schact_is_rct s + \ ct_in_cur_domain s \ is_subject aag (cur_thread s)) + (gets ((\a. \v. a = Some (v, True)) \ (arm_current_vcpu \ arch_state)))" + (is "reads_respects aag l ?P _") + apply (wpsimp wp: gets_ev''[where P="?P"]) + apply (prop_tac "equiv_hyp (aag_can_read aag) s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (drule (4) active_vcpu_is_subject)+ + apply (clarsimp simp: equiv_hyp_def equiv_for_def is_subject_cur_vcpu_def) + apply (rule iffI; erule ex_forward) + apply (erule_tac x=v in allE)+ + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (erule_tac x=v in allE)+ + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply simp + done lemma handle_vm_fault_reads_respects[Syscall_IF_assms]: - "reads_respects aag l (K (is_subject aag thread)) (handle_vm_fault thread vmfault_type)" - unfolding handle_vm_fault_def - by (cases vmfault_type; wpsimp wp: dmo_read_stval_reads_respects) + "reads_respects aag l (pas_refined aag and valid_cur_hyp and schact_is_rct and ct_in_cur_domain + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_vm_fault thread vmfault_type)" + unfolding handle_vm_fault_def fun_app_def valid_cur_hyp_def + apply (cases vmfault_type; clarsimp; subst gets_compE) + by (wpsimp wp: gets_current_vcpu_reads_respects as_user_reads_respects + dmo_getESR_reads_respects dmo_getFAR_reads_respects + dmo_addressTranslateS1_reads_respects + simp: det_getRestartPC)+ lemma handle_hypervisor_fault_reads_respects[Syscall_IF_assms]: - "reads_respects aag l \ (handle_hypervisor_fault thread hypfault_type)" - by (cases hypfault_type; wpsimp) + assumes pas_domains_distinct[wp]: "pas_domains_distinct (aag :: 'a subject_label PAS)" + shows "reads_respects aag l (invs and pas_refined aag and pas_cur_domain aag + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_hypervisor_fault thread hypfault_type)" + apply (cases hypfault_type) + apply (wpsimp wp: handle_fault_reads_respects dmo_getESR_reads_respects split_del: if_split) + apply (auto simp: valid_fault_def) + done lemma handle_vm_fault_globals_equiv[Syscall_IF_assms]: "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ @@ -86,8 +194,11 @@ lemma handle_vm_fault_globals_equiv[Syscall_IF_assms]: by (cases vmfault_type; wpsimp wp: dmo_no_mem_globals_equiv) lemma handle_hypervisor_fault_globals_equiv[Syscall_IF_assms]: - "handle_hypervisor_fault thread hypfault_type \globals_equiv st\" - by (cases hypfault_type; wpsimp) + "\globals_equiv st and invs\ handle_hypervisor_fault thread hypfault_type \\_. globals_equiv st\" + apply (cases hypfault_type) + apply (wpsimp wp: handle_fault_globals_equiv split_del: if_split)+ + apply (auto simp: valid_fault_def) + done crunch arch_activate_idle_thread, handle_spurious_irq for globals_equiv[Syscall_IF_assms, wp]: "globals_equiv st" @@ -111,19 +222,42 @@ lemma decode_asid_pool_invocation_authorised_for_globals: and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ decode_asid_pool_invocation label msg slot cap excaps \authorised_for_globals_arch_inv\, -" - unfolding authorised_for_globals_arch_inv_def decode_asid_pool_invocation_def - apply (simp add: split_def Let_def cong: if_cong split del: if_split) - apply wpsimp - done + unfolding authorised_for_globals_arch_inv_def decode_asid_pool_invocation_def Let_def + by wpsimp lemma decode_asid_control_invocation_authorised_for_globals: "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ decode_asid_control_invocation label msg slot cap excaps \authorised_for_globals_arch_inv\, -" - unfolding authorised_for_globals_arch_inv_def decode_asid_control_invocation_def - apply (simp add: split_def Let_def cong: if_cong split del: if_split) - apply wpsimp + unfolding authorised_for_globals_arch_inv_def decode_asid_control_invocation_def Let_def + by wpsimp + +definition is_pt_cap_typ :: "cap \ pt_type \ bool" where + "is_pt_cap_typ cap pt_t \ + arch_cap_fun_lift (\acap. is_PageTableCap acap \ acap_pt_type acap = pt_t) False cap" + +(* FIXME AARCH64 IF: consolidate with pt_lookup_slot_cap_to *) +lemma pt_lookup_slot_cap_to_lvl: + "\ invs s; \\(max_pt_level, pt) s; is_aligned pt (pt_bits VSRootPT_T); vptr \ user_region; + pt_lookup_slot pt vptr (ptes_of s) = Some (level, slot) \ + \ \p cap. caps_of_state s p = Some cap \ is_pt_cap_typ cap (level_type level) \ + obj_refs cap = {table_base level slot} \ s \ cap \ cap_asid cap \ None" + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (frule pt_walk_max_level) + apply (rename_tac pt_ptr asid vref) + apply (subgoal_tac "vs_lookup_table level asid vptr s = Some (level, pt_ptr)") + prefer 2 + apply (drule pt_walk_level) + apply (clarsimp simp: vs_lookup_table_def in_omonad) + apply (frule_tac level=level in valid_vspace_objs_strongD[rotated]; clarsimp) + apply (drule vs_lookup_table_target[where level=level], simp) + apply (drule valid_vs_lookupD, erule vref_for_level_user_region; clarsimp) + apply (frule (1) cap_to_pt_is_pt_cap_and_type, simp) + apply (fastforce intro: valid_objs_caps) + apply (frule pts_of_Some_alignedD, fastforce) + apply (frule caps_of_state_valid, fastforce) + apply (fastforce simp: cap_asid_def is_cap_simps is_pt_cap_typ_def) done lemma decode_frame_invocation_authorised_for_globals: @@ -132,40 +266,35 @@ lemma decode_frame_invocation_authorised_for_globals: decode_frame_invocation label msg slot cap excaps \authorised_for_globals_arch_inv\, -" unfolding authorised_for_globals_arch_inv_def authorised_for_globals_page_inv_def - decode_frame_invocation_def decode_fr_inv_map_def - apply (simp add: split_def Let_def cong: arch_cap.case_cong if_cong split del: if_split) - apply (wpsimp wp: check_vp_wpR) - apply (subgoal_tac - "(\a b. cte_wp_at (parent_for_refs (make_user_pte (addrFromPPtr x) - (attribs_from_word (msg ! 2)) - (mask_vm_rights xa - (data_to_rights (msg ! Suc 0))), - ba)) (a, b) s)", clarsimp) + decode_frame_invocation_def decode_fr_inv_map_def + apply (case_tac "invocation_type label = ArchInvocationLabel ARMPageMap \ is_FrameCap cap") + defer + apply (wpsimp simp: isPageFlushLabel_def Let_def decode_fr_inv_flush_def) + apply (simp add: is_FrameCap_def Let_def cong: arch_cap.case_cong if_cong) + apply (wpsimp wp: check_vp_wpR whenE_throwError_wp) + apply (prop_tac "\ user_vtop < msg ! 0 + mask (pageBitsForSize xb) \ msg ! 0 \ user_region") + apply (clarsimp simp: user_region_def not_le) + apply (rule user_vtop_leq_canonical_user) + apply (simp add: vmsz_aligned_def not_less) + apply (drule is_aligned_no_overflow_mask) + apply simp + apply (case_tac "msg ! 0 \ user_region") + prefer 2 + apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) apply (clarsimp simp: parent_for_refs_def cte_wp_at_caps_of_state) apply (frule vspace_for_asid_vs_lookup) - apply (frule_tac vptr="msg ! 0" in pt_lookup_slot_cap_to) - apply fastforce - apply (fastforce elim: vs_lookup_table_is_aligned) - apply (drule not_le_imp_less) - apply (frule order.strict_implies_order[where b=user_vtop]) - apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) - apply (drule canonical_below_pptr_base_user) - apply (erule below_user_vtop_canonical) - apply (clarsimp simp: vmsz_aligned_def) - apply (drule is_aligned_no_overflow_mask) - apply (clarsimp simp: user_region_def) - apply (erule (1) dual_order.trans) - apply assumption - apply (fastforce simp: is_pt_cap_def is_PageTableCap_def split: option.splits) - done + using pt_lookup_slot_cap_to_lvl[where vptr="msg ! 0"] + by (fastforce dest: vs_lookup_table_is_aligned + simp: is_pt_cap_typ_def is_PageTableCap_def + split: option.splits) lemma decode_page_table_invocation_authorised_for_globals: "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ decode_page_table_invocation label msg slot cap excaps \authorised_for_globals_arch_inv\, -" - unfolding authorised_for_globals_arch_inv_def authorised_for_globals_page_table_inv_def - decode_page_table_invocation_def decode_pt_inv_map_def + unfolding decode_page_table_invocation_def decode_pt_inv_map_def + authorised_for_globals_arch_inv_def authorised_for_globals_page_table_inv_def apply (simp add: split_def Let_def cong: arch_cap.case_cong if_cong split del: if_split) apply (wpsimp cong: if_cong wp: hoare_vcg_if_lift2) apply (clarsimp simp: pt_lookup_slot_from_level_def pt_lookup_slot_def) @@ -175,27 +304,66 @@ lemma decode_page_table_invocation_authorised_for_globals: apply (subgoal_tac "msg ! 0 \ user_region") apply (frule reachable_page_table_not_global; clarsimp?) apply (frule vs_lookup_table_is_aligned; clarsimp?) - apply (fastforce dest: global_pt_in_global_refs invs_arch_state simp: valid_arch_state_def) - apply (drule not_le_imp_less) - apply (frule order.strict_implies_order[where b=user_vtop]) - apply (drule order.strict_trans[OF _ user_vtop_pptr_base]) - apply (drule canonical_below_pptr_base_user) - apply (erule below_user_vtop_canonical) - apply clarsimp + apply (fastforce intro: user_vtop_leq_canonical_user simp: user_region_def) done +lemma decode_sgi_signal_invocation_authorised_for_globals: + "\\\ decode_sgi_signal_invocation cap + \authorised_for_globals_arch_inv\, -" + unfolding decode_sgi_signal_invocation_def authorised_for_globals_arch_inv_def + by wpsimp + +lemma decode_smc_invocation_authorised_for_globals: + "\\\ decode_smc_invocation label args acap + \authorised_for_globals_arch_inv\, -" + unfolding decode_smc_invocation_def authorised_for_globals_arch_inv_def + by wpsimp + +lemma decode_vspace_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_vspace_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding decode_vspace_invocation_def decode_vs_inv_flush_def + by (wpsimp simp: Let_def authorised_for_globals_arch_inv_def) + +lemma decode_vcpu_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_vcpu_invocation label msg cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding decode_vcpu_invocation_def decode_vcpu_set_tcb_def decode_vcpu_inject_irq_def + decode_vcpu_read_register_def decode_vcpu_write_register_def decode_vcpu_ack_vppi_def + range_check_def arch_check_irq_def authorised_for_globals_arch_inv_def + by (wpc | wpsimp wp: whenE_throwError_wp)+ + lemma decode_arch_invocation_authorised_for_globals[Syscall_IF_assms]: "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ arch_decode_invocation label msg x_slot slot cap excaps \authorised_for_globals_arch_inv\, -" unfolding arch_decode_invocation_def - by (wpsimp wp: decode_asid_pool_invocation_authorised_for_globals + by (wpsimp wp: decode_sgi_signal_invocation_authorised_for_globals + decode_smc_invocation_authorised_for_globals + decode_vspace_invocation_authorised_for_globals + decode_vcpu_invocation_authorised_for_globals + decode_asid_pool_invocation_authorised_for_globals decode_asid_control_invocation_authorised_for_globals decode_frame_invocation_authorised_for_globals decode_page_table_invocation_authorised_for_globals, fastforce) -declare arch_prepare_set_domain_inv[Syscall_IF_assms] +crunch vcpu_flush_if_current + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps simp: crunch_simps invs_arch_state) + +lemma arch_prepare_set_domain_globals_equiv[Syscall_IF_assms]: + "\globals_equiv st and invs\ arch_prepare_set_domain t new_dom \\_. globals_equiv st\" + unfolding arch_prepare_set_domain_def + by (wpsimp wp: fpu_release_globals_equiv) + +crunch arch_prepare_set_domain + for valid_arch_state[Syscall_IF_assms,wp]: valid_arch_state + (wp: hoare_drop_imps) end diff --git a/proof/infoflow/AARCH64/ArchTcb_IF.thy b/proof/infoflow/AARCH64/ArchTcb_IF.thy index a25532587f..dd39402e14 100644 --- a/proof/infoflow/AARCH64/ArchTcb_IF.thy +++ b/proof/infoflow/AARCH64/ArchTcb_IF.thy @@ -8,7 +8,7 @@ theory ArchTcb_IF imports Tcb_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Tcb_IF_assms @@ -31,7 +31,6 @@ lemma cap_ne_global_pt: apply (unfold global_refs_def) apply clarsimp apply (unfold cap_range_def) - apply (drule valid_global_arch_objs_global_ptD) apply blast done @@ -64,9 +63,23 @@ lemma arch_post_modify_registers_reads_respects_f[Tcb_IF_assms, wp]: "reads_respects_f aag l \ (arch_post_modify_registers cur t)" by wpsimp +lemma reads_equiv_valid_inv_f: + assumes a: "reads_equiv_valid_inv A aag P f" + assumes b: "\P. \P\ f \\_. P\" + shows "equiv_valid_inv (reads_equiv_f aag) A P f" + supply equiv_valid_2_def[simp] equiv_valid_def2[simp] + apply (clarsimp simp: reads_equiv_f_def) + apply (insert a, clarsimp) + apply (drule_tac x=s in spec, drule_tac x=t in spec, clarsimp) + apply (drule (1) bspec, clarsimp) + apply (drule (1) bspec, clarsimp) + apply (drule state_unchanged[OF b])+ + by simp + lemma arch_get_sanitise_register_info_reads_respects_f[Tcb_IF_assms, wp]: - "reads_respects_f aag l \ (arch_get_sanitise_register_info rv)" - by wpsimp + "reads_respects_f aag l (K (aag_can_read_or_affect aag l rv)) (arch_get_sanitise_register_info rv)" + unfolding arch_get_sanitise_register_info_def + by (wpsimp wp: reads_equiv_valid_inv_f) end @@ -79,15 +92,15 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma valid_ipc_buffer_cap_is_nondevice_page_cap: "\valid_ipc_buffer_cap cap ptr; cap \ NullCap\ \ is_nondevice_page_cap cap" by (clarsimp simp: valid_ipc_buffer_cap_def split: cap.splits arch_cap.splits) lemma is_valid_vtable_root_def2: - "is_valid_vtable_root c = (\r a. c = ArchObjectCap (PageTableCap r (Some a)))" - by (auto simp: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits) + "is_valid_vtable_root c = (\r a. c = ArchObjectCap (PageTableCap r VSRootPT_T (Some a)))" + by (auto simp: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits pt_type.splits) (* FIXME: Pretty general. Probably belongs somewhere else *) lemma invoke_tcb_thread_preservation[Tcb_IF_assms]: @@ -246,15 +259,184 @@ lemma tc_reads_respects_f[Tcb_IF_assms]: apply (clarsimp cong: conj_cong) apply (intro conjI impI allI) (* slow *) - by (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def - det_setRegister option.disc_eq_case[symmetric] - split: cap.splits arch_cap.splits option.split)+ + by (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def + det_setRegister option.disc_eq_case[symmetric] + split: cap.splits arch_cap.splits option.split pt_type.splits)+ + +crunch lazy_fpu_restore + for cdt[wp]: "\s. P (cdt s)" + and is_original_cap[wp]: "\s. P (is_original_cap s)" + and interrupt_states[wp]: "\s. P (interrupt_states s)" + and interrupt_irq_node[wp]: "\s. P (interrupt_irq_node s)" + and ready_queues[wp]: "\s. P (ready_queues s)" + and asid_pools_of[wp]: "\s. P (asid_pools_of s)" + and asid_table[wp]: "\s. P (asid_table s)" + and numlistregs[wp]: "\s. P (numlistregs s)" + and vcpu_state[wp]: "\s. P (vcpu_state (machine_state s))" + and underlying_memory[wp]: "\s. P (underlying_memory (machine_state s))" + and device_state[wp]: "\s. P (device_state (machine_state s))" + (wp: dmo_wp crunch_wps ignore: arch_thread_set) + +lemma equiv_but_for_labels_guard_imp: + "\ equiv_but_for_labels aag L' st s; L' \ L \ + \ equiv_but_for_labels aag L st s" + by (auto simp: equiv_but_for_labels_def elim!: states_equiv_for_guard_imp) + +definition is_subject_cur_fpu_2 where + "is_subject_cur_fpu_2 aag cf \ \ptr. cf = Some ptr \ is_subject aag ptr" + +locale_abbrev is_subject_cur_fpu where + "is_subject_cur_fpu aag \ \s. is_subject_cur_fpu_2 aag (arm_current_fpu_owner (arch_state s))" + +lemmas is_subject_cur_fpu_def = is_subject_cur_fpu_2_def + +lemma dmo_enableFpu_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op enableFpu)" + unfolding enableFpu_def dmo_distr + apply wpsimp + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_reads_respects)+ + done + +lemma dmo_disableFpu_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op disableFpu)" + unfolding disableFpu_def dmo_distr + apply wpsimp + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_reads_respects)+ + done + +(* FIXME AARCH64 IF: consolidate cur_fpu_of and is_arch_cur_fpu *) +lemma equiv_kheap_equiv_cur_fpu_of: + "\ equiv_for P kheap s s'; P t; valid_cur_fpu s; valid_cur_fpu s' \ + \ cur_fpu_of s t = cur_fpu_of s' t" + by (clarsimp simp: valid_cur_fpu_def equiv_for_def is_tcb_cur_fpu_def obj_at_def) + +lemma lazy_fpu_restore_reads_respects: + "reads_respects aag l (valid_cur_fpu and K (is_subject aag t)) (lazy_fpu_restore t)" + unfolding lazy_fpu_restore_def + apply (subst gets_comp) + apply (case_tac "aag_can_read_or_affect aag l t") + apply (wpsimp simp: lazy_fpu_restore_def wp: thread_get_reads_respects gets_ev'') + apply (rename_tac s s') + apply (prop_tac "valid_cur_fpu s") + apply assumption + apply (prop_tac "valid_cur_fpu s'") + apply assumption + apply clarsimp + apply (prop_tac "equiv_for (aag_can_read_or_affect aag l) kheap s s'") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_disj) + apply (clarsimp simp: equiv_kheap_equiv_cur_fpu_of) + apply wpsimp + apply (wpsimp wp: thread_get_reads_respects) + apply (wpsimp wp: thread_get_wp') + apply clarsimp + apply (rule gen_asm_ev) + apply clarsimp + done lemma arch_post_set_flags_reads_respects_f[Tcb_IF_assms]: - "reads_respects_f aag l \ (arch_post_set_flags t flags)" - unfolding arch_post_set_flags_def by wpsimp + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_f aag l (silc_inv aag st and valid_cur_fpu and K (is_subject aag t)) (arch_post_set_flags t flags)" + unfolding arch_post_set_flags_def + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: when_ev reads_respects_f[OF fpu_release_reads_respects] + reads_respects_f[OF lazy_fpu_restore_reads_respects]) + apply fastforce + done + +lemma arch_tcb_context_get_cur_fpu_update[simp]: + "arch_tcb_context_get (tcb_arch tcb\tcb_cur_fpu := fpu\) = arch_tcb_context_get (tcb_arch tcb)" + by (simp add: arch_tcb_context_get_def) + +lemma globals_equiv_fpu_owner_update[simp]: + "globals_equiv st (s\arch_state := arch_state s\arm_current_fpu_owner := t\\) = + globals_equiv st s" + by (auto simp add: globals_equiv_def idle_equiv_def) + +lemma set_arm_current_fpu_owner_globals_equiv[wp]: + "\globals_equiv st and valid_arch_state\ + set_arm_current_fpu_owner t + \\_. globals_equiv st\" + unfolding set_arm_current_fpu_owner_def arch_thread_set_is_thread_set + by (wpsimp wp: thread_set_globals_equiv thread_set_valid_arch_state hoare_vcg_all_lift hoare_drop_imps + | fastforce simp: ran_tcb_cap_cases)+ + +lemma dmo_enableFpu_globals_equiv[wp]: + "do_machine_op enableFpu \globals_equiv st\" + by (wpsimp wp: bind_wp_skip + simp: globals_equiv_def idle_equiv_def enableFpu_def dmo_distr dmo_modify_distr) + +lemma dmo_disableFpu_globals_equiv[wp]: + "do_machine_op disableFpu \globals_equiv st\" + apply (clarsimp simp: disableFpu_def dmo_distr dmo_modify_distr) + apply (rule bind_wp_skip) + apply (unfold globals_equiv_def arch_globals_equiv_def idle_equiv_def enableFpu_def)[1] + apply wpsimp + apply wpsimp + done + +lemma dmo_state_assert_inv[wp]: + "do_machine_op (state_assert f) \P\" + unfolding state_assert_def + by (wpsimp wp: dmo_wp) + +lemma dmo_readFpuState_globals_equiv[wp]: + "do_machine_op readFpuState \globals_equiv st\" + by (wpsimp simp: readFpuState_def dmo_distr dmo_modify_distr) + +lemma dmo_writeFpuState_globals_equiv[wp]: + "do_machine_op (writeFpuState fpustate) \globals_equiv st\" + apply (clarsimp simp: writeFpuState_def dmo_distr dmo_modify_distr) + apply wpsimp + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + done + +lemma as_user_getRestart_inv[wp]: + "as_user t getFPUState \P\" + unfolding getFPUState_def + by (wpsimp wp: as_user_inv) + +lemma load_fpu_state_globals_equiv[wp]: + "load_fpu_state t \globals_equiv st\" + unfolding load_fpu_state_def + by wpsimp + +lemma save_fpu_state_globals_equiv[wp]: + "\globals_equiv st and valid_arch_state and (\s. t \ idle_thread s)\ + save_fpu_state t + \\_. globals_equiv st\" + unfolding save_fpu_state_def + by wpsimp + +crunch load_fpu_state, save_fpu_state + for valid_arch_state[wp]: "valid_arch_state" + +lemma switch_local_fpu_owner_globals_equiv: + "\globals_equiv st and invs\ + switch_local_fpu_owner new_owner + \\_. globals_equiv st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: hoare_vcg_all_lift hoare_weak_lift_imp) + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_cur_fpu_def + is_tcb_cur_fpu_def live_def arch_tcb_live_def + dest: idle_no_ex_cap if_live_then_nonz_capD) + done + +lemma lazy_fpu_restore_globals_equiv: + "\globals_equiv st and invs\ + lazy_fpu_restore t + \\_. globals_equiv st\" + unfolding lazy_fpu_restore_def + by (wpsimp wp: switch_local_fpu_owner_globals_equiv hoare_drop_imps) -declare arch_post_set_flags_inv[Tcb_IF_assms] +crunch arch_post_set_flags + for globals_equiv[Tcb_IF_assms]: "globals_equiv st" + (simp: crunch_simps) end diff --git a/proof/infoflow/AARCH64/ArchUserOp_IF.thy b/proof/infoflow/AARCH64/ArchUserOp_IF.thy index 546aa12c2b..f345f94fc1 100644 --- a/proof/infoflow/AARCH64/ArchUserOp_IF.thy +++ b/proof/infoflow/AARCH64/ArchUserOp_IF.thy @@ -8,7 +8,7 @@ theory ArchUserOp_IF imports UserOp_IF begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming definition ptable_lift_s where "ptable_lift_s s \ ptable_lift (cur_thread s) s" @@ -100,10 +100,22 @@ lemma arch_globals_equiv_device_state_update[UserOp_IF_assms, simp]: arch_globals_equiv ct it kh kh' as as' ms ms'" by auto +lemma no_hyp_modify[UserOp_IF_assms]: + "\f. no_hyp (modify (\ms. ms\underlying_memory := f ms\))" + "\f. no_hyp (modify (\ms. ms\device_state := f ms\))" + "\f. no_hyp (modify (\ms. ms\machine_state_rest := f ms\))" + by wpsimp+ + +lemma no_fpu_modify[UserOp_IF_assms]: + "\f. no_fpu (modify (\ms. ms\underlying_memory := f ms\))" + "\f. no_fpu (modify (\ms. ms\device_state := f ms\))" + "\f. no_fpu (modify (\ms. ms\machine_state_rest := f ms\))" + by wpsimp+ + end -requalify_types AARCH64.user_transition_if +arch_requalify_types user_transition_if global_interpretation UserOp_IF_1?: UserOp_IF_1 proof goal_cases @@ -113,7 +125,7 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma requiv_get_pt_of_thread_eq: "\ reads_equiv aag s s'; pas_refined aag s; is_subject aag (cur_thread s); @@ -142,7 +154,7 @@ lemma requiv_get_pt_entry_eq: done lemma requiv_get_page_info_eq: - "\ reads_equiv aag s s'; pas_refined aag s; invs s; is_subject aag pt; x \ kernel_mappings; + "\ reads_equiv aag s s'; pas_refined aag s; invs s; is_subject aag pt; \asid. vs_lookup_table max_pt_level asid x s = Some (max_pt_level, pt) \ \ get_page_info (aobjs_of s) pt x = get_page_info (aobjs_of s') pt x" apply (clarsimp simp: get_page_info_def obind_def) @@ -150,12 +162,10 @@ lemma requiv_get_page_info_eq: apply (clarsimp split: option.splits) apply (case_tac "pt_lookup_slot pt x (ptes_of s') = Some (a, b)"; clarsimp) apply (frule_tac ptr=b in ptes_of_reads_equiv[rotated]) - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) - apply (prop_tac "ba = bb", clarsimp simp: pt_slot_offset_def) - apply (frule pt_walk_is_aligned) - apply (erule vs_lookup_table_is_aligned; clarsimp simp: canonical_not_kernel_is_user) - apply (erule pt_walk_is_subject, (fastforce simp: canonical_not_kernel_is_user)+) - apply (rule requiv_get_pt_entry_eq; fastforce simp: canonical_not_kernel_is_user) + apply (clarsimp simp: pt_lookup_slot_def) + apply (rule_tac pt_lookup_slot_from_level_is_subject) + apply fastforce+ + apply (rule requiv_get_pt_entry_eq; fastforce) done lemma requiv_vspace_of_thread_global_pt: @@ -166,18 +176,19 @@ lemma requiv_vspace_of_thread_global_pt: apply (erule equiv_forE) apply (prop_tac "aag_can_read aag (cur_thread s)", simp) apply (clarsimp simp: get_vspace_of_thread_def - split: option.split kernel_object.splits cap.splits arch_cap.splits) - apply (rename_tac tcb word word' word'') - apply (subgoal_tac "aag_can_read_asid aag word'") - apply (subgoal_tac "s \ ArchObjectCap (PageTableCap word (Some (word',word'')))") + split: option.split kernel_object.splits cap.splits arch_cap.splits pt_type.splits) + apply (rename_tac tcb pt asid vref) + apply (subgoal_tac "aag_can_read_asid aag asid") + apply (subgoal_tac "s \ ArchObjectCap (PageTableCap pt VSRootPT_T (Some (asid,vref)))") apply (clarsimp simp: equiv_asids_def equiv_asid_def valid_cap_def obind_def vspace_for_asid_def vspace_for_pool_def pool_for_asid_def) apply (clarsimp simp: word_gt_0 typ_at_eq_kheap_obj) - apply (drule_tac x=word' in spec) - apply (case_tac "word' = 0"; clarsimp) - apply (clarsimp simp: asid_pools_of_ko_at obj_at_def asid_low_bits_of_def opt_map_def + apply (drule_tac x=asid in spec) + apply (case_tac "asid = 0"; clarsimp) + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def) + apply (clarsimp simp: asid_low_bits_of_def opt_map_def + entry_for_asid_def entry_for_pool_def pool_for_asid_def obind_def split: option.splits) - apply (frule valid_global_arch_objs_global_ptD[OF invs_valid_global_arch_objs]) apply (drule invs_valid_global_refs) apply (drule_tac ptr="((cur_thread s), tcb_cnode_index 1)" in valid_global_refsD2[rotated]) apply (subst caps_of_state_tcb_cap_cases) @@ -187,7 +198,7 @@ lemma requiv_vspace_of_thread_global_pt: apply (simp add: cap_range_def global_refs_def) apply (cut_tac s=s and t="cur_thread s" and tcb=tcb in objs_valid_tcb_vtable) apply (fastforce simp: invs_valid_objs get_tcb_def)+ - apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag word') + apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag asid) \ state_asids_to_policy aag s") apply (frule pas_refined_Control_into_is_subject_asid) apply (fastforce simp: pas_refined_def) @@ -201,7 +212,7 @@ lemma vspace_for_asid_get_vspace_of_thread: "get_vspace_of_thread (kheap s) (arch_state s) ct \ global_pt s \ \asid. vspace_for_asid asid s = Some (get_vspace_of_thread (kheap s) (arch_state s) ct)" by (fastforce simp: get_vspace_of_thread_def - split: option.splits kernel_object.splits cap.splits arch_cap.splits) + split: option.splits kernel_object.splits cap.splits arch_cap.splits pt_type.splits) lemma pt_of_thread_same_agent: "\ pas_refined aag s; is_subject aag tcb_ptr; @@ -228,27 +239,13 @@ lemma requiv_ptable_rights_eq: \ ptable_rights_s s = ptable_rights_s s'" apply (simp add: ptable_rights_s_def) apply (rule ext) - apply (case_tac "x \ kernel_mappings") - apply (clarsimp simp: ptable_rights_def split: option.splits) - apply (rule conjI; clarsimp) - apply (frule some_get_page_info_kmapsD; - fastforce dest: invs_arch_state vspace_for_asid_get_vspace_of_thread - simp: valid_arch_state_def kernel_mappings_canonical) - apply (frule some_get_page_info_kmapsD) - apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread - simp: valid_arch_state_def kernel_mappings_canonical)[12] - apply (frule_tac r=b in some_get_page_info_kmapsD) - apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread - simp: valid_arch_state_def kernel_mappings_canonical)[12] - apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = - arm_us_global_vspace (arch_state s)") + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = global_pt s") apply (frule requiv_vspace_of_thread_global_pt) apply (auto)[4] - apply (fastforce dest: get_page_info_gpd_kmaps[rotated, rotated] + apply (fastforce dest: get_page_info_gpd_kmaps[rotated 3] simp: ptable_rights_def invs_valid_global_objs invs_arch_state split: option.splits)+ - apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = - arm_us_global_vspace (arch_state s')") + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = global_pt s'") apply (drule reads_equiv_sym) apply (frule requiv_vspace_of_thread_global_pt; fastforce simp: reads_equiv_def) apply (simp add: ptable_rights_def) @@ -265,16 +262,6 @@ lemma requiv_ptable_attrs_eq: is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \ {} \ \ ptable_attrs_s s x = ptable_attrs_s s' x" apply (simp add: ptable_attrs_s_def ptable_rights_s_def) - apply (case_tac "x \ kernel_mappings") - apply (clarsimp simp: ptable_attrs_def split: option.splits) - apply (rule conjI) - apply clarsimp - apply (frule some_get_page_info_kmapsD) - apply (auto simp: vspace_for_asid_get_vspace_of_thread ptable_rights_def)[12] - apply clarsimp - apply (frule some_get_page_info_kmapsD) - apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread - simp: valid_arch_state_def kernel_mappings_canonical ptable_rights_def)[12] apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = arm_us_global_vspace (arch_state s)") apply (frule requiv_vspace_of_thread_global_pt) @@ -282,15 +269,15 @@ lemma requiv_ptable_attrs_eq: apply (clarsimp simp: ptable_attrs_def split: option.splits) apply (rule conjI) apply clarsimp - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) - apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] apply clarsimp apply (rule conjI) - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) - apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] apply clarsimp - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) - apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = arm_us_global_vspace (arch_state s')") apply (drule reads_equiv_sym) @@ -309,16 +296,6 @@ lemma requiv_ptable_lift_eq: invs s'; is_subject aag (cur_thread s); ptable_rights_s s x \ {} \ \ ptable_lift_s s x = ptable_lift_s s' x" apply (simp add: ptable_lift_s_def ptable_rights_s_def) - apply (case_tac "x \ kernel_mappings") - apply (clarsimp simp: ptable_lift_def split: option.splits) - apply (rule conjI) - apply clarsimp - apply (frule some_get_page_info_kmapsD) - apply (auto simp: vspace_for_asid_get_vspace_of_thread ptable_rights_def)[12] - apply clarsimp - apply (frule some_get_page_info_kmapsD) - apply (auto dest: invs_arch_state vspace_for_asid_get_vspace_of_thread - simp: valid_arch_state_def kernel_mappings_canonical ptable_rights_def)[12] apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = arm_us_global_vspace (arch_state s)") apply (frule requiv_vspace_of_thread_global_pt) @@ -326,15 +303,15 @@ lemma requiv_ptable_lift_eq: apply (clarsimp simp: ptable_lift_def split: option.splits) apply (rule conjI) apply clarsimp - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) - apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] apply clarsimp apply (rule conjI) - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) - apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] apply clarsimp - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) - apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3] + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = arm_us_global_vspace (arch_state s')") apply (drule reads_equiv_sym) @@ -440,11 +417,12 @@ proof - apply (simp add: obj_bits_def)+ apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp) apply (rule arg_cong[where f = ptrFromPAddr]) - apply (subst (asm) is_aligned_ptrFromPAddr_n_eq[OF pageBitsForSize_le_canonical_bit]) - apply (subst neg_mask_add_aligned[OF _ and_mask_less']) - apply simp - apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) - apply (simp add: is_aligned_neg_mask_eq) + apply (subgoal_tac "is_aligned base (pageBitsForSize sz')") + apply (subst neg_mask_add_aligned[OF _ and_mask_less']) + apply simp + apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) + apply simp + apply (metis is_aligned_addD2 is_aligned_pptrBaseOffset ptrFromPAddr_def) apply (drule not_sym) apply (erule(5) data_at_disjoint_equiv) apply (unfold obj_range_def) @@ -452,18 +430,22 @@ proof - apply (simp add: obj_bits_def is_aligned_neg_mask)+ apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp) apply (rule arg_cong[where f = ptrFromPAddr]) - apply (subst (asm) is_aligned_ptrFromPAddr_n_eq[OF pageBitsForSize_le_canonical_bit]) - apply (rule sym) - apply (subst mask_lower_twice[symmetric]) - apply (erule less_imp_le_nat) - apply (rule arg_cong[where f = "\x. x && ~~ mask z" for z]) - apply (subst neg_mask_add_aligned[OF _ and_mask_less']) - apply simp - apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) - apply simp + apply (subgoal_tac "is_aligned base (pageBitsForSize sz')") + apply (rule sym) + apply (subst mask_lower_twice[symmetric]) + apply (erule less_imp_le_nat) + apply (rule arg_cong[where f = "\x. x && ~~ mask z" for z]) + apply (subst neg_mask_add_aligned[OF _ and_mask_less']) + apply simp + apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) + apply simp + apply (metis is_aligned_addD2 is_aligned_pptrBaseOffset ptrFromPAddr_def) done qed +lemmas bit_minus_one_leq_less = bit0.minus_one_leq_less bit1.minus_one_leq_less +lemmas bit_zero_least = bit0.zero_least bit1.zero_least + lemma level_le_2_cases: "(level :: vm_level) \ 2 \ level = 0 \ level = 1 \ level = 2" apply clarsimp @@ -475,19 +457,35 @@ lemma level_le_2_cases: apply (drule meta_mp) apply (erule order.strict_implies_not_eq) apply (drule meta_mp) - apply (rule bit0.minus_one_leq_less) + apply (rule bit_minus_one_leq_less) apply (erule order.strict_implies_order) - apply (erule bit0.zero_least) + apply (erule bit_zero_least) apply clarsimp apply clarsimp done +lemma pt_walk_vref_for_levelD: + "\ pt_walk top_level bot_level pt vref ptes = Some (level,ptr); + level \ top_level; top_level \ max_pt_level \ + \ pt_walk top_level bot_level pt (vref_for_level vref level) ptes = Some (level,ptr)" + apply (induct top_level arbitrary: pt) + apply (simp add: pt_walk.simps Let_def oapply_def) + apply (case_tac "top_level=bot_level") + apply (simp add: pt_walk.simps) + apply (erule_tac x="pptr_from_pte (the (ptes (level_type top_level) (pt_slot_offset top_level pt vref)))" + in meta_allE) + apply (subst (asm) pt_walk.simps) + apply (subst pt_walk.simps) + apply (simp add: Let_def vm_level.leq_minus1_less) + apply (clarsimp simp: obind_def split: if_splits option.splits) + apply (meson pt_walk_max_level vm_level.leq_minus1_less vm_level.zero_least) + done + lemma ptable_lift_data_consistant: assumes vs: "valid_state s" and pt_lift: "ptable_lift t s x = Some ptr" and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s" and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \ arm_us_global_vspace (arch_state s)" - "x \ kernel_mappings" shows "ptable_lift t s (x && ~~ mask (pageBitsForSize sz)) = Some (ptr && ~~ mask (pageBitsForSize sz))" proof - @@ -503,7 +501,7 @@ proof - apply (case_tac pde; clarsimp simp: pte_info_def) apply (frule pt_lookup_slot_max_pt_level) apply (frule vspace_for_asid_vs_lookup) - apply (frule canonical_not_kernel_is_user[OF misc(2)]) + apply (clarsimp split: if_splits) apply (frule_tac level=level in valid_vspace_objs_pte) apply clarsimp apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) @@ -515,39 +513,41 @@ proof - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) apply (clarsimp split: if_splits) apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2) - apply (subst (asm) table_index_max_level_slots; clarsimp?) - apply (fastforce dest: vs_lookup_table_is_aligned valid_arch_state_asid_table) + apply clarsimp apply (clarsimp simp: valid_pte_def) - apply (frule data_at_same_size; simp?) + apply (frule data_at_same_size[symmetric]; simp?) + apply (simp add: pageBitsForSize_pt_bits_left) + apply (fold vref_for_level_def) + apply (prop_tac "level_of_vmsize (vmsize_of_level level) = level") + apply (metis data_at_level pageBitsForSize_pt_bits_left) + apply clarsimp apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t) (vref_for_level x level) (ptes_of s) = Some (level, pt)") - apply (case_tac "level = max_pt_level"; clarsimp) - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) - apply (subst (asm) pt_lookup_vs_lookup_eq) - apply clarsimp - apply (clarsimp simp: vspace_for_asid_def) - apply (clarsimp simp: pt_walk.simps) - apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2 in_omonad) - apply (fold vref_for_level_def) apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) - apply (rule exI) - apply (subst pt_walk_vref_for_level_eq[where vref'=x]) - apply (fastforce dest: level_le_2_cases le_neq_trans simp: max_pt_level_def2 max_def) - apply clarsimp - apply fastforce + apply (fastforce dest: pt_walk_vref_for_levelD) + using vref_for_level_user_region apply (fastforce simp: vref_for_level_def is_aligned_mask_out_add_eq mask_AND_NOT_mask - pt_bits_left_le_canonical is_aligned_ptrFromPAddr_n_eq - elim: canonical_vref_for_levelI[unfolded vref_for_level_def] + is_aligned_ptrFromPAddr_n_eq dest: data_at_aligned) done qed +(* FIXME AARCH64 IF: override in ArchRetype_AI *) +lemma valid_vspace_objs_pte: + "\ ptes_of s pt_t p = Some pte; valid_vspace_objs s; \\ (level, table_base pt_t p) s \ + \ valid_pte level pte s" + apply (clarsimp simp: ptes_of_def in_opt_map_eq) + apply (drule (2) valid_vspace_objsD) + apply (fastforce simp: in_opt_map_eq) + apply simp + done + lemma ptable_rights_data_consistant: assumes vs: "valid_state s" and pt_lift: "ptable_lift t s x = Some ptr" and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s" and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \ - arm_us_global_vspace (arch_state s)" "x \ kernel_mappings" + arm_us_global_vspace (arch_state s)" shows "ptable_rights t s (x && ~~ mask (pageBitsForSize sz)) = ptable_rights t s x" proof - have vs': "valid_objs s \ valid_arch_state s \ valid_vspace_objs s @@ -556,48 +556,33 @@ proof - thus ?thesis using pt_lift dat vs' apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits) - apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits) + apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits if_splits) apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]]) apply (rename_tac level pt pde asid) apply (case_tac pde; clarsimp simp: pte_info_def) apply (frule pt_lookup_slot_max_pt_level) apply (frule vspace_for_asid_vs_lookup) - apply (frule canonical_not_kernel_is_user[OF misc(2)]) apply (frule_tac level=level in valid_vspace_objs_pte) apply clarsimp apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI intro: vs_lookup_level) - apply (erule disjE[OF _ _ FalseE]) - prefer 2 - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) - apply (clarsimp split: if_splits) - apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2) - apply (subst (asm) table_index_max_level_slots; clarsimp?) - apply (fastforce dest: vs_lookup_table_is_aligned valid_arch_state_asid_table) apply (clarsimp simp: valid_pte_def) - apply (frule data_at_same_size; simp?) + apply (frule data_at_same_size[symmetric]; simp?) + apply (simp add: pageBitsForSize_pt_bits_left) + apply (prop_tac "level_of_vmsize (vmsize_of_level level) = level") + apply (metis data_at_level pageBitsForSize_pt_bits_left) + apply clarsimp + apply (fold vref_for_level_def) apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t) (vref_for_level x level) (ptes_of s) = Some (level, pt)") - apply (case_tac "level = max_pt_level"; clarsimp) - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) - apply (subst (asm) pt_lookup_vs_lookup_eq) - apply clarsimp - apply (clarsimp simp: vspace_for_asid_def) - apply (clarsimp simp: pt_walk.simps) - apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2 in_omonad) - apply (fold vref_for_level_def) apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) - apply (rule exI) - apply (subst pt_walk_vref_for_level_eq[where vref'=x]) - apply (fastforce dest: level_le_2_cases le_neq_trans simp: max_pt_level_def2 max_def) - apply clarsimp - apply fastforce - apply (clarsimp simp: vref_for_level_def) - apply (fastforce dest: canonical_vref_for_levelI[unfolded vref_for_level_def] - simp: pt_bits_left_le_canonical ) - done + apply (fastforce dest: pt_walk_vref_for_levelD) + apply (rule conjI) + apply (fastforce) + apply clarsimp + using vref_for_level_user_region by fastforce qed @@ -607,20 +592,14 @@ lemma user_op_access_data_at: auth \ vspace_cap_rights_to_auth (ptable_rights tcb s x) \ \ (pasObjectAbs aag tcb, auth, pasObjectAbs aag (ptrFromPAddr (ptr && ~~ mask (pageBitsForSize sz)))) \ pasPolicy aag" - apply (case_tac "x \ kernel_mappings") - apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits) - apply (frule some_get_page_info_kmapsD) - apply (fastforce dest: invs_arch_state invs_equal_kernel_mappings - simp: valid_arch_state_def vspace_for_asid_get_vspace_of_thread - kernel_mappings_canonical vspace_cap_rights_to_auth_def)+ apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) tcb = arm_us_global_vspace (arch_state s)") apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits) - apply (frule get_page_info_gpd_kmaps[rotated, rotated]) + apply (frule get_page_info_gpd_kmaps[rotated 3]) apply (fastforce simp: invs_valid_global_objs invs_arch_state)+ - apply (frule (2) ptable_lift_data_consistant[rotated 2]) + apply (frule (1) ptable_lift_data_consistant[rotated 2]) apply fastforce apply fastforce - apply (frule (2) ptable_rights_data_consistant[rotated 2]) + apply (frule (1) ptable_rights_data_consistant[rotated 2]) apply fastforce apply fastforce apply (erule (3) user_op_access) @@ -839,12 +818,15 @@ declare valid_vspace_objs_if_def[simp] end -requalify_consts - AARCH64.do_user_op_if - AARCH64.valid_vspace_objs_if - AARCH64.context_matches_state +arch_requalify_consts + do_user_op_if + valid_vspace_objs_if + context_matches_state -requalify_facts - AARCH64.do_user_op_reads_respects_g +(* FIXME AARCH64 IF: this is currently used in do_user_op_if_reads_respects_g + where aag contains a free type variable, so this can't be a locale assumption. + Investigate whether we can tweak the interface, or otherwise add a comment. *) +arch_requalify_facts + do_user_op_reads_respects_g end diff --git a/proof/infoflow/AARCH64/Example_Valid_State.thy b/proof/infoflow/AARCH64/Example_Valid_State.thy index d9c7e5fc94..f07b67b666 100644 --- a/proof/infoflow/AARCH64/Example_Valid_State.thy +++ b/proof/infoflow/AARCH64/Example_Valid_State.thy @@ -478,7 +478,7 @@ definition Silc_caps :: cnode_contents where (the_nat_to_bl_10 5) \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0))), (the_nat_to_bl_10 318) - \ NotificationCap ntfn_ptr 0 {AllowSend} )" + \ NotificationCap ntfn_ptr 0 {AllowSend})" definition Silc_cnode :: kernel_object where "Silc_cnode \ CNode 10 Silc_caps" @@ -1216,7 +1216,7 @@ lemma silc_inv_s0: apply (intro conjI) apply (clarsimp simp: all_children_def s0_internal_def silc_dom_equiv_def equiv_for_refl) apply (clarsimp simp: all_children_def s0_internal_def silc_dom_equiv_def equiv_for_refl) - apply (clarsimp simp: Invariants_AI.cte_wp_at_caps_of_state ) + apply (clarsimp simp: Invariants_AI.cte_wp_at_caps_of_state) by (auto simp:is_transferable.simps dest:s0_caps_of_state) diff --git a/proof/infoflow/ADT_IF.thy b/proof/infoflow/ADT_IF.thy index 7dca4e18cf..fa6a2082d2 100644 --- a/proof/infoflow/ADT_IF.thy +++ b/proof/infoflow/ADT_IF.thy @@ -722,7 +722,7 @@ definition global_automaton_if :: (s_aux, Some e, s') \ do_user_opf \ e \ Interrupt} \ \ \User runs, no exception happens\ - {((s, InUserMode), (s', InUserMode) ) | s s_aux s'. (s, None, s_aux) \ get_active_irqf \ + {((s, InUserMode), (s', InUserMode)) | s s_aux s'. (s, None, s_aux) \ get_active_irqf \ (s_aux, None, s') \ do_user_opf} \ \ \Interrupt while in user mode\ {((s, InUserMode), (s', KernelEntry Interrupt)) | s s' i. (s, Some i, s') \ get_active_irqf} \ @@ -884,6 +884,82 @@ definition irq_state_next where locale ADT_IF_1 = + assumes dmo_getActiveIRQ_wp': + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False (st :: det_state) and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + and dmo_getActiveIRQ_wp: + "\\s :: det_state. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ + do_machine_op (getActiveIRQ False) + \P\" + and dmo_getActiveIRQ_valid_irq_states[wp]: + "do_machine_op (getActiveIRQ in_kernel) \\s :: det_state. valid_irq_states s\" + and deleted_irq_handler_valid_irq_states[wp]: + "deleted_irq_handler irq \\s :: det_state. valid_irq_states s\" + and arch_finalise_cap_valid_irq_states[wp]: + "arch_finalise_cap c x \\s :: det_state. valid_irq_states s\" + and arch_post_cap_deletion_valid_irq_states[wp]: + "arch_post_cap_deletion c \\s :: det_state. valid_irq_states s\" + and prepare_thread_delete_valid_irq_states[wp]: + "prepare_thread_delete ptr \\s :: det_state. valid_irq_states s\" + and cur_hyp_in_cur_domain_machine_state_update[simp]: + "\f. cur_hyp_in_cur_domain (machine_state_update f s) = cur_hyp_in_cur_domain s" + and cur_fpu_in_cur_domain_machine_state_update[simp]: + "\f. cur_fpu_in_cur_domain (machine_state_update f s) = cur_fpu_in_cur_domain s" + and thread_set_no_etcb_change_cur_fpu_in_cur_domain: + "(\P tcb. P (tcb_domain (f tcb)) = (P (tcb_domain tcb) :: bool)) \ thread_set f t' \cur_fpu_in_cur_domain\" + and thread_set_no_etcb_change_cur_hyp_in_cur_domain: + "(\P tcb. P (tcb_domain (f tcb)) = (P (tcb_domain tcb) :: bool)) \ thread_set f t' \cur_hyp_in_cur_domain\" + and thread_set_tcb_context_valid_cur_hyp[wp]: + "thread_set (tcb_arch_update (arch_tcb_context_set tc)) tcb \\s :: det_state. valid_cur_hyp s\" + and maybe_handle_interrupt_cur_hyp_in_cur_domain: + "maybe_handle_interrupt in_kernel \cur_hyp_in_cur_domain\" + and maybe_handle_interrupt_cur_fpu_in_cur_domain: + "maybe_handle_interrupt in_kernel \cur_fpu_in_cur_domain\" + and maybe_handle_interrupt_valid_cur_hyp: + "\valid_cur_hyp and invs\ maybe_handle_interrupt in_kernel \\_ s :: det_state. valid_cur_hyp s\" + and handle_event_cur_hyp_in_cur_domain[wp]: + "\cur_hyp_in_cur_domain and invs and ct_in_cur_domain and (\s. e \ Interrupt \ ct_active s) and (\s. scheduler_action s = resume_cur_thread)\ + handle_event e + \\_. cur_hyp_in_cur_domain\" + and handle_event_cur_fpu_in_cur_domain[wp]: + "\cur_fpu_in_cur_domain and einvs and (\s. e \ Interrupt \ ct_active s) and (\s. scheduler_action s = resume_cur_thread)\ + handle_event e + \\_. cur_fpu_in_cur_domain\" + and handle_event_valid_cur_hyp: + "\valid_cur_hyp and einvs and (\s. e \ Interrupt \ ct_active s) and (\s. scheduler_action s = resume_cur_thread)\ + handle_event e + \\_ s :: det_state. valid_cur_hyp s\" + and schedule_cur_hyp_in_cur_domain: + "\\s. cur_hyp_in_cur_domain s \ valid_sched s \ valid_objs s \ sym_refs (state_hyp_refs_of s)\ + schedule + \\_. cur_hyp_in_cur_domain\" + and schedule_cur_fpu_in_cur_domain: + "\\s. cur_fpu_in_cur_domain s \ valid_sched s \ valid_objs s \ sym_refs (state_hyp_refs_of s)\ + schedule + \\_. cur_fpu_in_cur_domain\" + and schedule_valid_cur_hyp: + "\valid_cur_hyp and valid_idle\ + schedule + \\_ s :: det_state. valid_cur_hyp s\" + and activate_thread_cur_hyp_in_cur_domain: + "activate_thread \cur_hyp_in_cur_domain\" + and activate_thread_cur_fpu_in_cur_domain: + "activate_thread \cur_fpu_in_cur_domain\" + and activate_thread_valid_cur_hyp: + "activate_thread \\s :: det_state. valid_cur_hyp s\" + and do_user_op_if_cur_hyp_in_cur_domain[wp]: + "do_user_op_if uop tc \cur_hyp_in_cur_domain\" + and do_user_op_if_cur_fpu_in_cur_domain[wp]: + "do_user_op_if uop tc \cur_fpu_in_cur_domain\" + and do_user_op_if_valid_cur_hyp[wp]: + "do_user_op_if uop tc \\s :: det_state. valid_cur_hyp s\" + + +locale ADT_IF_2 = ADT_IF_1 + fixes initial_aag :: "'a subject_label PAS" assumes do_user_op_if_invs[wp]: "do_user_op_if uop tc \invs and ct_running :: det_state \ bool\" @@ -928,10 +1004,10 @@ locale ADT_IF_1 = and init_arch_objects_irq_state_of_state[wp]: "\P. init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_state_of_state s)\" and getActiveIRQ_None: - "(None, s') \ fst (do_machine_op (getActiveIRQ in_kernel) (s :: det_state)) + "(None, s') \ fst (do_machine_op (getActiveIRQ False) (s :: det_state)) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" and getActiveIRQ_Some: - "(Some irq, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some irq, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some irq" and kernel_entry_if_idle_equiv: "\invs and (\s. e \ Interrupt \ ct_active s) and domain_sep_inv irqs st and idle_equiv st @@ -963,12 +1039,12 @@ locale ADT_IF_1 = and do_user_op_if_irq_measure_if: "\P. do_user_op_if uop tc \\s :: det_state. P (irq_measure_if s)\" and invoke_tcb_irq_state_inv: - "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" and reset_untyped_cap_irq_state_inv: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False sta and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" and handle_vm_fault_irq_state_of_state[wp]: @@ -979,12 +1055,8 @@ locale ADT_IF_1 = "create_cap type bits untyped dev sl \\s. P (irq_state_of_state s)\" and arch_invoke_irq_control_irq_state_of_state[wp]: "arch_invoke_irq_control ici \\s. P (irq_state_of_state s)\" - and thread_set_pas_refined: - "\ \tcb. \(getF, v)\ran tcb_cap_cases. getF (f tcb) = getF tcb; - \tcb. tcb_state (f tcb) = tcb_state tcb; - \tcb. tcb_bound_notification (f tcb) = tcb_bound_notification tcb; - \tcb. tcb_domain (f tcb) = tcb_domain tcb \ - \ thread_set f t \pas_refined aag\" + and thread_set_context_pas_refined: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" begin lemmas do_user_op_if_no_domain_caps[wp] = @@ -1000,7 +1072,7 @@ lemma kernel_entry_silc_inv[wp]: unfolding kernel_entry_if_def by (wpsimp simp: ran_tcb_cap_cases arch_tcb_update_aux2 wp: hoare_weak_lift_imp handle_event_silc_inv thread_set_silc_inv thread_set_invs_trivial - thread_set_not_state_valid_sched thread_set_pas_refined + thread_set_not_state_valid_sched thread_set_context_pas_refined | wp (once) hoare_vcg_imp_lift | force)+ lemma kernel_entry_pas_refined[wp]: @@ -1011,7 +1083,7 @@ lemma kernel_entry_pas_refined[wp]: \\_. pas_refined aag\" unfolding kernel_entry_if_def by (wpsimp simp: ran_tcb_cap_cases schact_is_rct_def arch_tcb_update_aux2 - wp: hoare_vcg_imp_lift' handle_event_pas_refined thread_set_pas_refined + wp: hoare_vcg_imp_lift' handle_event_pas_refined thread_set_context_pas_refined guarded_pas_domain_lift thread_set_invs_trivial thread_set_not_state_valid_sched)+ lemma kernel_entry_if_domain_sep_inv: @@ -1048,6 +1120,45 @@ lemma kernel_entry_if_valid_domain_list[wp]: unfolding kernel_entry_if_def by (wpsimp wp: thread_set_invs_trivial simp: ran_tcb_cap_cases arch_tcb_update_aux2) +lemma thread_set_tcb_context_ct_in_cur_domain[wp]: + "thread_set (\tcb. tcb\tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\) t \ct_in_cur_domain\" + by (wpsimp simp: thread_set_def set_object_def get_object_def) + +lemma thread_set_ct_active'[wp]: + "thread_set (\tcb. tcb\tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\) t \ct_active\" + by (simp add: arch_tcb_update_aux2 thread_set_tcb_context_update_ct_active) + +lemma kernel_entry_if_cur_fpu_in_cur_domain: + "\cur_fpu_in_cur_domain and einvs and (\s. e \ Interrupt \ ct_active s) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry_if e tc + \\_. cur_fpu_in_cur_domain\" + apply (simp add: kernel_entry_if_def) + apply (wpsimp wp: thread_set_not_state_valid_sched thread_set_no_etcb_change_cur_fpu_in_cur_domain + thread_set_invs_trivial ball_tcb_cap_casesI hoare_vcg_imp_lift') + done + +lemma kernel_entry_if_cur_hyp_in_cur_domain: + "\cur_hyp_in_cur_domain and einvs and (\s. e \ Interrupt \ ct_active s) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry_if e tc + \\_. cur_hyp_in_cur_domain\" + apply (simp add: kernel_entry_if_def) + apply (wpsimp wp: thread_set_no_etcb_change_cur_hyp_in_cur_domain thread_set_invs_trivial ball_tcb_cap_casesI + hoare_vcg_imp_lift') + apply (clarsimp simp: valid_sched_def) + done + +lemma kernel_entry_if_valid_cur_hyp: + "\valid_cur_hyp and einvs and (\s. e \ Interrupt \ ct_active s) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry_if e tc + \\_. valid_cur_hyp\" + apply (simp add: kernel_entry_if_def arch_tcb_update_aux2) + apply (wpsimp wp: handle_event_valid_cur_hyp thread_set_invs_trivial ball_tcb_cap_casesI + hoare_vcg_imp_lift' thread_set_not_state_valid_sched) + done + crunch schedule_if for pas_refined[wp]: "pas_refined aag" @@ -1082,7 +1193,12 @@ lemma handle_preemption_if_invs: by (wpsimp wp: handle_spurious_irq_invs) -context ADT_IF_1 begin +context ADT_IF_2 begin + +crunch handle_preemption_if + for cur_hyp_in_cur_domain: cur_hyp_in_cur_domain + and cur_fpu_in_cur_domain: cur_fpu_in_cur_domain + and valid_cur_hyp: "\s :: det_state. valid_cur_hyp s" lemma handle_kernel_interrupt_domain_sep_inv: "\domain_sep_inv irqs st and K (irq \ non_kernel_IRQs)\ @@ -1113,7 +1229,7 @@ lemma handle_kernel_interrupt_pas_refined: apply (rule conjI; rule impI;rule hoare_pre) apply ((wp send_signal_pas_refined get_cap_wp handle_reserved_irq_non_kernel_IRQs | wpc - | simp add: get_irq_slot_def get_irq_state_def )+) + | simp add: get_irq_slot_def get_irq_state_def)+) done lemma handle_preemption_if_pas_refined[wp]: @@ -1134,9 +1250,11 @@ end lemma handle_preemption_if_silc_inv[wp]: - "handle_preemption_if tc \silc_inv aag st\" + "\silc_inv aag st and domain_sep_inv False st\ + handle_preemption_if tc + \\_. silc_inv aag st\" unfolding handle_preemption_if_def maybe_handle_interrupt_def - by (wpsimp wp: handle_interrupt_silc_inv do_machine_op_silc_inv) + by (wpsimp wp: handle_interrupt_silc_inv' do_machine_op_silc_inv hoare_drop_imps) crunch handle_preemption_if for cur_domain[wp]: "\s::det_state. P (cur_domain s)" @@ -1239,7 +1357,7 @@ lemma set_thread_state_scheduler_action: done -context ADT_IF_1 begin +context ADT_IF_2 begin lemma schedule_guarded_pas_domain: "\guarded_pas_domain aag and einvs and pas_refined aag\ @@ -1303,10 +1421,11 @@ crunch schedule_if and valid_list[wp]: valid_list lemma schedule_if_irq_masks: - "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ schedule_if tc \\_ s. P (irq_masks_of_state s)\" - by (simp add: schedule_if_def | wp)+ + unfolding schedule_if_def + by (wpsimp wp: schedule_irq_masks[where st=st]) definition kernel_schedule_if :: @@ -1393,16 +1512,16 @@ definition ADT_A_if :: kernel_handle_preemption_if kernel_schedule_if kernel_exit_A_if \ {(s,s'). step_restrict s'})\" + +context ADT_IF_2 begin + lemma check_active_irq_if_wp: - "\\s. P ((irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))),tc) + "\\s :: det_state. P ((irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))),tc) (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ check_active_irq_if tc \P\" by (wpsimp wp: dmo_getActiveIRQ_wp simp: check_active_irq_if_def) - -context ADT_IF_1 begin - lemma handle_preemption_if_only_timer_irq_inv[wp]: "handle_preemption_if tc \only_timer_irq_inv irq st\" by (wp only_timer_irq_inv_pres handle_preemption_if_irq_masks handle_preemption_if_domain_sep_inv @@ -1412,9 +1531,12 @@ end lemma schedule_if_only_timer_irq_inv[wp]: - "schedule_if tc \only_timer_irq_inv irq st\" - by (wp only_timer_irq_inv_pres schedule_if_irq_masks | blast)+ - + "\only_timer_irq_inv irq st and domain_sep_inv False st and valid_irq_states\ + schedule_if tc + \\_. only_timer_irq_inv irq st\" + by (wpsimp wp: only_timer_irq_inv_pres[where P="domain_sep_inv False st and valid_irq_states"] + schedule_if_irq_masks + | simp)+ subsection \Big step IF automaton\ @@ -1538,7 +1660,8 @@ locale valid_initial_state_noenabled = invariant_over_ADT_if + (* FIXME: arch-sp pas_refined (current_aag s) s \ guarded_pas_domain (current_aag s) s \ idle_equiv s0_internal s \ - valid_domain_list s \ valid_vspace_objs_if s" + valid_domain_list s \ valid_vspace_objs_if s \ valid_cur_hyp s \ + cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s" assumes Invs_s0_internal: "Invs s0_internal" assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" assumes scheduler_action_s0_internal: "scheduler_action s0_internal = resume_cur_thread" @@ -1667,7 +1790,7 @@ lemma kernel_entry_if_noIRQ_domain_time_sep_inv: \\_ s. P (domain_time s)\" by (wpsimp wp: kernel_entry_if_noIRQ_domain_time_inv simp: no_domain_caps_strg) -context ADT_IF_1 begin +context ADT_IF_2 begin lemma kernel_entry_if_domain_time_sched_action: "\\s. domain_time s > 0\ @@ -2021,9 +2144,14 @@ lemma handle_preemption_if_valid_sched[wp]: locale ADT_valid_initial_state = - ADT_IF_1 initial_aag + valid_initial_state _ _ _ initial_aag for initial_aag + ADT_IF_2 initial_aag + valid_initial_state _ _ _ initial_aag for initial_aag begin +crunch schedule_if + for cur_hyp_in_cur_domain[wp]: "cur_hyp_in_cur_domain" + and cur_fpu_in_cur_domain[wp]: "cur_fpu_in_cur_domain" + and valid_cur_hyp[wp]: "\s :: det_state. valid_cur_hyp s" + lemma invs_if_Step_ADT_A_if: notes active_from_running[simp] shows "\ invs_if s; (s,t) \ Step (ADT_A_if utf) e \ \ invs_if t" @@ -2045,6 +2173,9 @@ lemma invs_if_Step_ADT_A_if: kernel_entry_if_idle_equiv kernel_entry_if_domain_time_sched_action kernel_entry_if_noIRQ_domain_time_sep_inv + kernel_entry_if_cur_hyp_in_cur_domain + kernel_entry_if_cur_fpu_in_cur_domain + kernel_entry_if_valid_cur_hyp hoare_false_imp ct_idle_lift | clarsimp intro!: guarded_pas_is_subject_current_aag[rule_format] | intro conjI)+ @@ -2075,6 +2206,9 @@ lemma invs_if_Step_ADT_A_if: kernel_entry_if_domain_sep_inv kernel_entry_if_guarded_pas_domain kernel_entry_if_domain_time_sched_action kernel_entry_if_noIRQ_domain_time_sep_inv + kernel_entry_if_cur_hyp_in_cur_domain + kernel_entry_if_cur_fpu_in_cur_domain + kernel_entry_if_valid_cur_hyp ct_idle_lift | clarsimp intro: guarded_pas_is_subject_current_aag)+ apply (rule conjI, fastforce intro!: active_from_running) @@ -2096,12 +2230,16 @@ lemma invs_if_Step_ADT_A_if: rule hoare_drop_imps) apply (wp handle_preemption_if_invs handle_preemption_if_domain_sep_inv handle_preemption_if_domain_time_sched_action - handle_preemption_if_det_inv ct_idle_lift) - apply fastforce + handle_preemption_if_det_inv ct_idle_lift + handle_preemption_if_cur_hyp_in_cur_domain + handle_preemption_if_cur_fpu_in_cur_domain + handle_preemption_if_valid_cur_hyp) + apply clarsimp apply (simp add: kernel_schedule_if_def | elim exE conjE)+ apply (erule use_valid) apply ((wp schedule_if_ct_running_or_ct_idle schedule_if_domain_time_nonzero' schedule_if_domain_time_nonzero schedule_if_det_inv hoare_false_imp + schedule_if_cur_hyp_in_cur_domain schedule_if_cur_fpu_in_cur_domain schedule_if_valid_cur_hyp | fastforce simp: invs_valid_idle)+)[2] apply (simp add: kernel_exit_A_if_def | elim exE conjE)+ apply (frule state_unchanged[OF kernel_exit_if_inv]) @@ -2121,7 +2259,7 @@ lemma invs_if_Step_ADT_A_if: apply simp apply (erule use_valid, erule use_valid[OF _ check_active_irq_if_wp]) apply (rule_tac Q'="\a. (invs and ct_running) and - (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ + (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ valid_cur_hyp b \ only_timer_irq_inv timer_irq s0_internal b \ silc_inv initial_aag s0_internal b \ pas_refined initial_aag b \ @@ -2129,7 +2267,8 @@ lemma invs_if_Step_ADT_A_if: idle_equiv s0_internal b \ domain_sep_inv False s0_internal b \ valid_domain_list b \ 0 < domain_time b \ - scheduler_action b = resume_cur_thread)" in hoare_strengthen_post) + scheduler_action b = resume_cur_thread \ + cur_hyp_in_cur_domain b \ cur_fpu_in_cur_domain b)" in hoare_strengthen_post) apply ((wp do_user_op_if_invs ct_idle_lift | simp add: ct_active_not_idle' | clarsimp)+)[2] apply (erule use_valid[OF _ check_active_irq_if_wp]) apply (simp add: ct_in_state_def) @@ -2143,7 +2282,7 @@ lemma invs_if_Step_ADT_A_if: apply simp apply (erule use_valid, erule use_valid[OF _ check_active_irq_if_wp]) apply (rule_tac Q'="\a. (invs and ct_running) and - (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ + (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ valid_cur_hyp b \ only_timer_irq_inv timer_irq s0_internal b \ silc_inv initial_aag s0_internal b \ pas_refined initial_aag b \ @@ -2151,7 +2290,8 @@ lemma invs_if_Step_ADT_A_if: idle_equiv s0_internal b \ domain_sep_inv False s0_internal b \ valid_domain_list b \ 0 < domain_time b \ - scheduler_action b = resume_cur_thread)" in hoare_strengthen_post) + scheduler_action b = resume_cur_thread \ + cur_hyp_in_cur_domain b \ cur_fpu_in_cur_domain b)" in hoare_strengthen_post) apply ((wp do_user_op_if_invs | simp | clarsimp simp: ct_active_not_idle')+)[2] apply (erule use_valid[OF _ check_active_irq_if_wp]) apply (simp add: ct_in_state_def) @@ -2311,7 +2451,7 @@ lemma next_irq_state_Suc': lemma is_irq_at_next_irq_state_dom': "is_irq_at s irq pos \ next_irq_state_dom (pos,irq_masks (machine_state s))" apply (rule next_irq_state.domintros) - apply (fastforce simp: is_irq_at_def ) + apply (fastforce simp: is_irq_at_def) done lemma is_irq_at_next_irq_state_dom: @@ -2464,23 +2604,6 @@ lemma OR_choiceE_wp: apply (fastforce split: prod.splits) done -lemma preemption_point_irq_state_inv'[wp]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ - preemption_point - \\_. irq_state_inv st\, \\_. irq_state_next st\" - apply (simp add: preemption_point_def) - apply (wpsimp wp: OR_choiceE_wp[where P'="irq_state_inv st and K(irq_is_recurring irq st)" - and P''="irq_state_inv st and K(irq_is_recurring irq st)"] - simp: reset_work_units_def)+ - apply simp - apply (wpsimp wp: OR_choiceE_wp dmo_getActiveIRQ_wp simp: reset_work_units_def)+ - apply (clarsimp simp: irq_state_inv_def) - apply (simp add: next_irq_state_Suc[OF _ recurring_next_irq_state_dom]) - apply (clarsimp simp: irq_state_next_def) - apply (simp add: next_irq_state_Suc'[OF _ recurring_next_irq_state_dom]) - apply (wp | simp add: update_work_units_def irq_state_inv_def | fastforce)+ - done - lemma validE_validE_E': "\P\ f \Q\, \E\ \ \P\ f -, \E\" apply (rule validE_validE_E) @@ -2489,9 +2612,6 @@ lemma validE_validE_E': apply simp+ done -lemmas preemption_point_irq_state_inv[wp] = validE_validE_R'[OF preemption_point_irq_state_inv'] -lemmas preemption_point_irq_state_next[wp] = validE_validE_E'[OF preemption_point_irq_state_inv'] - lemma hoare_add_postE: "\ \S\ f \\_. S'\; \P\ f \\r s. S' s \ Q r s\, \\r s. S' s \ E r s\ \ \ \P and S\ f \Q\,\E\" @@ -2504,14 +2624,47 @@ lemma hoare_add_postE: apply (assumption, simp, fastforce split: sum.splits) done + +context ADT_IF_1 begin + +lemma preemption_point_valid_irq_states[wp]: + "preemption_point \\s :: det_state. valid_irq_states s\" + unfolding preemption_point_def + by (wp OR_choiceE_wp[where P'=valid_irq_states and P''=valid_irq_states] hoare_drop_imps + | wpc | simp)+ + +crunch cap_delete + for valid_irq_states[wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemma preemption_point_irq_state_inv'[wp]: + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ + preemption_point + \\_. irq_state_inv st\, \\_. irq_state_next st\" + (is "validE ?P _ _ _") + apply (simp add: preemption_point_def) + apply (wpsimp wp: OR_choiceE_wp[where P'="?P" and P''="?P"] + simp: reset_work_units_def)+ + apply simp + apply (wpsimp wp: OR_choiceE_wp dmo_getActiveIRQ_wp'[where st=sta] simp: reset_work_units_def)+ + apply (clarsimp simp: irq_state_inv_def) + apply (simp add: next_irq_state_Suc[OF _ recurring_next_irq_state_dom]) + apply (clarsimp simp: irq_state_next_def) + apply (simp add: next_irq_state_Suc'[OF _ recurring_next_irq_state_dom]) + apply (wp | simp add: update_work_units_def irq_state_inv_def | fastforce)+ + done + +lemmas preemption_point_irq_state_inv[wp] = validE_validE_R'[OF preemption_point_irq_state_inv'] +lemmas preemption_point_irq_state_next[wp] = validE_validE_E'[OF preemption_point_irq_state_inv'] + lemma rec_del_irq_state_inv': notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del] rec_del.simps[simp del] shows - "s \ \irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "s \ \irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ rec_del call \\a s. (case call of FinaliseSlotCall x y \ y \ fst a \ snd a = NullCap | _ \ True) \ - domain_sep_inv False sta s \ irq_state_inv st s\, \\_. irq_state_next st\" + domain_sep_inv False sta s \ valid_irq_states s \ irq_state_inv st s\, \\_. irq_state_next st\" proof (induct s arbitrary: rule: rec_del.induct, simp_all only: rec_del_fails hoare_fail_any) case (1 slot exposed s) show ?case apply (simp add: split_def rec_del.simps) @@ -2536,12 +2689,13 @@ next (wp preemption_point_irq_state_inv[where irq=irq] | simp)+)[1] apply (rule spec_strengthen_postE) apply (rule "2.hyps"[simplified], fastforce+) - apply (wp finalise_cap_domain_sep_inv_cap get_cap_wp + apply (wp finalise_cap_domain_sep_inv_cap get_cap_wp finalise_cap_returns_NullCap[where irqs=False, simplified] drop_spec_validE[OF liftE_wp] set_cap_domain_sep_inv | simp add: without_preemption_def split del: if_split | wp (once) hoare_drop_imps - | wp irq_state_inv_triv)+ + | wp irq_state_inv_triv + | fastforce)+ apply (blast dest: cte_wp_at_domain_sep_inv_cap) done next @@ -2564,7 +2718,7 @@ next qed lemma rec_del_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ rec_del call \\_. irq_state_inv st\, \\_. irq_state_next st\" apply (rule hoare_strengthen_postE) @@ -2574,7 +2728,7 @@ lemma rec_del_irq_state_inv: done lemma cap_delete_irq_state_inv': - "\irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ cap_delete slot \\_. irq_state_inv st\, \\_. irq_state_next st\" by (wpsimp wp: rec_del_irq_state_inv simp: cap_delete_def) auto @@ -2585,7 +2739,7 @@ lemmas cap_delete_irq_state_next[wp] = validE_validE_E'[OF cap_delete_irq_state_ lemma cap_revoke_irq_state_inv'': notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del] shows - "s \ \irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "s \ \irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ cap_revoke slot \\_. irq_state_inv st\, \\_. irq_state_next st\" proof(induct rule: cap_revoke.induct[where ?a1.0=s]) @@ -2612,13 +2766,13 @@ lemmas cap_revoke_irq_state_inv[wp] = validE_validE_R'[OF cap_revoke_irq_state_i lemmas cap_revoke_irq_state_next[wp] = validE_validE_E'[OF cap_revoke_irq_state_inv'] lemma finalise_slot_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ finalise_slot p e \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" by (wpsimp wp: rec_del_irq_state_inv[folded validE_R_def] simp: finalise_slot_def) blast lemma invoke_cnode_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False sta + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and valid_cnode_inv cnode_invocation and K (irq_is_recurring irq st)\ invoke_cnode cnode_invocation \\_. irq_state_inv st\, \\_. irq_state_next st\" @@ -2634,6 +2788,9 @@ lemma invoke_cnode_irq_state_inv: apply fastforce done +end + + lemma checked_insert_irq_state_of_state[wp]: "check_cap_at a b (check_cap_at c d (cap_insert e f g)) \\s. P (irq_state_of_state s)\" by (wp | simp add: check_cap_at_def)+ @@ -2683,7 +2840,7 @@ lemma irq_state_inv_trivE': done -context ADT_IF_1 begin +context ADT_IF_2 begin crunch invoke_irq_control for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" @@ -2693,17 +2850,18 @@ lemma invoke_irq_control_noErr[wp]: by (cases a; wpsimp simp: arch_invoke_irq_control_noErr) lemma invoke_untyped_irq_state_inv: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) + and valid_irq_states and K (irq_is_recurring irq st)\ invoke_untyped ui \\_. irq_state_inv st\, \\_. irq_state_next st\" apply (cases ui, simp add: invoke_untyped_def mapM_x_def[symmetric]) apply (rule hoare_pre) apply (wp mapM_x_wp' whenE_wp reset_untyped_cap_irq_state_inv[where irq=irq] - | rule irq_state_inv_triv | simp)+ + | rule irq_state_inv_triv | fastforce)+ done lemma perform_invocation_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False (sta :: det_state) + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and valid_invocation op and K (irq_is_recurring irq st) and (\s. \i. op = InvokeIRQHandler i \ (\p. cte_wp_at ((=) (IRQHandlerCap (irq_of_handler_inv i))) p s))\ @@ -2713,14 +2871,16 @@ lemma perform_invocation_irq_state_inv: (solves \(wp invoke_untyped_irq_state_inv[where irq=irq] irq_state_inv_triv invoke_tcb_irq_state_inv invoke_cnode_irq_state_inv[simplified validE_R_def] | clarsimp | simp add: invoke_domain_def)+\)?) + apply wp + apply (wpsimp wp: irq_state_inv_triv' invoke_irq_control_irq_masks) + apply assumption + apply auto[1] apply wp - apply (wpsimp wp: irq_state_inv_triv' invoke_irq_control_irq_masks) + apply (wp irq_state_inv_triv' invoke_irq_handler_irq_masks | clarsimp)+ apply assumption apply auto[1] - apply wp - apply (wp irq_state_inv_triv' invoke_irq_handler_irq_masks | clarsimp)+ - apply assumption - apply auto[1] + apply (wp irq_state_inv_triv' arch_perform_invocation_irq_masks) + apply fastforce done lemma hoare_drop_impE: @@ -2769,12 +2929,16 @@ lemma handle_event_irq_state_inv: end +lemma schedule_if_irq_state_of_state[wp]: + "schedule_if tc \\s. P (irq_state_of_state s)\" + by (wpsimp simp: schedule_if_def activate_thread_def wp: hoare_drop_imps) + lemma schedule_if_irq_state_inv: - "schedule_if tc \irq_state_inv st\" - by (wp irq_state_inv_triv - | simp add: schedule_if_def activate_thread_def - | wpc - | wp (once) hoare_drop_imps)+ + "\irq_state_inv st and domain_sep_inv False st and valid_irq_states\ + schedule_if tc + \\_. irq_state_inv st\" + unfolding irq_state_inv_def + by (wpsimp wp: schedule_if_irq_masks[where st=st] | wps)+ lemma irq_measure_if_inv: assumes irq_state: @@ -2823,7 +2987,7 @@ abbreviation next_irq_state_of_state where "next_irq_state_of_state s \ next_irq_state (Suc (irq_state_of_state s)) (irq_masks_of_state s)" -context ADT_IF_1 begin +context ADT_IF_2 begin lemma kernel_entry_if_next_irq_state_of_state: "\ event \ Interrupt; invs i_s; domain_sep_inv False (st :: det_state) i_s; @@ -2841,7 +3005,7 @@ lemma kernel_entry_if_next_irq_state_of_state: thread_set_invs_trivial irq_is_recurring_triv simp: ran_tcb_cap_cases)+ apply (erule use_valid) - apply (wp | simp )+ + apply (wp | simp)+ apply (simp add: irq_state_inv_def) done @@ -2862,7 +3026,7 @@ lemma kernel_entry_if_next_irq_state_of_state_next: thread_set_invs_trivial irq_is_recurring_triv simp: ran_tcb_cap_cases)+ apply (erule use_valid) - apply (wp | simp )+ + apply (wp | simp)+ apply (simp add: irq_state_inv_def) done @@ -2888,18 +3052,20 @@ end lemma schedule_if_irq_measure_if: - "(r, b) \ fst (schedule_if uc i_s) \ irq_measure_if b \ irq_measure_if i_s" + "\ (r, b) \ fst (schedule_if uc i_s); domain_sep_inv False st i_s; valid_irq_states i_s \ + \ irq_measure_if b \ irq_measure_if i_s" apply (fold irq_measure_if_inv_def) apply (erule use_valid[OF _ irq_measure_if_inv'] | wp schedule_if_irq_state_inv | simp)+ - apply (simp add: irq_measure_if_inv_def) + apply (simp add: irq_measure_if_inv_def domain_sep_inv_refl) done lemma schedule_if_next_irq_state_of_state: - "(r, b) \ fst (schedule_if uc i_s) \ next_irq_state_of_state b = next_irq_state_of_state i_s" + "\ (r, b) \ fst (schedule_if uc i_s); domain_sep_inv False st i_s; valid_irq_states i_s \ + \ next_irq_state_of_state b = next_irq_state_of_state i_s" apply (erule use_valid) apply (rule_tac Q'="\_. irq_state_inv i_s" in hoare_strengthen_post) apply (wp schedule_if_irq_state_inv) - apply (auto simp: irq_state_inv_def) + apply (auto simp: irq_state_inv_def domain_sep_inv_refl) done lemma next_irq_state_of_state_triv: @@ -3033,11 +3199,11 @@ lemma ADT_A_if_Step_measure_if': apply (clarsimp split: if_splits) apply (rule Suc_le_lessD) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_irq_measure_if) + apply (blast intro: schedule_if_irq_measure_if invs_valid_irq_states) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_next_irq_state_of_state) + apply (blast intro: schedule_if_next_irq_state_of_state invs_valid_irq_states) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_next_irq_state_of_state) + apply (blast intro: schedule_if_next_irq_state_of_state invs_valid_irq_states) apply (clarsimp simp: kernel_exit_A_if_def split: if_splits) apply (clarsimp simp: kernel_exit_A_if_def) apply ((erule use_valid, wp | simp)+)[1] @@ -3127,7 +3293,7 @@ lemma ADT_A_if_Step_measure_if'': apply (clarsimp split: if_splits) apply (rule Suc_le_lessD) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_irq_measure_if) + apply (blast intro: schedule_if_irq_measure_if invs_valid_irq_states) apply (clarsimp simp: kernel_exit_A_if_def split: if_splits) apply (clarsimp simp: kernel_exit_A_if_def) apply ((erule use_valid, wp | simp)+)[1] @@ -3172,7 +3338,7 @@ lemma ADT_A_if_Step_irq_masks: apply (erule use_valid[OF _ handle_preemption_if_irq_masks]) apply fastforce apply (erule use_valid[OF _ schedule_if_irq_masks]) - apply fastforce + apply (blast intro: invs_valid_irq_states) apply (erule use_valid[OF _ kernel_exit_irq_masks]) apply simp done diff --git a/proof/infoflow/Arch_IF.thy b/proof/infoflow/Arch_IF.thy index 4ec8da0f3a..cc3256d8bb 100644 --- a/proof/infoflow/Arch_IF.thy +++ b/proof/infoflow/Arch_IF.thy @@ -19,7 +19,6 @@ lemmas [wp] = do_ipc_transfer_valid_arch_no_caps abbreviation irq_state_of_state :: "det_state \ nat" where "irq_state_of_state s \ irq_state (machine_state s)" - crunch cap_insert, cap_swap_for_delete for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" (wp: crunch_wps) @@ -148,18 +147,12 @@ lemma throw_on_false_reads_respects: \ reads_respects aag l P (throw_on_false ex f)" unfolding throw_on_false_def fun_app_def unlessE_def by wpsimp -lemma dmo_mol_2_reads_respects: - "reads_respects aag l \ (do_machine_op (machine_op_lift mop >>= (\ y. machine_op_lift mop')))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - by (wpsimp wp: machine_op_lift_ev)+ - lemma tl_subseteq: "set (tl xs) \ set xs" by (induct xs, auto) -abbreviation(input) aag_can_read_label where +abbreviation (input) aag_can_read_label where "aag_can_read_label aag l \ l \ subjectReads (pasPolicy aag) (pasSubject aag)" definition labels_are_invisible where @@ -167,38 +160,60 @@ definition labels_are_invisible where (\d \ L. \ aag_can_read_label aag d) \ (aag_can_affect_label aag l \ (\d \ L. d \ subjectReads (pasPolicy aag) l))" - -lemma equiv_but_for_reads_equiv: - "\ pas_domains_distinct aag; labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ +lemma equiv_but_for_reads_equiv': + "\ pas_domains_distinct aag \ equiv_for (aag_can_read_domain aag) ready_queues s s'; + labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ \ reads_equiv aag s s'" apply (simp add: reads_equiv_def2) apply (rule conjI) apply (clarsimp simp: labels_are_invisible_def equiv_but_for_labels_def) apply (rule states_equiv_forI) - apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ - apply (auto intro!: equiv_forI elim!: states_equiv_forE elim!: equiv_forD simp: o_def)[1] - apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ - apply (fastforce simp: equiv_asids_def elim: states_equiv_forE elim: equiv_forD) + apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ + apply (auto intro!: equiv_forI elim!: states_equiv_forE elim!: equiv_forD simp: o_def)[1] + apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ + apply (fastforce simp: equiv_asids_def elim: states_equiv_forE elim: equiv_forD) + apply (fastforce elim!: states_equiv_forE equiv_hyp_guard_imp) + apply (fastforce elim!: states_equiv_forE equiv_fpu_guard_imp) apply (clarsimp simp: equiv_for_def states_equiv_for_def disjoint_iff_not_equal) apply (metis pas_domains_distinct_inj) apply (fastforce simp: equiv_but_for_labels_def) done -lemma equiv_but_for_affects_equiv: - "\ pas_domains_distinct aag; labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ +lemma equiv_but_for_affects_equiv': + "\ pas_domains_distinct aag \ equiv_for (aag_can_affect_domain aag l) ready_queues s s'; + labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ \ affects_equiv aag l s s'" apply (subst affects_equiv_def2) apply (clarsimp simp: labels_are_invisible_def equiv_but_for_labels_def aag_can_affect_label_def) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE equiv_forD)+ - apply (fastforce simp: equiv_asids_def elim!: states_equiv_forE elim!: equiv_forD) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE equiv_forD)+ + apply (fastforce simp: equiv_asids_def elim!: states_equiv_forE elim!: equiv_forD) + apply (fastforce elim!: states_equiv_forE equiv_hyp_guard_imp) + apply (fastforce elim!: states_equiv_forE equiv_fpu_guard_imp) apply (clarsimp simp: equiv_for_def states_equiv_for_def disjoint_iff_not_equal) apply (metis pas_domains_distinct_inj) done +lemmas equiv_but_for_reads_equiv = equiv_but_for_reads_equiv'[OF disjI1] + and equiv_but_for_affects_equiv = equiv_but_for_affects_equiv'[OF disjI1] + +lemma equiv_for_lift: + assumes "\P. m \\s. P (f s)\" + shows "m \\s. equiv_for P f st s\" + and "m \\s. equiv_for P f s st\" + using assms + by (fastforce simp: equiv_for_def valid_def)+ + +lemma equiv_for_lift2: + assumes "\P. m \\s. P (f (g s))\" + shows "m \\s. equiv_for P f st (g s)\" + using assms + by (fastforce simp: equiv_for_def valid_def) + (* consider rewriting the return-value assumption using equiv_valid_rv_inv *) -lemma ev2_invisible: - assumes domains_distinct: "pas_domains_distinct aag" +lemma ev2_invisible': + assumes "pas_domains_distinct aag \ (\P. f \\s. P (ready_queues s)\) \ + (\P. g \\s. P (ready_queues s)\)" shows "\ labels_are_invisible aag l L; labels_are_invisible aag l L'; modifies_at_most aag L Q f; modifies_at_most aag L' Q' g; @@ -210,40 +225,63 @@ lemma ev2_invisible: apply blast apply (drule_tac s=s in modifies_at_mostD, assumption+) apply (drule_tac s=t in modifies_at_mostD, assumption+) - apply (frule (1) equiv_but_for_reads_equiv[OF domains_distinct]) - apply (frule_tac s=t in equiv_but_for_reads_equiv[OF domains_distinct], assumption) - apply (drule (1) equiv_but_for_affects_equiv[OF domains_distinct]) - apply (drule_tac s=t in equiv_but_for_affects_equiv[OF domains_distinct], assumption) - apply (blast intro: reads_equiv_trans reads_equiv_sym affects_equiv_trans affects_equiv_sym) + apply (insert assms) + apply (frule equiv_but_for_reads_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (drule equiv_but_for_affects_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (frule equiv_but_for_reads_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (rule equiv_for_sym, erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (drule equiv_but_for_affects_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (meson reads_equiv_sym reads_equiv_trans affects_equiv_sym affects_equiv_trans) done -lemma ev_invisible: +lemmas ev2_invisible = ev2_invisible'[OF disjI1] + +lemma revrv_invisible: assumes domains_distinct: "pas_domains_distinct aag" shows "\ labels_are_invisible aag l L; modifies_at_most aag L Q f; \s t. P s \ P t \ (\(rva, s') \ fst (f s). \(rvb, t') \ fst(f t). W rva rvb) \ - \ equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) - W (P and Q) (P and Q) f f" + \ reads_equiv_valid_rv_inv (affects_equiv aag l) aag W (P and Q) f" by (rule ev2_invisible[OF domains_distinct]; simp) -lemma modify_det: - "det (modify f)" - by (clarsimp simp: det_def modify_def get_def put_def bind_def) +lemma reads_respects_unit_invisible: + "\ labels_are_invisible aag l L; modifies_at_most aag L P f; \P. f \\s. P (ready_queues s)\ \ + \ reads_respects aag l P (f :: (det_state,unit) nondet_monad)" + apply (rule equiv_valid_guard_imp) + apply (simp add: equiv_valid_def2) + apply (rule ev2_invisible') + by simp+ + +lemma reads_respects_unit_cases': + "\ reads_respects aag l (P and K (aag_can_read_or_affect aag l ptr)) f; + modifies_at_most aag {pasObjectAbs aag ptr} (Q and K (\ aag_can_read_or_affect aag l ptr)) f; + \P. f \\s. P (ready_queues s)\ \ + \ reads_respects aag l (if aag_can_read_or_affect aag l ptr then P else Q) (f :: (det_state,unit) nondet_monad)" + apply (case_tac "aag_can_read_or_affect aag l ptr") + apply clarsimp + apply (rule_tac L="{pasObjectAbs aag ptr}" in reads_respects_unit_invisible) + apply (clarsimp simp: labels_are_invisible_def) + apply (clarsimp simp: modifies_at_most_def) + apply simp + done + +lemmas reads_respects_unit_cases = reads_respects_unit_cases'[OF _ modifies_at_mostI] lemma dummy_kheap_update: "st = st\kheap := kheap st\" by simp -lemma reads_affects_equiv_kheap_eq: - "\ reads_equiv aag s s'; affects_equiv aag l s s'; aag_can_affect aag l x \ aag_can_read aag x \ - \ kheap s x = kheap s' x" - by (fastforce elim: affects_equivE reads_equivE equiv_forE) - -lemma reads_affects_equiv_get_tcb_eq: - "\ aag_can_read aag t \ aag_can_affect aag l t; reads_equiv aag s s'; affects_equiv aag l s s' \ - \ get_tcb t s = get_tcb t s'" - by (fastforce simp: get_tcb_def reads_affects_equiv_kheap_eq) - lemma equiv_valid_get_assert: "equiv_valid_inv I A P f \ equiv_valid_inv I A P (get >>= (\ s. assert (g s) >>= (\ y. f)))" @@ -409,23 +447,22 @@ locale Arch_IF_1 = "\globals_equiv s and valid_arch_state\ set_endpoint ptr ep \\_. globals_equiv s\" - and set_cap_globals_equiv'': - "\globals_equiv s and valid_arch_state\ - set_cap cap p - \\_. globals_equiv s\" and set_thread_state_globals_equiv: "\globals_equiv s and valid_arch_state\ set_thread_state ref ts \\_. globals_equiv s\" - and as_user_globals_equiv: - "\f :: unit user_monad. - \globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" + and thread_set_non_idle_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" and arch_prepare_set_domain_irq_state_of_state[wp]: "arch_prepare_set_domain t new_dom \\s. P (irq_state_of_state s)\" and arch_prepare_next_domain_irq_state_of_state[wp]: "arch_prepare_next_domain \\s. P (irq_state_of_state s)\" + and equiv_hyp_machine_state_rest_update[simp]: + "\P. equiv_hyp P st (s\machine_state := ms\machine_state_rest := rest\\) = equiv_hyp P st (s\machine_state := ms\)" + and equiv_fpu_machine_state_rest_update[simp]: + "\P. equiv_fpu P st (s\machine_state := ms\machine_state_rest := rest\\) = equiv_fpu P st (s\machine_state := ms\)" begin crunch empty_slot @@ -465,7 +502,7 @@ lemma mol_states_equiv_for: apply (simp add: machine_rest_lift_def split_def) apply (wp modify_wp) apply (clarsimp simp: states_equiv_for_def equiv_asids_def) - apply (fastforce elim!: equiv_forE intro!: equiv_forI) + apply (auto elim!: equiv_forE intro!: equiv_forI) done lemma do_machine_op_mol_states_equiv_for: @@ -488,17 +525,15 @@ lemma set_mrs_reads_respects: "reads_respects aag l (K (aag_can_read aag t \ aag_can_affect aag l t)) (set_mrs t buf msgs)" apply (simp add: set_mrs_def cong: option.case_cong_weak) apply (wp mapM_x_ev' store_word_offs_reads_respects set_object_reads_respects - | wpc | simp add: split_def split del: if_split add: zipWithM_x_mapM_x)+ + | wpc | simp add: split_def split del: if_split add: zipWithM_x_mapM_x)+ apply (auto intro: reads_affects_equiv_get_tcb_eq) done -lemma cap_insert_globals_equiv'': - "\globals_equiv s and valid_global_objs and valid_arch_state\ - cap_insert new_cap src_slot dest_slot +lemma as_user_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ + as_user tptr f \\_. globals_equiv s\" - unfolding cap_insert_def - by (wpsimp wp: set_original_globals_equiv update_cdt_globals_equiv - set_cap_globals_equiv'' dxo_wp_weak hoare_drop_imps) + by (wpsimp wp: as_user_wp_thread_set_helper thread_set_non_idle_globals_equiv) lemma set_message_info_globals_equiv: "\globals_equiv s and valid_arch_state and (\s. thread \ idle_thread s)\ diff --git a/proof/infoflow/CNode_IF.thy b/proof/infoflow/CNode_IF.thy index 6f389db0b1..ec3dd5e7c5 100644 --- a/proof/infoflow/CNode_IF.thy +++ b/proof/infoflow/CNode_IF.thy @@ -46,7 +46,7 @@ lemma get_object_rev: lemma get_cap_rev: "reads_equiv_valid_inv A aag (K (aag_can_read aag (fst slot))) (get_cap slot)" unfolding get_cap_def - by (wp get_object_rev | wpc | simp add: split_def)+ + by (wpsimp wp: get_object_rev) declare if_weak_cong[cong] @@ -321,14 +321,9 @@ locale CNode_IF_1 = fixes state_ext_t :: "'s :: state_ext itself" and irq_at :: "nat \ (irq \ bool) \ irq option" assumes set_cap_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" - and dmo_getActiveIRQ_wp: - "\\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) - (s\machine_state := machine_state s\irq_state := irq_state (machine_state s) + 1\\)\ - do_machine_op (getActiveIRQ in_kernel) - \\rv s :: 's state. P rv s\" and arch_globals_equiv_irq_state_update[simp]: "arch_globals_equiv ct it kh kh' as as' ms (irq_state_update f ms') = arch_globals_equiv ct it kh kh' as as' ms ms'" @@ -340,7 +335,7 @@ crunch set_untyped_cap_as_full for globals_equiv[wp]: "globals_equiv st" lemma cap_insert_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ cap_insert new_cap src_slot dest_slot \\_. globals_equiv s\" unfolding cap_insert_def fun_app_def @@ -348,14 +343,14 @@ lemma cap_insert_globals_equiv: set_cap_globals_equiv hoare_drop_imps dxo_wp_weak) lemma cap_move_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ cap_move new_cap src_slot dest_slot \\_. globals_equiv s\" unfolding cap_move_def fun_app_def by (wpsimp wp: set_original_globals_equiv set_cdt_globals_equiv set_cap_globals_equiv dxo_wp_weak) lemma cap_swap_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ cap_swap cap1 slot1 cap2 slot2 \\_. globals_equiv s\" unfolding cap_swap_def @@ -478,12 +473,6 @@ lemma only_timer_irq_inv_determines_irq_masks: apply fastforce+ done -lemma dmo_getActiveIRQ_globals_equiv: - "\globals_equiv st\ do_machine_op (getActiveIRQ in_kernel) \\_. globals_equiv st\" - apply (wp dmo_getActiveIRQ_wp) - apply (auto simp: globals_equiv_def idle_equiv_def) - done - crunch reset_work_units, work_units_limit_reached, update_work_units for only_timer_irq_inv[wp]: "only_timer_irq_inv irq st" (simp: only_timer_irq_inv_def only_timer_irq_def irq_is_recurring_def is_irq_at_def) @@ -660,9 +649,11 @@ locale CNode_IF_3 = CNode_IF_2 + fixes aag :: "'a subject_label PAS" assumes dmo_getActiveIRQ_reads_respects: "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" + and dmo_getActiveIRQ_globals_equiv: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" begin -lemma dmo_getActiveIRQ_reads_respects_g : +lemma dmo_getActiveIRQ_reads_respects_g: "reads_respects_g aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" apply (rule equiv_valid_guard_imp[OF reads_respects_g]) apply (rule dmo_getActiveIRQ_reads_respects) @@ -736,18 +727,6 @@ lemma reads_respects_f_g: apply (fastforce intro: globals_equivI) done -lemma reads_equiv_valid_rv_inv_f: - assumes a: "reads_equiv_valid_rv_inv A aag R P f" - assumes b: "\P. \P\ f \\_. P\" - shows "equiv_valid_rv_inv (reads_equiv_f aag) A R P f" - apply (clarsimp simp: equiv_valid_2_def reads_equiv_f_def) - apply (insert a, clarsimp simp: equiv_valid_2_def) - apply (drule_tac x=s in spec, drule_tac x=t in spec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply (drule state_unchanged[OF b])+ - by simp - lemma set_cap_silc_inv': "\silc_inv aag st and (\s. \ cap_points_to_label aag cap (pasObjectAbs aag (fst slot)) \ (\lslot. lslot \ slots_holding_overlapping_caps cap s \ diff --git a/proof/infoflow/Decode_IF.thy b/proof/infoflow/Decode_IF.thy index de4b28b31a..328d1132d3 100644 --- a/proof/infoflow/Decode_IF.thy +++ b/proof/infoflow/Decode_IF.thy @@ -268,7 +268,7 @@ lemma decode_irq_control_invocation_rev: | simp add: Let_def)+ apply safe apply simp+ - apply (blast intro: aag_Control_into_owns_irq ) + apply (blast intro: aag_Control_into_owns_irq) apply (drule_tac x="caps ! 0" in bspec) apply (fastforce intro: bang_0_in_set) apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) @@ -347,7 +347,7 @@ begin lemma decode_invocation_reads_respects_f: "reads_respects_f aag l - (silc_inv aag st and pas_refined aag and valid_cap cap and invs and ct_active + (silc_inv aag st and pas_refined aag and invs and ct_active and domain_sep_inv irqs st' and cte_wp_at ((=) cap) slot and ex_cte_cap_to slot and (\s. \r\zobj_refs cap. ex_nonz_cap_to r s) diff --git a/proof/infoflow/FinalCaps.thy b/proof/infoflow/FinalCaps.thy index 64e2747f44..b46eb3a0f9 100644 --- a/proof/infoflow/FinalCaps.thy +++ b/proof/infoflow/FinalCaps.thy @@ -335,16 +335,12 @@ locale FinalCaps_1 = "arch_finalise_cap c x \silc_inv aag st\" and prepare_thread_delete_silc_inv[wp]: "prepare_thread_delete p \silc_inv aag st\" - and handle_reserved_irq_silc_inv[wp]: - "handle_reserved_irq irq \silc_inv aag st\" - and arch_mask_irq_signal_silc_inv[wp]: - "arch_mask_irq_signal irq \silc_inv aag st\" and handle_vm_fault_silc_inv[wp]: "handle_vm_fault t vmft \silc_inv aag st\" + and arch_mask_irq_signal_silc_inv[wp]: + "arch_mask_irq_signal irq \silc_inv aag st\" and handle_vm_fault_cur_thread[wp]: "\P. handle_vm_fault t vmft \\s :: det_state. P (cur_thread s)\" - and handle_hypervisor_fault_silc_inv[wp]: - "handle_hypervisor_fault t hvft \silc_inv aag st\" and arch_activate_idle_threadt_silc_inv[wp]: "arch_activate_idle_thread t \silc_inv aag st\" and arch_switch_to_idle_thread_silc_inv[wp]: @@ -2714,15 +2710,15 @@ end lemma thread_set_tcb_ipc_buffer_update_silc_inv[wp]: - "\silc_inv aag st\ - thread_set (tcb_ipc_buffer_update blah) t - \\_. silc_inv aag st\" + "thread_set (tcb_ipc_buffer_update f) t \silc_inv aag st\" by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) lemma thread_set_tcb_fault_handler_update_silc_inv[wp]: - "\silc_inv aag st\ - thread_set (tcb_fault_handler_update blah) t - \\_. silc_inv aag st\" + "thread_set (tcb_fault_handler_update f) t \silc_inv aag st\" + by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) + +lemma thread_set_tcb_arch_update_silc_inv[wp]: + "thread_set (tcb_arch_update f) t \silc_inv aag st\" by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) lemma thread_set_tcb_fault_handler_update_invs: @@ -2846,7 +2842,7 @@ lemma handle_reply_silc_inv: handle_reply \\_. silc_inv aag st\" unfolding handle_reply_def - apply (wp hoare_vcg_all_lift get_cap_wp | wpc )+ + apply (wp hoare_vcg_all_lift get_cap_wp | wpc)+ by (force dest: cap_auth_caps_of_state silc_inv_not_subject simp: cte_wp_at_caps_of_state aag_cap_auth_def cap_auth_conferred_def reply_cap_rights_to_auth_def @@ -2885,10 +2881,58 @@ crunch timer_tick, handle_yield for silc_inv[wp]: "silc_inv aag st" (simp: tcb_cap_cases_def) +end + + +locale FinalCaps_3 = FinalCaps_2 + + assumes handle_reserved_irq_silc_inv[wp]: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_. silc_inv aag st\" + and handle_hypervisor_fault_silc_inv[wp]: + "\silc_inv aag st and invs and pas_refined aag and is_subject aag o cur_thread and K (is_subject aag t)\ + handle_hypervisor_fault t hvft + \\_. silc_inv aag st\" + and handle_reserved_irq_in_kernel_inv: + "\P and K (irq \ non_kernel_IRQs)\ + handle_reserved_irq irq + \\_. P :: det_state \ bool\" +begin + lemma handle_interrupt_silc_inv: - "handle_interrupt irq \silc_inv aag st\" + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_interrupt irq + \\_. silc_inv aag st\" unfolding handle_interrupt_def by (wpsimp wp: hoare_drop_imps) +(* FIXME: cleanup *) +lemma irq_inactive_or_timer: + "\domain_sep_inv False st and Q IRQTimer and Q IRQInactive\ + get_irq_state irq + \Q\" + apply (simp add:get_irq_state_def) + apply wp + apply (clarsimp simp add: domain_sep_inv_def) + apply (drule_tac x=irq in spec) + apply (case_tac "interrupt_states st irq") + by fastforce+ + +lemma handle_interrupt_silc_inv': + "\silc_inv aag st and domain_sep_inv False st\ + handle_interrupt irq + \\_. silc_inv aag st\" + unfolding handle_interrupt_def + apply (wpsimp wp: irq_inactive_or_timer) + apply fastforce + done + +lemma handle_interrupt_in_kernel_silc_inv: + "\silc_inv aag st and K (irq \ non_kernel_IRQs)\ + handle_interrupt irq + \\_. silc_inv aag st\" + unfolding handle_interrupt_def get_irq_state_def + by (wpsimp wp: handle_reserved_irq_in_kernel_inv) + lemma handle_event_silc_inv: "\silc_inv aag st and einvs and simple_sched_action and pas_refined aag and domain_sep_inv (pasMaySendIrqs aag) st' @@ -2896,7 +2940,7 @@ lemma handle_event_silc_inv: and (\s. ct_active s \ is_subject aag (cur_thread s))\ handle_event ev \\_. silc_inv aag st\" - apply (case_tac ev; simp_all add: maybe_handle_interrupt_def) + apply (case_tac ev; simp_all add: maybe_handle_interrupt_def) by (wpsimp wp: handle_send_silc_inv[where st'=st'] handle_call_silc_inv[where st'=st'] handle_recv_silc_inv @@ -2904,7 +2948,8 @@ lemma handle_event_silc_inv: handle_interrupt_silc_inv handle_vm_fault_silc_inv handle_hypervisor_fault_silc_inv - simp: invs_valid_objs invs_mdb invs_sym_refs)+ + simp: invs_valid_objs invs_mdb invs_sym_refs + | wp (once) hoare_drop_imps)+ crunch activate_thread for silc_inv[wp]: "silc_inv aag st" @@ -2915,6 +2960,7 @@ crunch schedule ignore: set_scheduler_action simp: crunch_simps) +(* FIXME IF: delete if unused *) lemma call_kernel_silc_inv: "\silc_inv aag st and einvs and simple_sched_action and pas_refined aag and (\s. ev \ Interrupt \ ct_active s) @@ -2922,7 +2968,13 @@ lemma call_kernel_silc_inv: call_kernel ev \\_. silc_inv aag st\" unfolding call_kernel_def maybe_handle_interrupt_def - by (wpsimp wp: handle_interrupt_silc_inv handle_event_silc_inv[where st'=st']) + apply (wpsimp wp: handle_interrupt_in_kernel_silc_inv handle_event_silc_inv[where st'=st']) + apply (rule_tac Q'="\rv s. rv \ Some ` non_kernel_IRQs \ silc_inv aag st s" in hoare_strengthen_post[rotated]) + apply clarsimp + apply (wpsimp wp: getActiveIRQ_neq_non_kernel) + apply (wpsimp wp: handle_event_silc_inv[where st'=st']) + apply clarsimp + done end diff --git a/proof/infoflow/Finalise_IF.thy b/proof/infoflow/Finalise_IF.thy index 683c46a28e..2a6d1cff57 100644 --- a/proof/infoflow/Finalise_IF.thy +++ b/proof/infoflow/Finalise_IF.thy @@ -30,7 +30,7 @@ locale Finalise_IF_1 = and set_bound_notification_none_reads_respects: "pas_domains_distinct aag \ reads_respects aag l \ (set_bound_notification ref None)" and thread_set_reads_respects: - "pas_domains_distinct aag \ reads_respects aag l \ (thread_set x y)" + "reads_respects aag l \ (thread_set f thread)" and set_tcb_queue_reads_respects[wp]: "reads_respects aag l \ (set_tcb_queue d prio queue)" and set_notification_equiv_but_for_labels: @@ -38,9 +38,13 @@ locale Finalise_IF_1 = set_notification ntfnptr ntfn \\_. equiv_but_for_labels aag L st\" and prepare_thread_delete_reads_respects_f: - "reads_respects_f aag l \ (prepare_thread_delete t)" + "pas_domains_distinct aag + \ reads_respects_f aag l (silc_inv aag st and pas_refined aag and valid_arch_state + and valid_cur_fpu and K (is_subject aag thread)) + (prepare_thread_delete thread)" and arch_finalise_cap_reads_respects: - "reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + "pas_domains_distinct aag + \ reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot and K (pas_cap_cur_auth aag (ArchObjectCap cap))) (arch_finalise_cap cap is_final)" and arch_finalise_cap_makes_halted: @@ -65,7 +69,7 @@ locale Finalise_IF_1 = arch_finalise_cap acap ex \\_. globals_equiv st\" and prepare_thread_delete_globals_equiv[wp]: - "prepare_thread_delete t \globals_equiv st\" + "\globals_equiv s and invs\ prepare_thread_delete t \\_. globals_equiv s\" begin lemma set_irq_state_reads_respects: @@ -528,6 +532,13 @@ crunch set_simple_ko for sched_act[wp]: "\s. P (scheduler_action s)" (wp: crunch_wps) +lemma thread_get_reads_respects: + "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) + (thread_get f thread)" + unfolding thread_get_def fun_app_def + apply (wp gets_the_ev) + apply (auto intro: reads_affects_equiv_get_tcb_eq) + done context Finalise_IF_1 begin @@ -545,18 +556,17 @@ lemma tcb_sched_action_reads_respects: apply (simp add: tcb_sched_action_def get_tcb_queue_def) apply (subst gets_apply) apply (case_tac "aag_can_read aag t \ aag_can_affect aag l t") - apply (simp add: thread_get_def) apply wp - apply (rule_tac Q="\s. pasObjectAbs aag t \ pasDomainAbs aag (tcb_domain rv)" + apply (rule_tac Q="\s. pasObjectAbs aag t \ pasDomainAbs aag rv" in equiv_valid_guard_imp) - apply (wp gets_apply_ev') + apply (wp gets_apply_ev) apply (fastforce simp: reads_equiv_def affects_equiv_def equiv_for_def states_equiv_for_def) - apply (wp | simp)+ + apply (wp thread_get_reads_respects | simp)+ apply (intro conjI impI allI | fastforce simp: get_tcb_def elim: reads_equivE affects_equivE equiv_forE)+ apply (clarsimp simp: pas_refined_def tcb_domain_map_wellformed_aux_def split: option.splits) - apply (erule_tac x="(t, tcb_domain y)" in ballE, force) - apply (force intro: domtcbs simp: get_tcb_Some etcbs_of'_def) + apply (erule_tac x="(t, tcb_domain tcb)" in ballE, force) + apply (force intro: domtcbs simp: obj_at_def get_tcb_Some etcbs_of'_def) apply (simp add: equiv_valid_def2 thread_get_def) apply (rule equiv_valid_rv_bind) apply (wpsimp wp: equiv_valid_rv_trivial') @@ -695,14 +705,6 @@ lemma get_bound_notification_reads_respects': apply simp+ done -lemma thread_get_reads_respects: - "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) - (thread_get f thread)" - unfolding thread_get_def fun_app_def - apply (wp gets_the_ev) - apply (auto intro: reads_affects_equiv_get_tcb_eq) - done - lemma get_bound_notification_reads_respects: "reads_respects aag l (\ s. aag_can_read aag thread \ aag_can_affect aag l thread) (get_bound_notification thread)" @@ -956,7 +958,7 @@ lemma cancel_signal_owned_reads_respects: lemma as_user_get_register_reads_respects: "reads_respects aag l (K (is_subject aag thread)) (as_user thread (getRegister reg))" - by (fastforce simp: equiv_valid_guard_imp[OF as_user_reads_respects] det_getRegister) + by (wpsimp wp: as_user_reads_respects simp: det_getRegister) lemma update_restart_pc_reads_respects[wp]: assumes domains_distinct[wp]: "pas_domains_distinct aag" @@ -1040,6 +1042,14 @@ lemma deleting_irq_handler_reads_respects: by (wp cap_delete_one_reads_respects_f reads_respects_f[OF get_irq_slot_reads_respects] | simp | blast)+ +crunch unbind_notification, set_original, fast_finalise + for valid_arch_state[wp]: "valid_arch_state" + (wp: dxo_wp_weak mapM_x_wp) + +crunch suspend + for valid_arch_state[wp]: "\s :: det_state. valid_arch_state s" + (wp: mapM_x_wp_inv crunch_wps simp: crunch_simps tcb_cap_cases_def) + lemma finalise_cap_reads_respects: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows @@ -1056,7 +1066,7 @@ lemma finalise_cap_reads_respects: suspend_reads_respects_f[where st=st] deleting_irq_handler_reads_respects unbind_notification_is_subj_reads_respects unbind_maybe_notification_reads_respects - unbind_notification_invs unbind_maybe_notification_invs + unbind_notification_invs unbind_maybe_notification_invs suspend_silc_inv | simp add: when_def invs_valid_objs invs_sym_refs aag_cap_auth_def cap_auth_conferred_def cap_rights_to_auth_def cap_links_irq_def aag_has_Control_iff_owns cte_wp_at_caps_of_state @@ -1464,7 +1474,7 @@ crunch set_original lemma empty_slot_globals_equiv: "\globals_equiv st and valid_arch_state\ empty_slot s b \\_. globals_equiv st\" unfolding empty_slot_def post_cap_deletion_def - by (wpsimp wp: set_cap_globals_equiv'' set_original_globals_equiv hoare_vcg_if_lift2 + by (wpsimp wp: set_cap_globals_equiv set_original_globals_equiv hoare_vcg_if_lift2 set_cdt_globals_equiv dxo_wp_weak hoare_drop_imps hoare_vcg_all_lift) crunch fast_finalise @@ -1473,7 +1483,7 @@ crunch fast_finalise crunch cap_delete_one for globals_equiv: "globals_equiv st" - (wp: set_cap_globals_equiv'' hoare_drop_imps simp: crunch_simps unless_def) + (wp: set_cap_globals_equiv hoare_drop_imps simp: crunch_simps unless_def) (*FIXME: Lots of this stuff should be in arch *) crunch deleting_irq_handler @@ -1505,7 +1515,7 @@ lemma finalise_cap_globals_equiv: by (wp cancel_all_ipc_globals_equiv cancel_all_ipc_valid_global_objs cancel_all_signals_globals_equiv cancel_all_signals_valid_global_objs arch_finalise_cap_globals_equiv unbind_maybe_notification_globals_equiv - unbind_notification_globals_equiv liftM_wp when_def + unbind_notification_invs unbind_notification_globals_equiv liftM_wp when_def | clarsimp simp: valid_cap_def | intro impI conjI)+ end diff --git a/proof/infoflow/IRQMasks_IF.thy b/proof/infoflow/IRQMasks_IF.thy index 5dc06f4fd2..9168933851 100644 --- a/proof/infoflow/IRQMasks_IF.thy +++ b/proof/infoflow/IRQMasks_IF.thy @@ -60,8 +60,6 @@ locale IRQMasks_IF_1 = "send_signal ntfnptr badge \\s. P (irq_masks_of_state s)\" and handle_vm_fault_irq_masks[wp]: "handle_vm_fault t vmft \\s. P (irq_masks_of_state s)\" - and handle_hypervisor_fault_irq_masks[wp]: - "handle_hypervisor_fault t hvft \\s. P (irq_masks_of_state s)\" and handle_interrupt_irq_masks: "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and K (irq \ maxIRQ)\ handle_interrupt irq @@ -78,8 +76,6 @@ locale IRQMasks_IF_1 = \\rv s :: det_state. (\x. rv = Some x \ x \ maxIRQ)\" and activate_thread_irq_masks[wp]: "activate_thread \\s. P (irq_masks_of_state s)\" - and schedule_irq_masks[wp]: - "schedule \\s. P (irq_masks_of_state s)\" and handle_spurious_irq_masks[wp]: "handle_spurious_irq \\s. P (irq_masks_of_state s)\" begin @@ -287,14 +283,29 @@ locale IRQMasks_IF_2 = IRQMasks_IF_1 state_t for state_t :: "'s :: state_ext state" + assumes do_reply_transfer_irq_masks[wp]: "do_reply_transfer sender receiver slot grant \\s. P (irq_masks_of_state s)\" - and arch_perform_invocation_irq_masks[wp]: - "arch_perform_invocation i \\s. P (irq_masks_of_state s)\" + and arch_perform_invocation_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + arch_perform_invocation i + \\rv s. P (irq_masks_of_state s)\" and arch_prepare_set_domain_irq_masks_of_state[wp]: "arch_prepare_set_domain t new_dom \\s. P (irq_masks_of_state s)\" and invoke_tcb_irq_masks: "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and tcb_inv_wf tinv\ invoke_tcb tinv \\_ s. P (irq_masks_of_state s)\" + and handle_hypervisor_fault_irq_masks[wp]: + "handle_hypervisor_fault t hvft \\s. P (irq_masks_of_state s)\" + and arch_switch_to_idle_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_idle_thread \\rv s. P (irq_masks_of_state s)\" + and arch_switch_to_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_thread t + \\rv s. P (irq_masks_of_state s)\" + and arch_prepare_next_domain_irq_masks[wp]: + "arch_prepare_next_domain \\s. P (irq_masks_of_state s)\" + and arch_prepare_next_domain_valid_irq_states[wp]: + "arch_prepare_next_domain \\s :: det_state. valid_irq_states s\" begin crunch invoke_domain @@ -311,6 +322,7 @@ lemma perform_invocation_irq_masks: by (wpsimp wp: invoke_tcb_irq_masks invoke_cnode_irq_masks[where st=st] invoke_irq_control_irq_masks[where st=st] invoke_irq_handler_irq_masks[where st=st] + arch_perform_invocation_irq_masks[where st=st] | fastforce)+ lemma handle_invocation_irq_masks: @@ -349,22 +361,71 @@ lemma handle_event_irq_masks: apply wpsimp+ done -lemma call_kernel_irq_masks: - "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and einvs - and (\s. ev \ Interrupt \ ct_active s)\ - call_kernel ev +lemma switch_to_idle_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + switch_to_idle_thread \\rv s. P (irq_masks_of_state s)\" - apply (simp add: call_kernel_def maybe_handle_interrupt_def) - apply (wpsimp wp: handle_interrupt_irq_masks[where st=st]) - apply (rule_tac Q'="\rv s. P (irq_masks_of_state s) \ domain_sep_inv False st s \ - (\x. rv = Some x \ x \ maxIRQ)" in hoare_strengthen_post) - apply (wp | simp)+ - apply (rule_tac Q'="\x s. P (irq_masks_of_state s) \ domain_sep_inv False st s" - and E="E" for E in hoare_strengthen_postE) - apply (rule valid_validE) - apply (wp handle_event_irq_masks[where st=st] valid_validE[OF handle_event_domain_sep_inv] - | simp)+ - done + unfolding switch_to_idle_thread_def + by (wpsimp wp: arch_switch_to_idle_thread_irq_masks[where st=st]) + +lemma switch_to_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + switch_to_thread t + \\rv s. P (irq_masks_of_state s)\" + unfolding switch_to_thread_def + by (wpsimp wp: arch_switch_to_thread_irq_masks[where st=st]) + +lemma guarded_switch_to_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + guarded_switch_to t + \\rv s. P (irq_masks_of_state s)\" + unfolding guarded_switch_to_def + by (wpsimp wp: switch_to_thread_irq_masks[where st=st] hoare_drop_imps) + +lemma choose_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + choose_thread + \\rv s. P (irq_masks_of_state s)\" + unfolding choose_thread_def + by (wpsimp wp: guarded_switch_to_irq_masks[where st=st] + switch_to_idle_thread_irq_masks[where st=st]) + +lemma do_extended_op_irq_masks[wp]: + "do_extended_op f \\s. P (irq_masks_of_state s)\" + by (wpsimp wp: dxo_wp_weak) + +lemma do_extended_op_valid_irq_states[wp]: + "do_extended_op f \valid_irq_states\" + by (wpsimp wp: dxo_wp_weak) + +lemma valid_irq_states_domain_index_update[simp]: + "valid_irq_states (domain_index_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +lemma valid_irq_states_cur_domain_update[simp]: + "valid_irq_states (cur_domain_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch next_domain + for irq_masks[wp]: "\s. P (irq_masks_of_state s)" + and valid_irq_states[wp]: "valid_irq_states" + (simp: crunch_simps) + +lemma schedule_choose_new_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + schedule_choose_new_thread + \\rv s. P (irq_masks_of_state s)\" + unfolding schedule_choose_new_thread_def + by (wpsimp wp: choose_thread_irq_masks[where st=st]) + +lemma schedule_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + schedule + \\rv s. P (irq_masks_of_state s)\" + unfolding schedule_def + by (wpsimp wp: schedule_choose_new_thread_irq_masks[where st=st] + guarded_switch_to_irq_masks[where st=st] + hoare_drop_imps gts_wp) end diff --git a/proof/infoflow/InfoFlow.thy b/proof/infoflow/InfoFlow.thy index 39a035f50f..24936ddd2c 100644 --- a/proof/infoflow/InfoFlow.thy +++ b/proof/infoflow/InfoFlow.thy @@ -156,9 +156,35 @@ abbreviation aag_can_read_domain :: "'a PAS \ domain \ b subsection \Generic equivalence\ -definition equiv_for where +defs equiv_for_def: "equiv_for P f c c' \ \x. P x \ f c x = f c' x" +definition identical_updates_rv where + "identical_updates_rv R s t s' t' \ (\R s' t' \ (R s s' \ R t t'))" + +abbreviation identical_updates_for_rv where + "identical_updates_for_rv P R s t s' t' \ \x. P x \ identical_updates_rv R (s x) (t x) (s' x) (t' x)" + +abbreviation identical_updates_for where + "identical_updates_for P \ identical_updates_for_rv P (=)" + +abbreviation identical_updates where + "identical_updates \ identical_updates_for (\_. True)" + +lemmas identical_updates_def = identical_updates_rv_def + +abbreviation identical_kheap_updates where + "identical_kheap_updates s s' kh kh' \ identical_updates (kheap s) (kheap s') kh kh'" + +lemmas identical_kheap_updates_def = identical_updates_def + + +subsection \Arch equivalence\ + +arch_requalify_consts + equiv_hyp + equiv_fpu + subsection \Machine state equivalence\ @@ -173,14 +199,6 @@ subsection \ASID equivalence\ definition equiv_asids :: "(asid \ bool) \ det_state \ det_state \ bool" where "equiv_asids R s s' \ \asid. asid \ 0 \ R asid \ equiv_asid asid s s'" -definition identical_updates where - "identical_updates k k' kh kh' \ \x. (kh x \ kh' x \ (k x = kh x \ k' x = kh' x))" - -abbreviation identical_kheap_updates where - "identical_kheap_updates s s' kh kh' \ identical_updates (kheap s) (kheap s') kh kh'" - -lemmas identical_kheap_updates_def = identical_updates_def - subsection \Generic state equivalence\ @@ -207,7 +225,9 @@ definition states_equiv_for :: equiv_for Q interrupt_states s s' \ equiv_for Q interrupt_irq_node s s' \ equiv_for S ready_queues s s' \ - equiv_asids R s s'" + equiv_asids R s s' \ + equiv_hyp P s s' \ + equiv_fpu P s s'" (* This the main use of states_equiv_for : P is use to restrict the labels we want to consider *) abbreviation states_equiv_for_labels :: @@ -361,6 +381,9 @@ abbreviation aag_can_affect_domain where "aag_can_affect_domain aag l \ \x. aag_can_affect_label aag l \ pasDomainAbs aag x \ subjectReads (pasPolicy aag) l \ {}" +abbreviation (input) aag_can_read_or_affect where + "aag_can_read_or_affect aag l \ \x. aag_can_read aag x \ aag_can_affect aag l x" + section \reads_respects\ diff --git a/proof/infoflow/InfoFlow_IF.thy b/proof/infoflow/InfoFlow_IF.thy index 09b0885b6c..829c6e9fbb 100644 --- a/proof/infoflow/InfoFlow_IF.thy +++ b/proof/infoflow/InfoFlow_IF.thy @@ -78,6 +78,8 @@ lemma states_equiv_forI: equiv_for Q interrupt_states s s'; equiv_for Q interrupt_irq_node s s'; equiv_asids R s s'; + equiv_hyp P s s'; + equiv_fpu P s s'; equiv_for S ready_queues s s' \ \ states_equiv_for P Q R S s s'" by (auto simp: states_equiv_for_def) @@ -85,79 +87,156 @@ lemma states_equiv_forI: definition for_each_byte_of_word :: "(obj_ref \ bool) \ obj_ref \ bool" where "for_each_byte_of_word P w \ \y\{w..w + (word_size - 1)}. P y" + locale InfoFlow_IF_1 = - fixes aag :: "'a PAS" + fixes identical_hyp_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" + and identical_fpu_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" + \ \equiv_asids lemmas\ assumes equiv_asids_refl: "equiv_asids R s s" and equiv_asids_sym: "equiv_asids R s t \ equiv_asids R t s" and equiv_asids_trans: "\ equiv_asids R s t; equiv_asids R t u \ \ equiv_asids R s u" + and equiv_asids_guard_imp: + "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" and equiv_asids_identical_kheap_updates: "\ equiv_asids R s s'; identical_kheap_updates s s' kh kh' \ - \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" - and equiv_asids_False: - "(\x. P x \ False) \ equiv_asids P x y" + \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" and equiv_asids_triv: "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; arch_state t = arch_state s; arch_state t' = arch_state s' \ - \ equiv_asids R t t'" + \ equiv_asids R t t'" and equiv_asids_non_asid_pool_kheap_update: - "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ + "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" + \ \equiv_hyp lemmas\ + and equiv_hyp_refl: + "equiv_hyp P s s" + and equiv_hyp_sym: + "equiv_hyp P s t \ equiv_hyp P t s" + and equiv_hyp_trans: + "\ equiv_hyp P s t; equiv_hyp P t u \ \ equiv_hyp P s u" + and equiv_hyp_guard_imp: + "\ equiv_hyp P s s'; \x. P' x \ P x \ \ equiv_hyp P' s s'" + and equiv_hypI: + "\ \x. P x \ equiv_hyp ((=) x) s t \ + \ equiv_hyp P s t" + and equiv_hyp_triv: + "\ equiv_hyp P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_hyp P t t'" + and equiv_hyp_machine_state_update: + "\ equiv_hyp P s s'; identical_hyp_state_updates P s s' ms ms' \ + \ equiv_hyp P (s\machine_state := ms\) (s'\machine_state := ms'\)" + \ \equiv_fpu lemmas\ + and equiv_fpu_refl: + "equiv_fpu P s s" + and equiv_fpu_sym: + "equiv_fpu P s t \ equiv_fpu P t s" + and equiv_fpu_trans: + "\ equiv_fpu P s t; equiv_fpu P t u \ \ equiv_fpu P s u" + and equiv_fpu_guard_imp: + "\ equiv_fpu P s s'; \x. P' x \ P x \ \ equiv_fpu P' s s'" + and equiv_fpuI: + "\ \x. P x \ equiv_fpu ((=) x) s t \ + \ equiv_fpu P s t" + and equiv_fpu_triv: + "\ equiv_fpu P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_fpu P t t'" + and equiv_fpu_machine_state_update: + "\ equiv_fpu P s s'; identical_fpu_state_updates P s s' ms ms' \ + \ equiv_fpu P (s\machine_state := ms\) (s'\machine_state := ms'\)" + \ \globals_equiv lemmas\ and globals_equiv_refl: "globals_equiv s s" and globals_equiv_sym: "globals_equiv s t \ globals_equiv t s" and globals_equiv_trans: "\ globals_equiv s t; globals_equiv t u \ \ globals_equiv s u" - and equiv_asids_guard_imp: - "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" - and dmo_loadWord_rev: - "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) - (do_machine_op (loadWord p))" begin +lemma equiv_asids_False: + "(\x. R x \ False) \ equiv_asids R x y" + by (auto simp: equiv_asids_def) + +lemma equiv_hyp_False: + "(\x. P x \ False) \ equiv_hyp P x y" + by (fastforce intro: equiv_hypI) + +lemma equiv_fpu_False: + "(\x. P x \ False) \ equiv_fpu P x y" + by (fastforce intro: equiv_fpuI) + +lemma equiv_hyp_updates[simp]: + "\f. equiv_hyp P st (kheap_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (kheap_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (ready_queues_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (ready_queues_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (cur_thread_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (cur_thread_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (scheduler_action_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (scheduler_action_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (domain_time_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (domain_time_update f st) s = equiv_hyp P st s" + by (auto elim: equiv_hyp_triv) + +lemma equiv_fpu_updates[simp]: + "\f. equiv_fpu P st (kheap_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (kheap_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (ready_queues_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (ready_queues_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (cur_thread_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (cur_thread_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (scheduler_action_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (scheduler_action_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (domain_time_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (domain_time_update f st) s = equiv_fpu P st s" + by (auto elim: equiv_fpu_triv) + lemma states_equiv_for_machine_state_update: - "\ states_equiv_for P Q R S s s'; equiv_machine_state P kh kh' \ - \ states_equiv_for P Q R S (s\machine_state := kh\) (s'\machine_state := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv - intro: equiv_forI simp: states_equiv_for_def) + "\ states_equiv_for P Q R S s s'; equiv_machine_state P ms ms'; + identical_hyp_state_updates P s s' ms ms'; identical_fpu_state_updates P s s' ms ms' \ + \ states_equiv_for P Q R S (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (fastforce elim: equiv_forE + elim!: equiv_asids_triv equiv_hyp_machine_state_update equiv_fpu_machine_state_update + intro: equiv_forI simp: states_equiv_for_def)+ lemma states_equiv_for_cdt_update: "\ states_equiv_for P Q R S s s'; equiv_for (P \ fst) id kh kh' \ \ states_equiv_for P Q R S (s\cdt := kh\) (s'\cdt := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_cdt_list_update: "\ states_equiv_for P Q R S s s'; equiv_for (P \ fst) id (kh (cdt_list s)) (kh' (cdt_list s')) \ \ states_equiv_for P Q R S (cdt_list_update kh s) (cdt_list_update kh' s')" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_is_original_cap_update: "\ states_equiv_for P Q R S s s'; equiv_for (P \ fst) id kh kh' \ \ states_equiv_for P Q R S (s\is_original_cap := kh\) (s'\is_original_cap := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_interrupt_states_update: "\ states_equiv_for P Q R S s s'; equiv_for Q id kh kh' \ \ states_equiv_for P Q R S (s\interrupt_states := kh\) (s'\interrupt_states := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_interrupt_irq_node_update: "\ states_equiv_for P Q R S s s'; equiv_for Q id kh kh' \ \ states_equiv_for P Q R S (s\interrupt_irq_node := kh\) (s'\interrupt_irq_node := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_ready_queues_update: "\ states_equiv_for P Q R S s s'; equiv_for S id kh kh' \ \ states_equiv_for P Q R S (s\ready_queues := kh\) (s'\ready_queues := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_identical_kheap_updates: @@ -180,6 +259,8 @@ lemma states_equiv_forE: "equiv_for Q interrupt_states s s'" "equiv_for Q interrupt_irq_node s s'" "equiv_asids R s s'" + "equiv_hyp P s s'" + "equiv_fpu P s s'" "equiv_for S ready_queues s s'" using sef[simplified states_equiv_for_def] by auto @@ -249,17 +330,17 @@ context InfoFlow_IF_1 begin lemma states_equiv_for_refl: "states_equiv_for P Q R S s s" - by (auto simp: states_equiv_for_def intro: equiv_for_refl equiv_asids_refl) + by (auto simp: states_equiv_for_def intro: equiv_for_refl equiv_asids_refl equiv_hyp_refl equiv_fpu_refl) lemma states_equiv_for_sym: "states_equiv_for P Q R S s t \ states_equiv_for P Q R S t s" - by (auto simp: states_equiv_for_def intro: equiv_for_sym equiv_asids_sym simp: equiv_for_def) + by (auto simp: states_equiv_for_def intro: equiv_for_sym equiv_asids_sym simp: equiv_for_def equiv_hyp_sym equiv_fpu_sym) lemma states_equiv_for_trans: "\ states_equiv_for P Q R S s t; states_equiv_for P Q R S t u \ \ states_equiv_for P Q R S s u" by (auto simp: states_equiv_for_def - intro: equiv_for_trans equiv_asids_trans equiv_forI + intro: equiv_for_trans equiv_asids_trans equiv_hyp_trans equiv_fpu_trans equiv_forI elim: equiv_forE) end @@ -288,6 +369,19 @@ lemma equiv_asids_aag_can_read_asid: (\d \ subjectReads (pasPolicy aag) (pasSubject aag). equiv_asids (\x. d = pasASIDAbs aag x) s s')" by (auto simp: equiv_asids_def) + +context InfoFlow_IF_1 begin + +lemma equiv_hyp_aag_can_read: + "equiv_hyp (aag_can_read aag) s s' = + (\d \ subjectReads (pasPolicy aag) (pasSubject aag). equiv_hyp (\x. d = pasObjectAbs aag x) s s')" + by (fastforce intro: equiv_hypI elim: equiv_hyp_guard_imp) + +lemma equiv_fpu_aag_can_read: + "equiv_fpu (aag_can_read aag) s s' = + (\d \ subjectReads (pasPolicy aag) (pasSubject aag). equiv_fpu (\x. d = pasObjectAbs aag x) s s')" + by (fastforce intro: equiv_fpuI elim: equiv_fpu_guard_imp) + lemma reads_equiv_def2: "reads_equiv aag s s' = (states_equiv_for (aag_can_read aag) (aag_can_read_irq aag) (aag_can_read_asid aag) (aag_can_read_domain aag) s s' \ @@ -296,7 +390,8 @@ lemma reads_equiv_def2: scheduler_action s = scheduler_action s' \ work_units_completed s = work_units_completed s' \ irq_state (machine_state s) = irq_state (machine_state s'))" - by (auto simp: reads_equiv_def equiv_for_def states_equiv_for_def equiv_asids_aag_can_read_asid) + by (auto simp: reads_equiv_def equiv_for_def states_equiv_for_def + equiv_hyp_aag_can_read equiv_fpu_aag_can_read equiv_asids_aag_can_read_asid) lemma reads_equivE: assumes sef: "reads_equiv aag s s'" @@ -308,6 +403,8 @@ lemma reads_equivE: "equiv_for (aag_can_read_irq aag) interrupt_states s s'" "equiv_for (aag_can_read_irq aag) interrupt_irq_node s s'" "equiv_asids (aag_can_read_asid aag) s s'" + "equiv_hyp (aag_can_read aag) s s'" + "equiv_fpu (aag_can_read aag) s s'" "equiv_for (aag_can_read_domain aag) ready_queues s s'" "cur_thread s = cur_thread s'" "cur_domain s = cur_domain s'" @@ -316,9 +413,6 @@ lemma reads_equivE: "irq_state (machine_state s) = irq_state (machine_state s')" using sef by (auto simp: reads_equiv_def2 elim: states_equiv_forE) - -context InfoFlow_IF_1 begin - lemma globals_equiv_updates[simp]: "\f. globals_equiv st (trans_state f s) = globals_equiv st s" "\f. globals_equiv s (cdt_update f s') = globals_equiv s s'" @@ -329,8 +423,11 @@ lemma globals_equiv_updates[simp]: by (simp add: globals_equiv_def idle_equiv_def)+ lemma reads_equiv_machine_state_update: - "\ reads_equiv aag s s'; equiv_machine_state (aag_can_read aag) kh kh'; irq_state kh = irq_state kh' \ - \ reads_equiv aag (s\machine_state := kh\) (s'\machine_state := kh'\)" + "\ reads_equiv aag s s'; equiv_machine_state (aag_can_read aag) ms ms'; + irq_state ms = irq_state ms'; + identical_hyp_state_updates (aag_can_read aag) s s' ms ms'; + identical_fpu_state_updates (aag_can_read aag) s s' ms ms' \ + \ reads_equiv aag (s\machine_state := ms\) (s'\machine_state := ms'\)" by (fastforce simp: reads_equiv_def2 intro: states_equiv_for_machine_state_update) lemma states_equiv_for_non_asid_pool_kheap_update: @@ -384,18 +481,21 @@ lemma reads_equiv_ready_queues_update: lemma reads_equiv_scheduler_action_update: "reads_equiv aag s s' \ reads_equiv aag (s\scheduler_action := kh\) (s'\scheduler_action := kh\)" - by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma reads_equiv_work_units_completed_update: "reads_equiv aag s s' \ reads_equiv aag (s\work_units_completed := kh\) (s'\work_units_completed := kh\)" - by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma reads_equiv_work_units_completed_update': "reads_equiv aag s s' \ reads_equiv aag (s\work_units_completed := (f (work_units_completed s))\) (s'\work_units_completed := (f (work_units_completed s'))\)" - by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma affects_equiv_def2: "affects_equiv aag l s s' = states_equiv_for (aag_can_affect aag l) @@ -405,7 +505,7 @@ lemma affects_equiv_def2: by (auto simp: affects_equiv_def dest: equiv_forD elim!: states_equiv_forE - intro!: states_equiv_forI equiv_forI equiv_asids_False) + intro!: states_equiv_forI equiv_forI equiv_asids_False equiv_hyp_False equiv_fpu_False) lemma affects_equivE: assumes sef: "affects_equiv aag l s s'" @@ -417,13 +517,17 @@ lemma affects_equivE: "equiv_for (aag_can_affect_irq aag l) interrupt_states s s'" "equiv_for (aag_can_affect_irq aag l) interrupt_irq_node s s'" "equiv_asids (aag_can_affect_asid aag l) s s'" + "equiv_hyp (aag_can_affect aag l) s s'" + "equiv_fpu (aag_can_affect aag l) s s'" "equiv_for (aag_can_affect_domain aag l) ready_queues s s'" using sef by (auto simp: affects_equiv_def2 elim: states_equiv_forE) lemma affects_equiv_machine_state_update: - "\ affects_equiv aag l s s'; equiv_machine_state (aag_can_affect aag l) kh kh' \ - \ affects_equiv aag l (s\machine_state := kh\) (s'\machine_state := kh'\)" - by (fastforce simp: affects_equiv_def2 intro: states_equiv_for_machine_state_update) + "\ affects_equiv aag l s s'; equiv_machine_state (aag_can_affect aag l) ms ms'; + identical_hyp_state_updates (aag_can_affect aag l) s s' ms ms'; + identical_fpu_state_updates (aag_can_affect aag l) s s' ms ms' \ + \ affects_equiv aag l (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (auto simp: affects_equiv_def2 intro: states_equiv_for_machine_state_update) lemma affects_equiv_non_asid_pool_kheap_update: "\ affects_equiv aag l s s'; equiv_for (aag_can_affect aag l) id kh kh'; @@ -470,18 +574,21 @@ lemma affects_equiv_ready_queues_update: lemma affects_equiv_scheduler_action_update: "affects_equiv aag l s s' \ affects_equiv aag l (s\scheduler_action := kh\) (s'\scheduler_action := kh\)" - by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma affects_equiv_work_units_completed_update: "affects_equiv aag l s s' \ affects_equiv aag l (s\work_units_completed := kh\) (s'\work_units_completed := kh\)" - by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma affects_equiv_work_units_completed_update': "affects_equiv aag l s s' \ affects_equiv aag l (s\work_units_completed := (f (work_units_completed s))\) (s'\work_units_completed := (f (work_units_completed s'))\)" - by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) (* reads_equiv and affects_equiv want to be equivalence relations *) lemma reads_equiv_refl: @@ -601,11 +708,13 @@ lemma states_equiv_for_guard_imp: and "\x. R' x \ R x" and "\x. S' x \ S x" shows "states_equiv_for P' Q' R' S' s s'" - using assms by (auto simp: states_equiv_for_def intro: equiv_for_guard_imp equiv_asids_guard_imp) + using assms + by (auto simp: states_equiv_for_def + intro: equiv_for_guard_imp equiv_asids_guard_imp equiv_hyp_guard_imp equiv_fpu_guard_imp) lemma set_object_reads_respects: "reads_respects aag l \ (set_object ptr obj)" - apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def bind_def' get_def gets_def put_def return_def fail_def assert_def) apply (rule conjI) apply (erule reads_equiv_identical_kheap_updates) @@ -614,9 +723,6 @@ lemma set_object_reads_respects: apply (clarsimp simp: identical_kheap_updates_def) done -end - - lemma cur_subject_reads_equiv_affects_equiv: "\ pasSubject aag = l; reads_equiv aag s s' \ \ affects_equiv aag l s s'" by (auto simp: reads_equiv_def2 affects_equiv_def equiv_for_def states_equiv_for_def) @@ -633,6 +739,12 @@ lemma requiv_get_tcb_eq[intro]: \ get_tcb thread s = get_tcb thread t" by (auto simp: reads_equiv_def2 get_tcb_def elim: states_equiv_forE_kheap) +(* FIXME AARCH64 IF: delete if unused *) +lemma requiv_get_tcb_eq'[intro]: + "\ reads_equiv aag s t; aag_can_read aag thread \ + \ get_tcb thread s = get_tcb thread t" + by (auto simp: reads_equiv_def2 get_tcb_def elim: states_equiv_forE_kheap) + lemma requiv_cur_thread_eq[intro]: "reads_equiv aag s t \ cur_thread s = cur_thread t" by (simp add: reads_equiv_def2) @@ -722,9 +834,6 @@ lemma as_user_rev: apply simp_all done - -context InfoFlow_IF_1 begin - lemma gets_kheap_revrv: "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for (aag_can_read aag or aag_can_affect aag l) id) \ (gets kheap)" @@ -789,21 +898,32 @@ lemma gets_ready_queues_revrv: apply (clarsimp simp: equiv_for_def disjoint_iff_not_equal elim!: reads_equivE affects_equivE) done +lemma reads_affects_equiv_kheap_eq: + "\ reads_equiv aag s s'; affects_equiv aag l s s'; aag_can_affect aag l x \ aag_can_read aag x \ + \ kheap s x = kheap s' x" + by (fastforce elim: affects_equivE reads_equivE equiv_forE) + +lemma reads_affects_equiv_get_tcb_eq: + "\ aag_can_read aag t \ aag_can_affect aag l t; reads_equiv aag s s'; affects_equiv aag l s s' \ + \ get_tcb t s = get_tcb t s'" + by (fastforce simp: get_tcb_def reads_affects_equiv_kheap_eq) + lemma as_user_reads_respects: - "reads_respects aag l (K (det f \ is_subject aag thread)) (as_user thread f)" + "reads_respects aag l (K (det f \ aag_can_read_or_affect aag l thread)) (as_user thread f)" apply (simp add: as_user_def split_def) apply (rule gen_asm_ev) - apply (wp set_object_reads_respects select_f_ev gets_the_ev) - apply fastforce + apply (wpsimp wp: set_object_reads_respects select_f_ev gets_the_ev) + apply (drule (2) reads_affects_equiv_get_tcb_eq) + apply auto done -end - - lemma get_message_info_rev: "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_message_info ptr)" by (wpsimp wp: as_user_rev getRegister_inv simp: get_message_info_def det_getRegister) +end + + lemma syscall_rev: assumes reads_res_m_fault: "reads_equiv_valid_inv A aag P m_fault" @@ -853,56 +973,9 @@ lemma syscall_reads_respects_g: context InfoFlow_IF_1 begin -lemma do_machine_op_spec_reads_respects': - assumes equiv_dmo: - "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) - (equiv_machine_state (aag_can_affect aag l)) Q f" - assumes guard: - "\s. P s \ Q (machine_state s)" - shows - "spec_reads_respects st aag l P (do_machine_op f)" - unfolding do_machine_op_def spec_equiv_valid_def - apply (rule equiv_valid_2_guard_imp) - apply (rule_tac R'="\ rv rv'. equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv' \ equiv_irq_state rv rv'" and Q="\ r s. st = s \ Q r" and Q'="\ r s. Q r" and P="(=) st" and P'="\" in equiv_valid_2_bind) - apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) - apply (rule gen_asm_ev2_r') - apply (rule_tac R'="\ (r, ms') (r', ms''). r = r' \ equiv_machine_state (aag_can_read aag) ms' ms'' \ equiv_machine_state (aag_can_affect aag l) ms' ms'' \ equiv_irq_state ms' ms''" and Q="\ r s. st = s" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) - apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) - apply (fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update) - apply (insert equiv_dmo)[1] - apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or simp: split_def split: prod.splits simp: equiv_for_def)[1] - apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) - apply (fastforce) - apply (rule select_f_inv) - apply (rule wp_post_taut) - apply simp+ - apply (clarsimp simp: equiv_valid_2_def in_monad) - apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) - apply (wp | simp add: guard)+ - done - -(* most of the time (i.e. always except for getActiveIRQ) you'll want this rule *) -lemma do_machine_op_spec_reads_respects: - assumes equiv_dmo: - "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) (equiv_machine_state (aag_can_affect aag l)) \ f" - assumes irq_state_inv: - "\P. \\ms. P (irq_state ms)\ f \\_ ms. P (irq_state ms)\" - shows - "spec_reads_respects st aag l \ (do_machine_op f)" - apply (rule do_machine_op_spec_reads_respects'[where Q=\, simplified]) - apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) - apply (subgoal_tac "equiv_irq_state b ba", simp) - apply (insert equiv_dmo, fastforce simp: equiv_valid_def2 equiv_valid_2_def) - apply (insert irq_state_inv) - apply (drule_tac x="\ms. ms = irq_state s" in meta_spec) - apply (clarsimp simp: valid_def) - apply (frule_tac x=s in spec) - apply (erule (1) impE) - apply (drule bspec, assumption, simp) - apply (drule_tac x=t in spec, simp) - apply (drule bspec, assumption) - apply simp - done +lemma equiv_for_disj: + "equiv_for (\x. P x \ Q x) f c c' = (equiv_for P f c c' \ equiv_for Q f c c')" + by (auto simp: equiv_for_def) lemma do_machine_op_rev: assumes equiv_dmo: "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) \\ \ f" @@ -925,9 +998,6 @@ lemma do_machine_op_rev: apply wpsimp done -end - - lemma do_machine_op_spec_rev: assumes equiv_dmo: "spec_equiv_valid_inv (machine_state st) (equiv_machine_state (aag_can_read aag)) \\ \ f" @@ -969,6 +1039,18 @@ lemma do_machine_op_spec_rev: apply (wp | simp)+ done +lemma modifies_at_mostI: + assumes hoare: "\st. \P and equiv_but_for_labels aag L st\ f \\_. equiv_but_for_labels aag L st\" + shows "modifies_at_most aag L P f" + apply (clarsimp simp: modifies_at_most_def) + apply (erule use_valid) + apply (rule hoare) + apply (fastforce simp: equiv_but_for_labels_def states_equiv_for_refl) + done + +end + + lemma spec_equiv_valid_hoist_guard: "((P st) \ spec_equiv_valid_inv st I A \ f) \ spec_equiv_valid_inv st I A P f" by (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def) @@ -989,7 +1071,19 @@ lemma invs_kernel_mappings: by (auto simp: invs_def valid_state_def) -context InfoFlow_IF_1 begin +locale InfoFlow_IF_2 = InfoFlow_IF_1 + + fixes no_hyp :: "'m machine_monad \ bool" + and no_fpu :: "'m machine_monad \ bool" + and aag :: "'a PAS" + assumes dmo_loadWord_rev: + "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) + (do_machine_op (loadWord p))" + and do_machine_op_reads_respects': + "\ equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f; + \s. P s \ Q (machine_state s); no_hyp f; no_fpu f\ + \ reads_respects aag l P (do_machine_op f)" +begin lemma load_word_offs_rev: "for_each_byte_of_word (aag_can_read aag) (a + of_nat x * of_nat word_size) @@ -997,15 +1091,100 @@ lemma load_word_offs_rev: unfolding load_word_offs_def fun_app_def by (fastforce intro: equiv_valid_guard_imp[OF dmo_loadWord_rev]) -lemma modifies_at_mostI: - assumes hoare: "\st. \P and equiv_but_for_labels aag L st\ f \\_. equiv_but_for_labels aag L st\" - shows "modifies_at_most aag L P f" - apply (clarsimp simp: modifies_at_most_def) - apply (erule use_valid) - apply (rule hoare) - apply (fastforce simp: equiv_but_for_labels_def states_equiv_for_refl) +(* most of the time (i.e. always except for getActiveIRQ) you'll want this rule *) +lemma do_machine_op_reads_respects: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) + (equiv_machine_state (aag_can_affect aag l)) \ f" + assumes irq_state_inv: "\P. \\ms. P (irq_state ms)\ f \\_ ms. P (irq_state ms)\" + assumes no_hyp: "no_hyp f" + assumes no_fpu: "no_fpu f" + shows "reads_respects aag l \ (do_machine_op f)" + apply (rule do_machine_op_reads_respects'[where Q=\, simplified, OF _ no_hyp no_fpu]) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subgoal_tac "equiv_irq_state b ba", simp) + apply (insert equiv_dmo, fastforce simp: equiv_valid_def2 equiv_valid_2_def) + apply (insert irq_state_inv) + apply (drule_tac x="\ms. ms = irq_state s" in meta_spec) + apply (clarsimp simp: valid_def) + apply (frule_tac x=s in spec) + apply (erule (1) impE) + apply (drule bspec, assumption, simp) + apply (drule_tac x=t in spec, simp) + apply (drule bspec, assumption) + apply simp done end +lemma tcb_domain_wellformed: + "\ pas_refined aag s; etcbs_of s t = Some a \ + \ pasObjectAbs aag t \ pasDomainAbs aag (etcb_domain a)" + apply (clarsimp simp add: pas_refined_def tcb_domain_map_wellformed_aux_def) + apply (drule_tac x="(t,etcb_domain a)" in bspec) + apply (rule domtcbs) + apply force+ + done + +lemma equiv_valid_inv_split_lr: + assumes "equiv_valid_rv_inv I \\ \\ P f" + and "equiv_valid_inv \\ A P f" + shows "equiv_valid_inv I A P f" + using assms + by (fastforce simp: equiv_valid_2_def equiv_valid_def2) + +lemma equiv_valid_inv_split_rl: + assumes "equiv_valid_inv I \\ P f" + and "equiv_valid_rv_inv \\ A \\ P f" + shows "equiv_valid_inv I A P f" + using assms + by (fastforce simp: equiv_valid_2_def equiv_valid_def2) + +lemma equiv_valid_rv_inv_lift: + assumes inv: "\st. \P and I st and A st\ f \\_. I st and A st\" + assumes symI: "\st s. I st s = I s st" + assumes symA: "\st s. A st s = A s st" + shows "equiv_valid_rv_inv I A \\ P f" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply simp + done + +lemma equiv_valid_inv_lift: + assumes inv: "\st. \P and I st and A st\ f \\_. I st and A st\" + assumes symI: "\st s. I st s = I s st" + assumes symA: "\st s. A st s = A s st" + shows "equiv_valid_inv I A P (f :: ('s,unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply simp + done + +lemma equiv_valid_conseq: + "\ equiv_valid I' A' B' P' f; + \s t. I s t \ A s t \ P s \ P t \ I' s t \ A' s t \ P' s \ P' t; + \s t. I' s t \ B' s t \ I s t \ B s t \ + \ equiv_valid I A B P f" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule_tac x=s in allE) + apply (erule_tac x=t in allE, drule mp, fastforce) + apply fastforce + done + +declare equiv_valid_guard_imp[wp_pre] + end diff --git a/proof/infoflow/Interrupt_IF.thy b/proof/infoflow/Interrupt_IF.thy index 8dbdb13a65..65287cc612 100644 --- a/proof/infoflow/Interrupt_IF.thy +++ b/proof/infoflow/Interrupt_IF.thy @@ -21,7 +21,7 @@ locale Interrupt_IF_1 = "reads_respects aag l (K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)) (arch_invoke_irq_control irq_ctl_inv)" and arch_invoke_irq_control_globals_equiv: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" and arch_invoke_irq_handler_globals_equiv[wp]: @@ -74,20 +74,20 @@ lemma invoke_irq_control_reads_respects: done lemma invoke_irq_control_globals_equiv: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ invoke_irq_control a \\_. globals_equiv st\" apply (induct a) - apply (wpsimp wp: set_irq_state_globals_equiv cap_insert_globals_equiv'' + apply (wpsimp wp: set_irq_state_globals_equiv cap_insert_globals_equiv set_irq_state_valid_global_objs arch_invoke_irq_control_globals_equiv)+ done lemma invoke_irq_handler_globals_equiv: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ invoke_irq_handler a \\_. globals_equiv st\" apply (induct a) - by (wpsimp wp: modify_wp cap_insert_globals_equiv'' + by (wpsimp wp: modify_wp cap_insert_globals_equiv cap_delete_one_globals_equiv cap_delete_one_valid_global_objs)+ subsection "reads_respects_g" diff --git a/proof/infoflow/Ipc_IF.thy b/proof/infoflow/Ipc_IF.thy index 91fad3a76d..91f050ac96 100644 --- a/proof/infoflow/Ipc_IF.thy +++ b/proof/infoflow/Ipc_IF.thy @@ -19,11 +19,6 @@ definition ipc_buffer_has_read_auth :: "'a PAS \ 'a \ ob (\buf'. is_aligned buf' msg_align_bits \ (\x \ ptr_range buf' msg_align_bits. (l,Read,pasObjectAbs aag x) \ (pasPolicy aag)))" -abbreviation aag_can_read_or_affect where - "aag_can_read_or_affect aag l x \ - aag_can_read aag x \ aag_can_affect aag l x" - - lemma get_cap_reads_respects: "reads_respects aag l (K (aag_can_read aag (fst slot) \ aag_can_affect aag l (fst slot))) (get_cap slot)" apply (simp add: get_cap_def split_def) @@ -64,14 +59,16 @@ lemma tcb_sched_action_equiv_but_for_labels: apply (simp add: tcb_sched_action_def, wp) apply (clarsimp simp: etcb_at_def equiv_but_for_labels_def split: option.splits) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD[where f=kheap]) - apply (simp add: states_equiv_for_def) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) - apply (fastforce simp: equiv_asids_def elim: states_equiv_forE) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD[where f=kheap]) + apply (simp add: states_equiv_for_def) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def elim: states_equiv_forE) + apply (fastforce elim: states_equiv_forE) + apply (fastforce elim: states_equiv_forE) apply (clarsimp simp: pas_refined_def tcb_domain_map_wellformed_aux_def split: option.splits) apply (rule equiv_forI) apply (erule_tac x="(thread, etcb_domain (the (etcbs_of s thread)))" in ballE) @@ -159,7 +156,7 @@ locale Ipc_IF_1 = and handle_arch_fault_reply_reads_respects: "reads_respects aag l (K (aag_can_read aag thread)) (handle_arch_fault_reply afault thread x y)" and arch_get_sanitise_register_info_reads_respects[wp]: - "reads_respects aag l \ (arch_get_sanitise_register_info t)" + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (arch_get_sanitise_register_info t)" and arch_get_sanitise_register_info_valid_global_objs[wp]: "arch_get_sanitise_register_info t \\s :: det_state. valid_global_objs s\" and handle_arch_fault_reply_valid_global_objs[wp]: @@ -465,7 +462,7 @@ lemma blocked_cancel_ipc_nosts_reads_respects: gts_reads_respects set_simple_ko_reads_respects gts_wp simp: get_blocking_object_def get_thread_state_rev)+ apply (clarsimp simp: pred_tcb_at_def obj_at_def) - by (fastforce dest:read_sync_ep_read_receivers ) + by (fastforce dest:read_sync_ep_read_receivers) next case False thus ?thesis apply - \ \can't read or affect ep\ @@ -555,7 +552,7 @@ lemma send_signal_reads_respects: gts_reads_respects gts_wp hoare_vcg_imp_lift get_simple_ko_wp get_simple_ko_reads_respects update_waiting_ntfn_reads_respects | wpc - | simp )+ + | simp)+ apply (insert visible) apply clarsimp apply (rule conjI[rotated]) @@ -1171,14 +1168,6 @@ lemma load_word_offs_reads_respects: end -lemma as_user_reads_respects: - "reads_respects aag l (K (det f \ aag_can_read_or_affect aag l thread)) (as_user thread f)" - apply (simp add: as_user_def split_def) - apply (rule gen_asm_ev) - apply (wp set_object_reads_respects select_f_ev gets_the_ev) - apply (auto intro: reads_affects_equiv_get_tcb_eq[where aag=aag]) - done - lemma get_mi_length': "\\\ get_message_info sender \\rv s. buffer_cptr_index + unat (mi_extra_caps rv) < 2 ^ (msg_align_bits - word_size_bits)\" @@ -1666,7 +1655,7 @@ lemma setup_caller_cap_globals_equiv: setup_caller_cap sender receiver grant \\_. globals_equiv s\" unfolding setup_caller_cap_def - apply (wp cap_insert_globals_equiv'' set_thread_state_globals_equiv) + apply (wp cap_insert_globals_equiv set_thread_state_globals_equiv) apply (simp_all) done @@ -1694,7 +1683,7 @@ next apply (wp set_extra_badge_globals_equiv)+ apply (rule Cons.hyps) apply (simp) - apply (wp cap_insert_globals_equiv'') + apply (wp cap_insert_globals_equiv) apply (rule_tac Q'="\_. globals_equiv st and valid_arch_state and valid_global_objs" and E'="\_. globals_equiv st and valid_arch_state and valid_global_objs" in hoare_strengthen_postE) diff --git a/proof/infoflow/Noninterference.thy b/proof/infoflow/Noninterference.thy index b8fa1db534..e50e7b54bf 100644 --- a/proof/infoflow/Noninterference.thy +++ b/proof/infoflow/Noninterference.thy @@ -386,15 +386,6 @@ lemma kernel_entry_if_globals_equiv_scheduler: apply fastforce done -lemma domain_fields_equiv_lift: - assumes a: "\P. \domain_fields P and Q\ f \\_. domain_fields P\" - assumes b: "\P. \(\s. P (cur_domain s)) and R\ f \\_ s. P (cur_domain s)\" - shows "\domain_fields_equiv st and Q and R\ f \\_. domain_fields_equiv st\" - apply (clarsimp simp: valid_def domain_fields_equiv_def) - apply (erule use_valid, wp a b) - apply simp - done - lemma check_active_irq_if_partitionIntegrity: "check_active_irq_if tc \partitionIntegrity aag st\" apply (simp add: check_active_irq_if_def) @@ -570,7 +561,13 @@ lemmas integrity_subjects_device = integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1] lemmas integrity_subjects_asids = - integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2] + integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1] + +lemmas integrity_subjects_hyps = + integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1] + +lemmas integrity_subjects_fpus = + integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2] lemma pas_wellformed_pasSubject_update_Control: "\ pas_wellformed (aag\pasSubject := pasObjectAbs aag p\); @@ -596,7 +593,6 @@ lemma fun_noteqD: "f \ g \ \a. f a \ g a" by blast - locale Noninterference_1 = fixes current_aag :: "det_state \ 'a subject_label PAS" and arch_globals_equiv_strengthener :: "machine_state \ machine_state \ bool" @@ -613,9 +609,9 @@ locale Noninterference_1 = and sameFor_scheduler_affects_equiv: "\s s'. \ (s,s') \ same_for aag PSched; (s,s') \ same_for aag (Partition l'); invs (internal_state_if s); invs (internal_state_if s') \ - \ scheduler_equiv aag (internal_state_if s) (internal_state_if s') \ - scheduler_affects_equiv aag (OrdinaryLabel l') - (internal_state_if s) (internal_state_if s')" + \ scheduler_equiv aag (internal_state_if s) (internal_state_if s') \ + scheduler_affects_equiv aag (OrdinaryLabel l') + (internal_state_if s) (internal_state_if s')" and do_user_op_if_partitionIntegrity: "\aag :: 'a subject_label PAS. \partitionIntegrity aag st and pas_refined aag and invs and is_subject aag \ cur_thread\ @@ -634,20 +630,16 @@ locale Noninterference_1 = and integrity_fpu_update_reference_state: "is_subject aag t \ integrity_fpu aag {pasSubject aag} x s (s\kheap := (kheap s)(t \ blah)\)" - and partitionIntegrity_subjectAffects_aobj: - "\ partitionIntegrity aag s s'; kheap s x = Some (ArchObj ao); kheap s x \ kheap s' x; - silc_inv aag st s; pas_refined aag s; pas_wellformed_noninterference aag \ - \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" and partitionIntegrity_subjectAffects_asid: "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; valid_arch_state s; valid_arch_state s'; pas_wellformed_noninterference aag; silc_inv aag st s'; invs s'; \ equiv_asids (\x. pasASIDAbs aag x = a) s s'\ - \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" and arch_switch_to_thread_reads_respects_g': "equiv_valid (reads_equiv_g aag) (affects_equiv aag l) (\s s'. affects_equiv aag l s s' \ arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (\s. is_subject aag t) (arch_switch_to_thread t)" + (\s. invs s \ is_subject aag t) (arch_switch_to_thread t)" and arch_globals_equiv_strengthener_thread_independent: "arch_globals_equiv_strengthener (machine_state s) (machine_state s') \ \ct ct' it it'. arch_globals_equiv ct it (kheap s) (kheap s') @@ -661,14 +653,14 @@ locale Noninterference_1 = \st :: det_state. f \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; \st :: det_state. g \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; \s t. P s \ P' t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (g t). W rva rvb) \ - \ equiv_valid_2 (reads_equiv_g aag) - (\s s'. affects_equiv aag l s s' \ - arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (\s s'. affects_equiv aag l s s' \ - arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (W :: unit \ unit \ bool) (P and Q) (P' and Q') f g" + \ equiv_valid_2 (reads_equiv_g aag) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (W :: unit \ unit \ bool) (P and Q) (P' and Q') f g" and arch_switch_to_idle_thread_reads_respects_g[wp]: - "reads_respects_g aag l \ (arch_switch_to_idle_thread)" + "reads_respects_g aag l valid_arch_state (arch_switch_to_idle_thread)" and arch_globals_equiv_threads_eq: "arch_globals_equiv t' t'' kh kh' as as' ms ms' \ arch_globals_equiv t t kh kh' as as' ms ms'" @@ -683,14 +675,48 @@ locale Noninterference_1 = (do_machine_op (getActiveIRQ in_kernel))" and handle_spurious_irq_reads_respects_scheduler[wp]: "reads_respects_scheduler aag l \ handle_spurious_irq" - (* FIXME IF: precludes ARM_HYP *) - and getActiveIRQ_no_non_kernel_IRQs: - "getActiveIRQ True = getActiveIRQ False" - and valid_cur_hyp_triv: - "valid_cur_hyp s" - and arch_tcb_get_registers_equality: - "arch_tcb_get_registers (tcb_arch tcb) = arch_tcb_get_registers (tcb_arch tcb') - \ tcb_arch (tcb :: tcb) = tcb_arch (tcb' :: tcb)" + and getActiveIRQ_ev2: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + and arch_prepare_next_domain_reads_respects_g: + "reads_equiv_valid_g_inv (affects_equiv aag l) aag invs + arch_prepare_next_domain" + and partitionIntegrity_subjectAffects_aobj: + "\ partitionIntegrity aag s s'; kheap s x = Some (ArchObj ao); + kheap s x \ kheap s' x; silc_inv aag st s; + pas_wellformed_noninterference aag; pas_refined aag s; + pas_refined aag s'; pas_cur_domain aag s; pas_cur_domain aag s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; invs s; invs s' \ + \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" + and partitionIntegrity_subjectAffects_hyp: + "\ partitionIntegrity aag s s'; invs s; invs s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; pas_cur_domain aag s; + pas_cur_domain aag s'; pas_domains_distinct aag; + \ equiv_hyp (\x. pasObjectAbs aag x = a) s s'\ + \ subject_can_affect_label_directly aag a" + and partitionIntegrity_subjectAffects_fpu: + "\ partitionIntegrity aag s s'; invs s; invs s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; pas_refined aag s; + pas_refined aag s'; pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_fpu (\x. pasObjectAbs aag x = a) s s' \ + \ subject_can_affect_label_directly aag a" + and partitionIntegrity_subjectAffects_tcb_fpu: + "\ partitionIntegrity aag s s'; kheap s x = Some (TCB tcb); + kheap s' x = Some (TCB tcb'); tcb' = tcb\tcb_arch := new_arch\; + arch_tcb_get_registers new_arch = + arch_tcb_get_registers (tcb_arch tcb); + tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb); + kheap s x \ kheap s' x; silc_inv aag st s; + pas_wellformed_noninterference aag; pas_refined aag s; + pas_refined aag s'; pas_cur_domain aag s; pas_cur_domain aag s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; invs s; invs s' \ + \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" begin lemma integrity_update_reference_state: @@ -706,7 +732,7 @@ lemma integrity_update_reference_state: be identical to the initial one, but it isn't because we first update the context of cur_thread *) lemma kernel_entry_if_integrity: - "\einvs and schact_is_rct and pas_refined aag and is_subject aag \ cur_thread + "\einvs and valid_cur_hyp and schact_is_rct and pas_refined aag and is_subject aag \ cur_thread and domain_sep_inv (pasMaySendIrqs aag) st' and guarded_pas_domain aag and (\s. e \ Interrupt \ ct_active s) and (=) st\ kernel_entry_if e tc @@ -721,9 +747,9 @@ lemma kernel_entry_if_integrity: \ cur_thread s = cur_thread st" in hoare_strengthen_post) apply (wp handle_event_integrity handle_event_cur_thread | simp)+ apply (fastforce intro: integrity_update_reference_state) - apply (wp thread_set_integrity_autarch thread_set_pas_refined guarded_pas_domain_lift + apply (wp thread_set_integrity_autarch thread_set_context_pas_refined guarded_pas_domain_lift thread_set_invs_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def schact_is_rct_def arch_tcb_update_aux2 valid_cur_hyp_triv)+ + | simp add: tcb_cap_cases_def schact_is_rct_def arch_tcb_update_aux2)+ apply (wp thread_set_tcb_context_update_wp)+ apply (clarsimp simp: schact_is_rct_def) apply (rule conjI) @@ -801,9 +827,8 @@ lemma kernel_entry_if_domain_fields_equiv: simp: ran_tcb_cap_cases arch_tcb_update_aux2) fastforce - lemma kernel_entry_if_partitionIntegrity: - "\silc_inv aag st and pas_refined aag and einvs and schact_is_rct + "\silc_inv aag st and pas_refined aag and einvs and valid_cur_hyp and schact_is_rct and is_subject aag \ cur_thread and domain_sep_inv (pasMaySendIrqs aag) st' and guarded_pas_domain aag and (\s. ev \ Interrupt \ ct_active s) and (=) st\ kernel_entry_if ev tc @@ -835,149 +860,144 @@ text \ \ lemma partitionIntegrity_subjectAffects_obj: assumes par_inte: "partitionIntegrity (aag :: 'a subject_label PAS) s s'" - assumes pas_ref: "pas_refined aag s" - assumes invs: "invs s" + assumes pas_ref: "pas_refined aag s" "pas_refined aag s'" + assumes pas_dom: "pas_cur_domain aag s" "pas_cur_domain aag s'" + assumes cur_vcpu: "cur_hyp_in_cur_domain s" "cur_hyp_in_cur_domain s'" + assumes cur_fpu: "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + assumes invs: "invs s" "invs s'" assumes pwni: "pas_wellformed_noninterference aag" assumes silc_inv: "silc_inv aag st s" assumes kh_diff: "kheap s x \ kheap s' x" notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, - THEN spec[where x=x], simplified integrity_obj_def, simplified] + THEN spec[where x=x], simplified] shows "pasObjectAbs aag x \ subjectAffects (pasPolicy aag) (pasSubject aag)" - proof - + note hyps = pwni pas_ref invs silc_inv kh_diff + hence sym_helper: "\auth tcb. kheap s x = Some (TCB tcb) \ + (pasObjectAbs aag x, auth, pasObjectAbs aag x) \ pasPolicy aag" + by (fastforce elim!: pas_wellformed_noninterference_policy_refl + silc_inv_cnode_onlyE obj_atE + simp: is_cap_table_def) show ?thesis - using inte_obj - proof (induct "kheap s x" rule: converse_rtranclp_induct) - case base - thus ?case using kh_diff by force + using tro_tro_alt[OF inte_obj] + proof (induct rule: integrity_obj_alt.induct) + case tro_alt_lrefl + thus ?case by (simp add: subjectAffects.intros(1)) next - case (step z) - note troa = step.hyps(1) - show ?case - proof (cases "z = kheap s x") - case True - thus ?thesis using step.hyps by blast - next - case False - note hyps = this pwni pas_ref invs silc_inv kh_diff - hence sym_helper: "\auth tcb. kheap s x = Some (TCB tcb) \ - (pasObjectAbs aag x, auth, pasObjectAbs aag x) \ pasPolicy aag" - by (fastforce elim!: pas_wellformed_noninterference_policy_refl - silc_inv_cnode_onlyE obj_atE - simp: is_cap_table_def) - show ?thesis - using troa - proof (cases rule: integrity_obj_atomic.cases) - case troa_lrefl - thus ?thesis by (fastforce intro: subjectAffects.intros) - next - case (troa_ntfn ntfn ntfn' auth s) - thus ?thesis by (fastforce intro: affects_ep) - next - case (troa_ep ep ep' auth s) - thus ?thesis by (fastforce intro: affects_ep) - next - case (troa_ep_unblock ep ep' tcb ntfn) - thus ?thesis by (fastforce intro: affects_ep_bound_trans) - next - case (troa_tcb_send tcb tcb' ctxt' ep) - thus ?thesis using hyps - apply (clarsimp simp: direct_send_def indirect_send_def) - apply (erule disjE) - apply (clarsimp simp: receive_blocked_on_def2) - apply (frule (2) pas_refined_tcb_st_to_auth) - apply (fastforce intro!: affects_send sym_helper) - apply (fastforce intro!: affects_send bound_tcb_at_implies_receive - pred_tcb_atI sym_helper) - done - next - case (troa_tcb_call tcb tcb' caller R ctxt' ep) - thus ?thesis using hyps - apply (clarsimp simp add: direct_call_def ep_recv_blocked_def) - apply (rule affects_send[rotated 2]) - apply (erule (1) pas_refined_tcb_st_to_auth[rotated 2]; force) - apply (fastforce intro: sym_helper) - apply assumption - apply blast - done - next - case (troa_tcb_reply tcb tcb' new_st ctxt') - thus ?thesis using hyps - apply clarsimp - apply (erule affects_reply) - by (rule sym_helper) - next - case (troa_tcb_receive tcb tcb' new_st ep) - thus ?thesis using hyps - by (auto intro: affects_recv pas_refined_tcb_st_to_auth simp: send_blocked_on_def2) - next - case (troa_tcb_restart tcb tcb' ep) - thus ?thesis using hyps - by (fastforce intro: affects_reset[where auth=Receive] affects_reset[where auth=SyncSend] - elim: blocked_on.elims pas_refined_tcb_st_to_auth[rotated 2] - intro!: sym_helper) - next - case (troa_tcb_unbind tcb tcb') - thus ?thesis using hyps - apply - - by (cases "tcb_bound_notification tcb" ; - fastforce intro: affects_reset[where auth=Receive] bound_tcb_at_implies_receive + case tro_alt_orefl + thus ?case by (simp add: assms) + next + case (tro_alt_ntfn ntfn ntfn' auth) + thus ?case by (fastforce intro: affects_ep) + next + case (tro_alt_ep ep ep' auth) + thus ?case by (fastforce intro: affects_ep) + next + case (tro_alt_ep_unblock ep ep') + thus ?case by (fastforce intro: affects_ep_bound_trans) + next + case (tro_alt_tcb_send tcb tcb' ccap' cap' ntfn' new_arch ep) + thus ?case using hyps + apply (clarsimp simp: direct_send_def indirect_send_def) + apply (erule disjE) + apply (clarsimp simp: receive_blocked_on_def2) + apply (frule (2) pas_refined_tcb_st_to_auth) + apply (fastforce intro!: affects_send sym_helper) + apply (fastforce intro!: affects_send bound_tcb_at_implies_receive pred_tcb_atI sym_helper) - next - case (troa_tcb_empty_ctable tcb tcb' cap') - thus ?thesis using hyps - apply (clarsimp simp:reply_cap_deletion_integrity_def; elim disjE; clarsimp) - apply (rule affects_delete_derived) - apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], - assumption) - apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 0)"], - force simp: caps_of_state_def') - by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def reply_cap_rights_to_auth_def - split: if_splits) - next - case (troa_tcb_empty_caller tcb tcb' cap') - thus ?thesis using hyps - apply (clarsimp simp:reply_cap_deletion_integrity_def) - apply (elim disjE; clarsimp) - apply (rule affects_delete_derived) - apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], - assumption) - apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 3)"], - force simp: caps_of_state_def') - by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def - reply_cap_rights_to_auth_def - split: if_splits) - next - case (troa_tcb_activate tcb tcb') - thus ?thesis by blast - next - case (troa_tcb_fpu tcb tcb' new_arch) - thus ?thesis - by (auto intro!: step tcb.equality arch_tcb_get_registers_equality) - next - case (troa_arch ao ao') - thus ?thesis - using assms by (fastforce dest: partitionIntegrity_subjectAffects_aobj) - next - case (troa_cnode n content content') - thus ?thesis - using hyps unfolding cnode_integrity_def - apply clarsimp - apply (drule fun_noteqD) - apply (erule exE, rename_tac l) - apply (drule_tac x=l in spec) - apply (clarsimp dest!:not_sym[where t=None]) - apply (clarsimp simp:reply_cap_deletion_integrity_def) - apply (rule affects_delete_derived) - apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], - assumption) - apply (frule_tac p="(x,l)" in cap_auth_caps_of_state[rotated]) - apply (force simp: caps_of_state_def' intro:well_formed_cnode_invsI) - by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def - reply_cap_rights_to_auth_def - split: if_splits) - qed - qed + done + next + case (tro_alt_tcb_call tcb tcb' ccap' cap' ntfn' new_arch caller R ep) + thus ?case using hyps + apply (clarsimp simp add: direct_call_def ep_recv_blocked_def) + apply (rule affects_send[rotated 2]) + apply (erule (1) pas_refined_tcb_st_to_auth[rotated 2]; force) + apply (fastforce intro: sym_helper) + apply assumption + apply blast + done + next + case (tro_alt_tcb_reply tcb tcb' ccap' cap' ntfn' new_st new_arch) + thus ?case using hyps + apply (clarsimp simp: direct_reply_def) + apply (erule affects_reply) + by (rule sym_helper) + next + case (tro_alt_tcb_receive tcb tcb' ccap' cap' ntfn' new_arch new_st ep) + thus ?case using hyps + by (auto intro: affects_recv pas_refined_tcb_st_to_auth simp: send_blocked_on_def2) + next + case (tro_alt_tcb_restart tcb tcb' ccap' cap' ntfn' new_arch ep) + thus ?case using hyps + by (fastforce intro: affects_reset[where auth=Receive] affects_reset[where auth=SyncSend] + elim: blocked_on.elims pas_refined_tcb_st_to_auth[rotated 2] + intro!: sym_helper) + next + case (tro_alt_tcb_generic tcb tcb' ccap' cap' ntfn' new_arch) + have "tcb_bound_notification tcb \ ntfn' \ ?case" + using tro_alt_tcb_generic hyps + apply (clarsimp simp: tcb_bound_notification_reset_integrity_def) + by (cases "tcb_bound_notification tcb" ; + fastforce intro: affects_reset[where auth=Receive] bound_tcb_at_implies_receive + pred_tcb_atI sym_helper) + moreover have "tcb_caller tcb \ cap' \ ?case" + using tro_alt_tcb_generic(2,3,4,5,8) hyps + apply (clarsimp simp:reply_cap_deletion_integrity_def) + apply (rule affects_delete_derived) + apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], + assumption) + apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 3)"], + force simp: caps_of_state_def') + by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def + reply_cap_rights_to_auth_def + split: if_splits) + moreover have "tcb_ctable tcb \ ccap' \ ?case" + using tro_alt_tcb_generic(2,3,4,5,9) hyps + apply (clarsimp simp: reply_cap_deletion_integrity_def) + apply (rule affects_delete_derived) + apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], + assumption) + apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 0)"], + force simp: caps_of_state_def') + by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def reply_cap_rights_to_auth_def + split: if_splits) + moreover have "\ tcb_ctable tcb = ccap'; tcb_caller tcb = cap'; + tcb_bound_notification tcb = ntfn'; tcb_arch tcb \ new_arch \ \ ?case" + using tro_alt_tcb_generic(2,3,4,5,6) assms + by (fastforce intro: partitionIntegrity_subjectAffects_tcb_fpu) + ultimately show ?case + using tro_alt_tcb_generic(2,3,4) kh_diff + apply clarsimp + apply (case_tac "tcb_ctable tcb \ ccap'", fastforce) + apply (case_tac "tcb_caller tcb \ cap'", fastforce) + apply (case_tac "tcb_bound_notification tcb \ ntfn'", fastforce) + apply (case_tac "tcb_arch tcb \ new_arch", fastforce) + apply simp + done + next + case (tro_alt_tcb_activate tcb tcb' ntfn' ccap' cap' new_arch) + thus ?case by simp + next + case (tro_alt_cnode n content content') + thus ?case + using hyps unfolding cnode_integrity_def + apply clarsimp + apply (drule fun_noteqD) + apply (erule exE, rename_tac l) + apply (drule_tac x=l in spec) + apply (clarsimp dest!:not_sym[where t=None]) + apply (clarsimp simp:reply_cap_deletion_integrity_def) + apply (rule affects_delete_derived) + apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], + assumption) + apply (frule_tac p="(x,l)" in cap_auth_caps_of_state[rotated]) + apply (force simp: caps_of_state_def' intro:well_formed_cnode_invsI) + by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def + reply_cap_rights_to_auth_def + split: if_splits) + next + case (tro_alt_arch ao ao') + thus ?case using assms by (fastforce dest: partitionIntegrity_subjectAffects_aobj) qed qed @@ -1225,19 +1245,32 @@ lemma valid_sched_valid_blocked: "valid_sched s \ valid_blocked context Noninterference_1 begin lemma partitionIntegrity_subjectAffects_etcbs: - "\ partitionIntegrity (aag :: 'a subject_label PAS) s s'; pas_refined aag s; - valid_objs s; einvs s; einvs s'; pas_wellformed_noninterference aag; + assumes par_inte: "partitionIntegrity (aag :: 'a subject_label PAS) s s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows + "\ pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + einvs s; einvs s'; pas_wellformed_noninterference aag; silc_inv aag st s; silc_inv aag st' s'; etcbs_of s x \ etcbs_of s' x \ \ pasObjectAbs aag x \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (insert par_inte) apply (prop_tac "kheap s x \ kheap s' x") apply (clarsimp simp: etcbs_of'_def) + apply (case_tac "is_subject aag x") + using affects_lrefl apply fastforce apply (erule partitionIntegrity_subjectAffects_obj; simp) done lemma partitionIntegrity_subjectAffects_ready_queues: assumes domains_distinct: "pas_domains_distinct (aag :: 'a subject_label PAS)" - shows "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; einvs s; einvs s'; - pas_refined aag s'; pas_cur_domain aag s; pas_wellformed_noninterference aag; + shows "\ partitionIntegrity aag s s'; pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + einvs s; einvs s'; pas_wellformed_noninterference aag; silc_inv aag st s; silc_inv aag st' s'; ready_queues s d \ ready_queues s' d; cur_thread s \ idle_thread s \ is_subject aag (cur_thread s); cur_thread s' \ idle_thread s' \ is_subject aag (cur_thread s') \ @@ -1267,12 +1300,12 @@ lemma partitionIntegrity_subjectAffects_ready_queues: apply (fastforce dest: domains_distinct[THEN pas_domains_distinct_inj]) apply (case_tac "etcbs_of s tcb_ptr \ etcbs_of s' tcb_ptr") apply (rule_tac s=s and s'=s' in partitionIntegrity_subjectAffects_etcbs) - apply (simp add: partitionIntegrity_def)+ + apply (simp add: partitionIntegrity_def)+ apply (subgoal_tac "kheap s tcb_ptr \ kheap s' tcb_ptr") apply (rule partitionIntegrity_subjectAffects_obj) - apply (fastforce simp add: partitionIntegrity_def valid_sched_def)+ - apply (rule_tac threads="tcb_ptr # tcbs" in ready_queues_alters_kheap) apply (fastforce simp add: partitionIntegrity_def valid_sched_def)+ + apply (rule_tac threads="tcb_ptr # tcbs" in ready_queues_alters_kheap) + apply (fastforce simp add: partitionIntegrity_def valid_sched_def)+ done end @@ -1319,10 +1352,18 @@ lemma sameFor_subject_def2: apply (rule conjI, rule refl) apply (rule conjI) apply (rule states_equiv_forI) - apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[5] - apply (fastforce intro: equiv_forI elim: states_equiv_forE_is_original_cap) - apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[2] - apply (solves \clarsimp simp: equiv_asids_def states_equiv_for_def\) + apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[4] + apply (fastforce intro: equiv_forI elim: states_equiv_forE_is_original_cap) + apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[2] + apply (solves \clarsimp simp: equiv_asids_def states_equiv_for_def\) + apply (rule equiv_hypI) + apply (clarsimp simp: states_equiv_for_def) + apply (drule (1) bspec) + apply (fastforce elim!: equiv_hyp_guard_imp) + apply (rule equiv_fpuI) + apply (clarsimp simp: states_equiv_for_def) + apply (drule (1) bspec) + apply (fastforce elim!: equiv_fpu_guard_imp) apply (fastforce intro: equiv_forI elim: states_equiv_forE_ready_queues) apply fastforce done @@ -1366,9 +1407,12 @@ context Noninterference_1 begin lemma partsSubjectAffects_bounds_subjects_affects: assumes domains_distinct: "pas_domains_distinct (aag :: 'a subject_label PAS)" - shows "\ partitionIntegrity aag s s'; pas_refined aag s; pas_refined aag s'; valid_objs s; - valid_arch_state s'; einvs s; einvs s'; silc_inv aag st s; silc_inv aag st' s'; - pas_wellformed_noninterference aag; pas_cur_domain aag s; + shows "\ partitionIntegrity aag s s'; pas_refined aag s; pas_refined aag s'; + einvs s; einvs s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + silc_inv aag st s; silc_inv aag st' s'; + pas_wellformed_noninterference aag; pas_cur_domain aag s; pas_cur_domain aag s'; guarded_is_subject_cur_thread aag s; guarded_is_subject_cur_thread aag s'; d \ partsSubjectAffects (pasPolicy aag) (label_of (pasSubject aag)); d \ PSched \ \ (((uc,s),mode),((uc',s'),mode')) \ same_for aag d" @@ -1377,12 +1421,16 @@ lemma partsSubjectAffects_bounds_subjects_affects: apply (cases d) prefer 2 apply simp + apply (unfold sameFor_def sameFor_subject_def2) apply (clarsimp simp: sameFor_def sameFor_subject_def2 states_equiv_for_def equiv_for_def - partsSubjectAffects_def image_def label_can_affect_partition_def) + partsSubjectAffects_def image_def label_can_affect_partition_def) apply (safe del: iffI notI) + apply (drule partitionIntegrity_subjectAffects_hyp) + apply (simp add: domains_distinct)+ + apply fastforce + apply (fastforce dest: partitionIntegrity_subjectAffects_asid) apply (fastforce dest: partitionIntegrity_subjectAffects_obj) - apply ((auto dest: partitionIntegrity_subjectAffects_obj - partitionIntegrity_subjectAffects_mem + apply ((auto dest: partitionIntegrity_subjectAffects_mem partitionIntegrity_subjectAffects_device partitionIntegrity_subjectAffects_cdt partitionIntegrity_subjectAffects_cdt_list @@ -1395,7 +1443,10 @@ lemma partsSubjectAffects_bounds_subjects_affects: OF domains_distinct] domains_distinct[THEN pas_domains_distinct_inj] | fastforce simp: partitionIntegrity_def - silc_dom_equiv_def equiv_for_def)+)[11] + silc_dom_equiv_def equiv_for_def)+)[10] + apply (drule partitionIntegrity_subjectAffects_fpu) + apply (simp add: domains_distinct)+ + apply fastforce apply ((fastforce intro: affects_lrefl simp: partitionIntegrity_def domain_fields_equiv_def dest: domains_distinct[THEN pas_domains_distinct_inj])+)[16] @@ -1404,17 +1455,6 @@ lemma partsSubjectAffects_bounds_subjects_affects: end -lemma cur_thread_not_SilcLabel: - "\ silc_inv aag st s; invs s \ \ pasObjectAbs aag (cur_thread s) \ SilcLabel" - apply (rule notI) - apply (simp add: silc_inv_def) - apply (drule tcb_at_invs) - apply clarify - apply (drule_tac x="cur_thread s" in spec, erule (1) impE) - apply (auto simp: obj_at_def is_tcb_def is_cap_table_def) - apply (case_tac ko, simp_all) - done - lemma ev_add_pre: "equiv_valid_inv I A P f \ equiv_valid_inv I A (P and Q) f" apply (rule equiv_valid_guard_imp) @@ -1424,7 +1464,7 @@ lemma ev_add_pre: crunch check_active_irq_if for invs[wp]: "einvs" - (wp: dmo_getActiveIRQ_wp ignore: do_machine_op) + (ignore: do_machine_op) crunch thread_set for schact_is_rct[wp]: "schact_is_rct" @@ -1946,11 +1986,15 @@ lemma integrity_part: apply (fastforce dest!: reachable_invs_if[OF reachable_Step'] simp: invs_if_def Invs_def) apply (fastforce dest!: reachable_invs_if simp: invs_if_def Invs_def) apply (fastforce dest!: reachable_invs_if[OF reachable_Step'] simp: invs_if_def Invs_def) + apply (fastforce dest!: reachable_invs_if simp: invs_if_def Invs_def) + apply (fastforce dest!: reachable_invs_if[OF reachable_Step'] simp: invs_if_def Invs_def) apply (fastforce dest: silc_inv_initial_aag_reachable simp: silc_inv_cur) - apply (frule Step_current_aag_unchanged[symmetric];simp) + apply (frule Step_current_aag_unchanged[symmetric]; simp) apply (fastforce dest: silc_inv_initial_aag_reachable[OF reachable_Step'] simp: silc_inv_cur) apply (rule pas_wellformed_cur) apply (simp add: current_aag_def) + apply (frule Step_current_aag_unchanged[symmetric];simp) + apply (simp add: current_aag_def) apply (fastforce dest!: reachable_invs_if domains_distinct[THEN pas_domains_distinct_inj] simp: invs_if_def Invs_def guarded_pas_domain_def guarded_is_subject_cur_thread_def current_aag_def) @@ -2148,11 +2192,12 @@ lemma tcb_sched_action_reads_respects_g': apply (wp set_tcb_queue_reads_respects_g') apply (rule_tac Q="\s. pasObjectAbs aag thread \ pasDomainAbs aag (tcb_domain rv)" in equiv_valid_guard_imp) - apply (wp gets_apply_ev') + apply (wp gets_apply_ev) apply (clarsimp simp: reads_equiv_g_def) apply (elim reads_equivE affects_equivE equiv_forE) apply (clarsimp simp: disjoint_iff_not_equal) - apply metis (* only one that works *) + apply (erule_tac x="tcb_domain rv" in meta_allE)+ + apply blast apply (wp | simp)+ apply (intro conjI impI allI | fastforce simp: get_tcb_def reads_equiv_g_def @@ -2185,7 +2230,7 @@ lemma tcb_sched_action_reads_respects_g': lemma switch_to_thread_reads_respects_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects_g aag (l :: 'a subject_label) - (pas_refined aag and (\s. is_subject aag t)) (switch_to_thread t)" + (pas_refined aag and invs and (\s. is_subject aag t)) (switch_to_thread t)" apply (simp add: switch_to_thread_def) apply (subst bind_assoc[symmetric]) apply (rule equiv_valid_guard_imp) @@ -2202,7 +2247,7 @@ lemma switch_to_thread_reads_respects_g: lemma guarded_switch_to_reads_respects_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects_g aag (l :: 'a subject_label) - (pas_refined aag and valid_idle and (\s. is_subject aag t)) + (pas_refined aag and invs and (\s. is_subject aag t)) (guarded_switch_to t)" apply (simp add: guarded_switch_to_def) apply (wp switch_to_thread_reads_respects_g get_thread_state_reads_respects_g gts_wp) @@ -2219,7 +2264,7 @@ lemma cur_thread_update_idle_reads_respects_g': done lemma switch_to_idle_thread_reads_respects_g[wp]: - "reads_respects_g aag (l :: 'a subject_label) \ (switch_to_idle_thread)" + "reads_respects_g aag (l :: 'a subject_label) valid_arch_state (switch_to_idle_thread)" apply (simp add: switch_to_idle_thread_def) apply (wp cur_thread_update_idle_reads_respects_g') apply (fastforce simp: reads_equiv_g_def globals_equiv_idle_thread_ptr) @@ -2239,7 +2284,7 @@ lemma choose_thread_reads_respects_g: apply (clarsimp simp: reads_equiv_g_def reads_equiv_def2 states_equiv_for_def equiv_for_def disjoint_iff_not_equal) apply (metis reads_lrefl) - apply (simp add: invs_valid_idle) + apply (simp add: invs_arch_state) (* everything from here clagged from Syscall_AC.choose_thread_respects *) apply (clarsimp simp: pas_refined_def) apply (clarsimp simp: tcb_domain_map_wellformed_aux_def) @@ -2299,7 +2344,7 @@ lemma reads_equiv_valid_g_inv_schedule_switch_thread_fastfail: lemma reads_respects_gets_ready_queues: "reads_respects aag l (\s. pasSubject aag \ pasDomainAbs aag d) (gets (\s. f (ready_queues s d)))" - apply (wp gets_ev'') + apply (wp gets_ev) apply (force elim: reads_equivE simp: equiv_for_def) done @@ -2326,11 +2371,11 @@ lemma schedule_choose_new_thread_reads_respects_g: ((\s. domain_time s \ 0) and einvs and pas_cur_domain aag and pas_refined aag and (\s. (cur_thread s \ idle_thread s \ is_subject aag (cur_thread s)))) schedule_choose_new_thread" - apply (simp add: schedule_choose_new_thread_def ) + apply (simp add: schedule_choose_new_thread_def) apply (subst gets_app_rewrite[where y=domain_time and f="\x. x = 0"])+ apply (wp gets_domain_time_zero_ev set_scheduler_action_reads_respects_g choose_thread_reads_respects_g ev_pre_cont[where f=next_domain] - arch_prepare_next_domain_ev hoare_pre_cont[where f=next_domain] when_ev) + arch_prepare_next_domain_reads_respects_g hoare_pre_cont[where f=next_domain] when_ev) apply (clarsimp simp: valid_sched_def word_neq_0_conv) done @@ -2832,52 +2877,32 @@ lemma kernel_schedule_if_confidentiality': end -lemma thread_set_tcb_context_update_runnable_globals_equiv: - "\globals_equiv st and st_tcb_at runnable t and invs\ - thread_set (tcb_arch_update (arch_tcb_context_set uc)) t - \\_. globals_equiv st\" - apply (rule hoare_pre) - apply (rule thread_set_context_globals_equiv) - apply clarsimp - apply (frule invs_valid_idle) - apply (fastforce simp: valid_idle_def pred_tcb_at_def obj_at_def) - done - -lemma thread_set_tcb_context_update_reads_respects_g: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_g aag (l :: 'a subject_label) (st_tcb_at runnable t and invs) - (thread_set (tcb_arch_update (arch_tcb_context_set uc)) t)" +lemma thread_set_reads_respects_g: + "reads_respects_g aag (l :: 'a subject_label) (st_tcb_at runnable t and invs) (thread_set f t)" apply (rule equiv_valid_guard_imp) apply (rule reads_respects_g) - apply (rule thread_set_reads_respects[OF domains_distinct]) + apply (rule thread_set_reads_respects) apply (rule doesnt_touch_globalsI) - apply (wp thread_set_tcb_context_update_runnable_globals_equiv) + apply (wp thread_set_globals_equiv') apply simp+ + apply (fastforce dest: invs_valid_idle simp: valid_idle_def pred_tcb_at_def obj_at_def) done -lemma thread_set_tcb_context_update_silc_inv[wp]: - "thread_set (tcb_arch_update (arch_tcb_context_set f)) t \silc_inv aag st\" - apply (rule thread_set_silc_inv) - apply (simp add: tcb_cap_cases_def) - done - -lemmas thread_set_tcb_context_update_reads_respects_f_g = - reads_respects_f_g'[where Q="\", simplified, - OF thread_set_tcb_context_update_reads_respects_g, - OF _ thread_set_tcb_context_update_silc_inv] +lemmas thread_set_reads_respects_f_g = + reads_respects_f_g'[where Q="\", simplified, OF thread_set_reads_respects_g] lemma kernel_entry_if_reads_respects_f_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_f_g aag l (ct_active and silc_inv aag st and einvs + shows "reads_respects_f_g aag l (ct_active and silc_inv aag st and einvs and valid_cur_hyp and only_timer_irq_inv irq st' and schact_is_rct and pas_refined aag and pas_cur_domain aag and guarded_pas_domain aag and K (ev \ Interrupt \ \ pasMaySendIrqs aag)) (kernel_entry_if ev tc)" apply (simp add: kernel_entry_if_def) - apply (wp handle_event_reads_respects_f_g thread_set_tcb_context_update_reads_respects_f_g - thread_set_tcb_context_update_silc_inv only_timer_irq_inv_pres[where P="\" and Q="\"] - thread_set_invs_trivial thread_set_not_state_valid_sched thread_set_pas_refined + apply (wp handle_event_reads_respects_f_g thread_set_reads_respects_f_g + only_timer_irq_inv_pres[where P="\" and Q="\"] + thread_set_invs_trivial thread_set_not_state_valid_sched thread_set_context_pas_refined | simp add: tcb_cap_cases_def arch_tcb_update_aux2)+ apply (elim conjE) apply (frule (1) ct_active_cur_thread_not_idle_thread[OF invs_valid_idle]) @@ -3500,6 +3525,22 @@ lemma handle_preemption_agnostic_tc: context Noninterference_1 begin +lemma handle_non_kernel_IRQ_ev2: + "equiv_valid_2 I A A R P (domain_sep_inv False st and K (irq \ maxIRQ \ irq \ non_kernel_IRQs)) + LHS (handle_interrupt irq >>= RHS)" + unfolding handle_interrupt_def + apply (rule EquivValid.gen_asm_ev2_r) + apply (prop_tac "\maxIRQ < irq") + apply (clarsimp simp: not_less) + apply (clarsimp simp: bind_assoc) + apply (rule_tac Q="\irq _. irq = IRQInactive" in equiv_valid_2_bind_right) + apply (rule gen_asm_ev2_r) + apply (clarsimp simp: fail_ev2_r) + apply (wpsimp simp: get_irq_state_def)+ + apply (fastforce simp: domain_sep_inv_def) + apply simp + done + lemma preemption_interrupt_scheduler_invisible: assumes domains_distinct[wp]: "pas_domains_distinct (aag :: 'a subject_label PAS)" shows "equiv_valid_2 (scheduler_equiv aag) (scheduler_affects_equiv aag l) @@ -3515,21 +3556,24 @@ lemma preemption_interrupt_scheduler_invisible: and (\s. ct_idle s \ uc' = idle_context s) and (\s. \ reads_scheduler_cur_domain aag l s)) (handle_preemption_if uc) (kernel_entry_if Interrupt uc')" - apply (simp add: kernel_entry_if_def handle_preemption_if_def maybe_handle_interrupt_def - getActiveIRQ_no_non_kernel_IRQs) + apply (simp add: kernel_entry_if_def handle_preemption_if_def maybe_handle_interrupt_def) apply (rule equiv_valid_2_bind_right) apply (rule equiv_valid_2_bind_right) apply (simp add: liftE_def bind_assoc) apply (simp only: option.case_eq_if) - apply (rule equiv_valid_2_bind_pre[where R'="(=)"]) + apply (rule equiv_valid_2_bind_pre[OF _ getActiveIRQ_ev2]) + apply (elim disjE) apply (simp split del: if_split) apply (rule equiv_valid_2_bind_pre[where R'="(=)" and Q="\\" and Q'="\\"]) apply (rule return_ev2) apply simp apply (rule equiv_valid_2) apply (wp handle_interrupt_reads_respects_scheduler[where st=st and st'=st'] | simp)+ - apply (rule equiv_valid_2) - apply (rule dmo_getActive_IRQ_reads_respect_scheduler) + apply clarsimp + apply (rule equiv_valid_2_guard_imp) + apply (rule handle_non_kernel_IRQ_ev2) + apply simp + apply fastforce apply (wp dmo_getActiveIRQ_return_axiom[simplified try_some_magic] | simp add: imp_conjR arch_tcb_update_aux2 | elim conjE @@ -3592,7 +3636,7 @@ lemma kernel_entry_scheduler_equiv_2: | wp (once) hoare_drop_imps)+ apply (rule context_update_cur_thread_snippit) apply (wp thread_set_invs_trivial guarded_pas_domain_lift - thread_set_pas_refined thread_set_not_state_valid_sched + thread_set_context_pas_refined thread_set_not_state_valid_sched | simp add: tcb_cap_cases_def arch_tcb_update_aux2)+ apply (fastforce simp: silc_inv_not_cur_thread cur_thread_idle)+ done @@ -3894,9 +3938,10 @@ lemma schedule_step: done lemma schedule_if_reads_respects_scheduler: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "reads_respects_scheduler aag l - (einvs and pas_refined aag and silc_inv aag st and guarded_pas_domain aag and tick_done) + (einvs and pas_refined aag and silc_inv aag st and guarded_pas_domain aag and tick_done and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) (schedule_if uc)" apply (simp add: schedule_if_def) apply (wp schedule_reads_respects_scheduler schedule_guarded_pas_domain) @@ -4015,7 +4060,7 @@ lemma scheduler_step_2_confidentiality: apply (rule equiv_valid_2E[where s="internal_state_if s" and t="internal_state_if t", OF schedule_if_reads_respects_scheduler_2 [where aag="initial_aag" and st="s0_internal" - and l="label_for_partition u", OF domains_distinct]], + and l="label_for_partition u", OF policy_wellformed]], assumption,assumption) apply (rule uwr_scheduler_affects_equiv,simp+) apply ((clarsimp simp: blob)+)[2] diff --git a/proof/infoflow/Noninterference_Base.thy b/proof/infoflow/Noninterference_Base.thy index 9c163a697f..d7d29b4c77 100644 --- a/proof/infoflow/Noninterference_Base.thy +++ b/proof/infoflow/Noninterference_Base.thy @@ -1287,7 +1287,7 @@ lemma Noninfluence_gen_integrity_u: apply (drule_tac x=s in spec, drule_tac x="{s}" in spec) apply (simp add: sources_Step sameFor_dom_def uwr_equiv_def Step_def ipurge_Cons ipurge_Nil uwr_refl policy_refl execution_Nil uwr_sym - split: if_splits ) + split: if_splits) done lemma Noninfluence_strong_uwr_integrity_u: diff --git a/proof/infoflow/PasUpdates.thy b/proof/infoflow/PasUpdates.thy index 4dc274e8d5..89e6dd7a1d 100644 --- a/proof/infoflow/PasUpdates.thy +++ b/proof/infoflow/PasUpdates.thy @@ -72,8 +72,7 @@ lemma tcb_domain_map_wellformed_pasSubject_update: by (clarsimp simp: tcb_domain_map_wellformed_aux_def) -(* FIXME: rename PasUpdates_2 to PasUpdates_1; original PasUpdates_1 was removed *) -locale PasUpdates_2 = +locale PasUpdates_1 = fixes aag :: "'a subject_label PAS" assumes state_asids_to_policy_pasSubject_update: "state_asids_to_policy (aag\pasSubject := subject\) s = @@ -203,7 +202,7 @@ lemma state_irqs_to_policy_pasMayEditReadyQueues_update: done -context PasUpdates_2 begin +context PasUpdates_1 begin lemma pas_refined_pasMayActivate_update: "pas_refined aag s diff --git a/proof/infoflow/Retype_IF.thy b/proof/infoflow/Retype_IF.thy index 914b13a9a2..994074505f 100644 --- a/proof/infoflow/Retype_IF.thy +++ b/proof/infoflow/Retype_IF.thy @@ -72,15 +72,6 @@ lemma machine_op_lift_irq_state[wp]: "machine_op_lift mop \\ms. P (irq_state ms)\" by (simp add: machine_op_lift_def machine_rest_lift_def | wp | wpc)+ -lemma dmo_mol_reads_respects: - "reads_respects aag l \ (do_machine_op (machine_op_lift mop))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (rule equiv_valid_guard_imp[OF machine_op_lift_ev]) - apply simp - apply wp - done - lemma dmo_bind_ev: "equiv_valid_inv I A P (do_machine_op (a >>= b)) = equiv_valid_inv I A P (do_machine_op a >>= (\rv. do_machine_op (b rv)))" @@ -134,7 +125,6 @@ lemma dmo_mapM_x_ev: shows "equiv_valid_inv D A I (do_machine_op (mapM_x m lst))" using assms by (auto intro: dmo_mapM_x_ev_pre) - locale Retype_IF_1 = assumes clearMemory_ev: "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \ (clearMemory ptr bits)" @@ -159,23 +149,31 @@ locale Retype_IF_1 = and K (range_cover p sz (obj_bits_api type o_bits) num \ 0 < num)\ retype_region p num o_bits type dev \\_. globals_equiv s\" + and machine_op_lift_no_hyp[wp]: + "no_hyp (machine_op_lift mop)" + and machine_op_lift_no_fpu[wp]: + "no_fpu (machine_op_lift mop)" + and clearMemory_no_hyp[wp]: + "no_hyp (clearMemory ptr bits)" + and clearMemory_no_fpu[wp]: + "no_fpu (clearMemory ptr bits)" + and freeMemory_no_hyp[wp]: + "no_hyp (freeMemory ptr bits)" + and freeMemory_no_fpu[wp]: + "no_fpu (freeMemory ptr bits)" begin +lemma dmo_mol_reads_respects: + "reads_respects aag l \ (do_machine_op (machine_op_lift mop))" + by (wpsimp wp: do_machine_op_reads_respects equiv_valid_guard_imp[OF machine_op_lift_ev]) + lemma dmo_clearMemory_reads_respects: "reads_respects aag l \ (do_machine_op (clearMemory ptr bits))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (rule equiv_valid_guard_imp[OF clearMemory_ev], rule TrueI) - apply wp - done + by (wpsimp wp: do_machine_op_reads_respects equiv_valid_guard_imp[OF clearMemory_ev]) lemma dmo_freeMemory_reads_respects: "reads_respects aag l \ (do_machine_op (freeMemory ptr bits))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (rule equiv_valid_guard_imp[OF freeMemory_ev], rule TrueI) - apply wp - done + by (wpsimp wp: do_machine_op_reads_respects equiv_valid_guard_imp[OF freeMemory_ev]) lemma dmo_clearMemory_reads_respects_g: "reads_respects_g aag l \ (do_machine_op (clearMemory ptr (2 ^bits)))" diff --git a/proof/infoflow/Scheduler_IF.thy b/proof/infoflow/Scheduler_IF.thy index 871895f75e..20e7b31118 100644 --- a/proof/infoflow/Scheduler_IF.thy +++ b/proof/infoflow/Scheduler_IF.thy @@ -8,6 +8,55 @@ theory Scheduler_IF imports "ArchSyscall_IF" "ArchPasUpdates" begin +definition valid_silc_label where + "valid_silc_label aag s \ (SilcLabel \ pasSubject aag) \ + (\x. pasObjectAbs aag x = SilcLabel \ (\sz. cap_table_at sz x s))" + +lemma valid_silc_label_lift: + assumes "\P T p. f \\s. P (typ_at T p s)\" + shows "f \valid_silc_label aag\" + unfolding valid_silc_label_def + by (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift hoare_vcg_ex_lift assms simp: cap_table_at_typ) + +lemma valid_silc_label_silc_dom_equiv: + assumes "\P T p. f \\s. P (typ_at T p s)\" + shows "f \valid_silc_label aag\" + unfolding valid_silc_label_def + by (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift hoare_vcg_ex_lift assms simp: cap_table_at_typ) + +lemma silc_dom_equiv_upds[simp]: + "\f. silc_dom_equiv aag st (arch_state_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (cur_thread_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (ready_queues_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (machine_state_update f s) = silc_dom_equiv aag st s" + by (auto simp add: silc_dom_equiv_def equiv_for_def) + +lemma set_object_silc_dom_equiv: + "\silc_dom_equiv aag st and valid_silc_label aag and K (\sz. \is_cap_table sz obj)\ + set_object ptr obj + \\_. silc_dom_equiv aag st\" + apply (wp set_object_wp_strong) + apply (clarsimp simp: valid_silc_label_def silc_dom_equiv_def equiv_for_def obj_at_def) + apply (erule_tac x=ptr in allE)+ + apply clarsimp + apply (case_tac obj; case_tac ko; clarsimp simp: is_cap_table_def a_type_def) + done + +lemma as_user_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ as_user ptr f \\_. silc_dom_equiv aag st\" + unfolding as_user_def + by (wpsimp wp: set_object_silc_dom_equiv simp: is_cap_table_def) + +lemma arch_thread_set_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ arch_thread_set ptr f \\_. silc_dom_equiv aag st\" + unfolding arch_thread_set_def + by (wpsimp wp: set_object_silc_dom_equiv simp: is_cap_table_def) + +lemma valid_silc_label_arch_state_update[simp]: + "valid_silc_label aag (arch_state_update f s) = valid_silc_label aag s" + by (simp add: valid_silc_label_def) + + (* After SELFOUR-553 scheduler no longer writes to shared memory *) abbreviation scheduler_affects_globals_frame where "scheduler_affects_globals_frame s \ {}" @@ -26,6 +75,15 @@ definition domain_fields_equiv :: "det_state \ det_state \ domain_start_index s = domain_start_index s' \ domain_list s = domain_list s'" +lemma domain_fields_equiv_lift: + assumes "\P. \domain_fields P and Q\ f \\_. domain_fields P\" + assumes "\P. \(\s. P (cur_domain s)) and R\ f \\_ s. P (cur_domain s)\" + shows "\domain_fields_equiv st and Q and R\ f \\_. domain_fields_equiv st\" + apply (clarsimp simp: valid_def domain_fields_equiv_def) + apply (erule use_valid, wp assms) + apply simp + done + definition reads_scheduler where "reads_scheduler aag l \ if (l = SilcLabel) then {} else subjectReads (pasPolicy aag) l" @@ -82,10 +140,6 @@ locale Scheduler_IF_1 = arch_scheduler_affects_equiv s s'" "\f. arch_scheduler_affects_equiv s (domain_time_update f s') = arch_scheduler_affects_equiv s s'" - and arch_switch_to_thread_kheap[wp]: - "\P t. arch_switch_to_thread t \\s :: det_state. P (kheap s)\" - and arch_switch_to_idle_thread_kheap[wp]: - "\P. arch_switch_to_idle_thread \\s :: det_state. P (kheap s)\" and arch_switch_to_thread_idle_thread[wp]: "\P t. arch_switch_to_thread t \\s :: det_state. P (idle_thread s)\" and arch_switch_to_idle_thread_idle_thread[wp]: @@ -93,9 +147,7 @@ locale Scheduler_IF_1 = and arch_switch_to_idle_thread_cur_domain[wp]: "\P. arch_switch_to_idle_thread \\s :: det_state. P (cur_domain s)\" and arch_switch_to_idle_thread_globals_equiv[wp]: - "arch_switch_to_idle_thread \globals_equiv st\" - and arch_switch_to_idle_thread_states_equiv_for[wp]: - "\P Q R S. arch_switch_to_idle_thread \states_equiv_for P Q R S st\" + "\valid_arch_state and globals_equiv st\ arch_switch_to_idle_thread \\_. globals_equiv st\" and arch_switch_to_idle_thread_work_units_completed[wp]: "\P. arch_switch_to_idle_thread \\s. P (work_units_completed s)\" and equiv_asid_equiv_update: @@ -119,8 +171,8 @@ locale Scheduler_IF_1 = "\P. arch_activate_idle_thread t \\s :: det_state. P (idle_thread s)\" and arch_activate_idle_thread_irq_state_of_state[wp]: "\P. arch_activate_idle_thread t \\s. P (irq_state_of_state s)\" - and arch_prepare_next_domain_kheap[wp]: - "\P. arch_prepare_next_domain \\s :: det_state. P (kheap s)\" + and arch_activate_idle_thread_domain_fields[wp]: + "\P. arch_activate_idle_thread t \domain_fields P\" and arch_prepare_next_domain_idle_thread[wp]: "\P. arch_prepare_next_domain \\s :: det_state. P (idle_thread s)\" begin @@ -370,15 +422,6 @@ lemma silc_dom_equiv_cur_thread_update'[simp]: "silc_dom_equiv aag (st\cur_thread := x\) s = silc_dom_equiv aag st s" by (simp add: silc_dom_equiv_def equiv_for_def) -lemma tcb_domain_wellformed: - "\ pas_refined aag s; etcbs_of s t = Some a \ - \ pasObjectAbs aag t \ pasDomainAbs aag (etcb_domain a)" - apply (clarsimp simp add: pas_refined_def tcb_domain_map_wellformed_aux_def) - apply (drule_tac x="(t,etcb_domain a)" in bspec) - apply (rule domtcbs) - apply force+ - done - lemma silc_dom_equiv_trans_state[simp]: "silc_dom_equiv aag st (trans_state f s) = silc_dom_equiv aag st s" by (simp add: silc_dom_equiv_def equiv_for_def) @@ -522,6 +565,8 @@ definition midstrength_scheduler_affects_equiv :: (reads_scheduler_cur_domain aag l s \ reads_scheduler_cur_domain aag l s' \ work_units_completed s = work_units_completed s')" +declare equiv_hyp_False[simp] equiv_fpu_False[simp] + lemma globals_frame_equiv_as_states_equiv: "scheduler_globals_frame_equiv st s = states_equiv_for (\x. x \ scheduler_affects_globals_frame s) \ \ \ @@ -531,7 +576,7 @@ lemma globals_frame_equiv_as_states_equiv: lemma silc_dom_equiv_as_states_equiv: "silc_dom_equiv aag st s = states_equiv_for (\x. pasObjectAbs aag x = SilcLabel) \ \ \ (s\kheap := kheap st\) s" - by (simp add: states_equiv_for_def equiv_for_def silc_dom_equiv_def equiv_asids_def) + by (auto simp add: states_equiv_for_def equiv_for_def silc_dom_equiv_def equiv_asids_def equiv_hyp_refl equiv_fpu_refl) lemma silc_dom_equiv_states_equiv_lift: assumes a: "\P Q R S st. f \states_equiv_for P Q R S st\" @@ -540,7 +585,7 @@ lemma silc_dom_equiv_states_equiv_lift: apply (clarsimp simp add: valid_def) apply (frule use_valid[OF _ a]) apply assumption - apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (auto simp add: states_equiv_for_def equiv_for_def equiv_asids_def equiv_hyp_refl equiv_fpu_refl) done @@ -592,7 +637,7 @@ proof - apply (clarsimp simp add: valid_def) apply (frule use_valid[OF _ a]) apply assumption - apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def equiv_hyp_False equiv_fpu_False) done show ?thesis apply (simp add: scheduler_affects_equiv_def[abs_def]) @@ -618,10 +663,6 @@ crunch guarded_switch_to,schedule for idle_thread[wp]: "\(s :: det_state). P (idle_thread s)" (wp: crunch_wps simp: crunch_simps) -crunch guarded_switch_to, schedule - for kheap[wp]: "\s :: det_state. P (kheap s)" - (wp: dxo_wp_weak crunch_wps simp: crunch_simps) - end @@ -798,6 +839,19 @@ lemma midstrength_cur_domain_unobservable: apply (drule_tac x="(aa,ba)" in bspec,clarsimp+) done +lemma weak_cur_domain_unobservable: + "reads_respects_scheduler aag l (P and (\s. \ reads_scheduler_cur_domain aag l s)) f + \ weak_reads_respects_scheduler aag l + (P and (\s. \ reads_scheduler_cur_domain aag l s)) f" + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def scheduler_affects_equiv_def + equiv_valid_def2 equiv_valid_2_def weak_scheduler_affects_equiv_def) + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply clarsimp + apply (drule_tac x="(a,b)" in bspec,clarsimp+) + apply (drule_tac x="(aa,ba)" in bspec,clarsimp+) + done + lemma midstrength_reads_respects_scheduler_cases: assumes domains_distinct: "pas_domains_distinct aag" assumes b: "pasObjectAbs aag t \ reads_scheduler aag l @@ -967,20 +1021,30 @@ lemma globals_equiv_scheduler[wp]: end +definition valid_tcb_context_update where + "valid_tcb_context_update f \ + \tcb tcb'. arch_tcb_context_get (tcb_arch tcb) = arch_tcb_context_get (tcb_arch tcb') + \ arch_tcb_context_get (tcb_arch (f tcb)) = arch_tcb_context_get (tcb_arch (f tcb'))" + + locale Scheduler_IF_2 = Scheduler_IF_1 + fixes aag :: "'a subject_label PAS" + and cur_hyp_in_cur_domain :: "det_state \ bool" + and cur_fpu_in_cur_domain :: "det_state \ bool" assumes arch_switch_to_thread_globals_equiv_scheduler: "\invs and globals_equiv_scheduler sta\ arch_switch_to_thread thread \\_. globals_equiv_scheduler sta\" and arch_switch_to_idle_thread_globals_equiv_scheduler[wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" and arch_switch_to_thread_midstrength_reads_respects_scheduler[wp]: - "pas_domains_distinct aag + "pas_wellformed_noninterference aag \ midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) (do _ <- arch_switch_to_thread t; _ <- modify (cur_thread_update (\_. t)); modify (scheduler_action_update (\_. resume_cur_thread)) @@ -989,20 +1053,26 @@ locale Scheduler_IF_2 = Scheduler_IF_1 + "(\st. \P and globals_equiv st\ (f :: (det_state, unit) nondet_monad) \\_. globals_equiv st\) \ \P and globals_equiv_scheduler s\ f \\_. globals_equiv_scheduler s\" and arch_switch_to_idle_thread_unobservable: - "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and - scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ - arch_switch_to_idle_thread - \\_ s. scheduler_affects_equiv aag l st s\" + "pas_wellformed_noninterference aag + \ \(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_hyp_in_cur_domain and valid_silc_label aag and pas_refined aag\ + arch_switch_to_idle_thread + \\_ s. scheduler_affects_equiv aag l st s\" and arch_switch_to_thread_unobservable: - "\(\s. \ reads_scheduler_cur_domain aag l s) and - scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ - arch_switch_to_thread t - \\_ s. scheduler_affects_equiv aag l st s\" + "pas_wellformed_noninterference aag + \ \(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and + valid_silc_label aag and pas_refined aag\ + arch_switch_to_thread t + \\_ s. scheduler_affects_equiv aag l st s\" and next_domain_midstrength_equiv_scheduler: "equiv_valid (scheduler_equiv aag) (weak_scheduler_affects_equiv aag l) (midstrength_scheduler_affects_equiv aag l) \ next_domain" - and arch_prepare_next_domain_ev: - "equiv_valid_inv (I :: det_state \ det_state \ bool) A \ arch_prepare_next_domain" + and arch_prepare_next_domain_weak_scheduler_reads_respects: + "weak_reads_respects_scheduler aag l (invs and valid_silc_label aag) arch_prepare_next_domain" and dmo_resetTimer_reads_respects_scheduler: "reads_respects_scheduler aag l \ (do_machine_op resetTimer)" and ackInterrupt_reads_respects_scheduler: @@ -1012,8 +1082,9 @@ locale Scheduler_IF_2 = Scheduler_IF_1 + (\s. x = idle_thread s \ tc = idle_context s) and scheduler_affects_equiv aag l st\ thread_set (tcb_arch_update (arch_tcb_context_set tc)) x \\_. scheduler_affects_equiv aag l st\" - and set_object_reads_respects_scheduler[wp]: - "reads_respects_scheduler aag l \ (set_object ptr obj)" + and thread_set_reads_respects_scheduler: + "\f. reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" and arch_activate_idle_thread_reads_respects_scheduler[wp]: "reads_respects_scheduler aag l \ (arch_activate_idle_thread rv)" and arch_activate_idle_thread_silc_dom_equiv[wp]: @@ -1021,14 +1092,50 @@ locale Scheduler_IF_2 = Scheduler_IF_1 + and arch_activate_idle_thread_scheduler_affects_equiv[wp]: "arch_activate_idle_thread t \scheduler_affects_equiv aag l s\" and arch_prepare_next_domain_globals_equiv_scheduler[wp]: - "arch_prepare_next_domain \\s:: det_state. globals_equiv_scheduler st s\" + "\invs and globals_equiv_scheduler st\ arch_prepare_next_domain \\_. globals_equiv_scheduler st\" + and arch_switch_to_idle_thread_midstrength_reads_respects: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + and arch_switch_to_thread_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + arch_switch_to_thread t + \\_. silc_dom_equiv aag (st :: det_state)\" + and arch_switch_to_idle_thread_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + arch_switch_to_idle_thread + \\_. silc_dom_equiv aag st\" + and set_scheduler_action_cur_hyp_in_cur_domain[wp]: + "set_scheduler_action act \cur_hyp_in_cur_domain\" + and set_scheduler_action_cur_fpu_in_cur_domain[wp]: + "set_scheduler_action act \cur_fpu_in_cur_domain\" + and tcb_sched_action_cur_hyp_in_cur_domain[wp]: + "tcb_sched_action a t \cur_hyp_in_cur_domain\" + and tcb_sched_action_cur_fpu_in_cur_domain[wp]: + "tcb_sched_action a t \cur_fpu_in_cur_domain\" + and next_domain_snippet_cur_hyp_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; next_domain od \\_. cur_hyp_in_cur_domain\" + and next_domain_snippet_cur_fpu_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; next_domain od \\_. cur_fpu_in_cur_domain\" + and arch_prepare_next_domain_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + arch_prepare_next_domain + \\_. silc_dom_equiv aag st\" + and arch_prepare_next_domain_typ_at[wp]: + "\P. arch_prepare_next_domain \\s :: det_state. P (typ_at T ptr s)\" begin +crunch choose_thread + for silc_dom_equiv[wp]: "silc_dom_equiv aag (st :: det_state)" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + lemma switch_to_thread_midstrength_reads_respects_scheduler[wp]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) (switch_to_thread t >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: switch_to_thread_def) apply (subst oblivious_modify_swap[symmetric, OF tcb_action_oblivious_cur_thread]) @@ -1056,9 +1163,12 @@ lemma switch_to_thread_globals_equiv_scheduler[wp]: done lemma guarded_switch_to_thread_midstrength_reads_respects_scheduler[wp]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) (guarded_switch_to t >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: guarded_switch_to_def bind_assoc) apply (subst bind_assoc[symmetric]) @@ -1070,14 +1180,12 @@ lemma switch_to_idle_thread_globals_equiv_scheduler[wp]: "\invs and globals_equiv_scheduler sta\ switch_to_idle_thread \\_. globals_equiv_scheduler sta\" - apply (simp add: switch_to_idle_thread_def) - apply (wp | simp)+ - done + by (wpsimp simp: switch_to_idle_thread_def) lemmas globals_equiv_scheduler_inv = globals_equiv_scheduler_inv'[where P="\",simplified] lemma switch_to_idle_thread_midstrength_reads_respects_scheduler[wp]: - "midstrength_reads_respects_scheduler aag l (invs and pas_refined aag) + "midstrength_reads_respects_scheduler aag l (invs and pas_refined aag and valid_silc_label aag) (switch_to_idle_thread >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: switch_to_idle_thread_def) apply (rule equiv_valid_guard_imp) @@ -1085,12 +1193,7 @@ lemma switch_to_idle_thread_midstrength_reads_respects_scheduler[wp]: apply (rule bind_ev_general) apply (rule bind_ev_general) apply (rule store_cur_thread_midstrength_reads_respects) - apply (rule_tac P="\" and P'="\" in equiv_valid_inv_unobservable) - apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P=\]) - apply (wp globals_equiv_scheduler_inv silc_dom_lift | simp)+ - apply (wp midstrength_scheduler_affects_equiv_unobservable - | simp | wps)+ + apply (rule arch_switch_to_idle_thread_midstrength_reads_respects) apply (wp cur_thread_update_not_subject_reads_respects_scheduler arch_stit_invs | assumption | simp | fastforce)+ apply (clarsimp simp: scheduler_equiv_def) @@ -1219,9 +1322,11 @@ end context Scheduler_IF_2 begin lemma choose_thread_reads_respects_scheduler_cur_domain: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and valid_queues + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and valid_queues and (\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {})) (choose_thread >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: choose_thread_def bind_assoc) @@ -1241,8 +1346,12 @@ lemma choose_thread_reads_respects_scheduler_cur_domain: done lemma switch_to_idle_thread_unobservable: - "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and - scheduler_affects_equiv aag l st and (\s. cur_domain s = cur_domain st) and invs\ + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_hyp_in_cur_domain and valid_silc_label aag and pas_refined aag\ switch_to_idle_thread \\_. scheduler_affects_equiv aag l st\" apply (simp add: switch_to_idle_thread_def) @@ -1270,29 +1379,38 @@ lemma tcb_sched_action_unobservable: done lemma switch_to_thread_unobservable: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "\(\s. \ reads_scheduler_cur_domain aag l s) and - (\s. pasObjectAbs aag t \ reads_scheduler aag l) and - scheduler_affects_equiv aag l st and scheduler_equiv aag st and invs and pas_refined aag\ - switch_to_thread t - \\_. scheduler_affects_equiv aag l st\" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and scheduler_equiv aag st and + invs and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and + valid_silc_label aag and pas_refined aag\ + switch_to_thread t + \\_. scheduler_affects_equiv aag l st\" apply (simp add: switch_to_thread_def) - apply (wp cur_thread_update_unobservable arch_switch_to_idle_thread_unobservable - tcb_sched_action_unobservable arch_switch_to_thread_unobservable) + apply (wp cur_thread_update_unobservable tcb_sched_action_unobservable arch_switch_to_thread_unobservable) apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) done +(* need a wellformedness condition on silc labels so silc dom can be preserved *) lemma choose_thread_reads_respects_scheduler_other_domain: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_scheduler aag l ( invs and pas_refined aag and valid_queues and - (\s. \ reads_scheduler_cur_domain aag l s)) choose_thread" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "reads_respects_scheduler aag l (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. \ reads_scheduler_cur_domain aag l s)) + choose_thread" apply (rule reads_respects_scheduler_unobservable'' - [where P'="\s. \ reads_scheduler_cur_domain aag l s \ - invs s \ pas_refined aag s \ valid_queues s"]) + [where P'="\s. \ reads_scheduler_cur_domain aag l s \ invs s \ pas_refined aag s \ + valid_silc_label aag s \ cur_hyp_in_cur_domain s \ + cur_fpu_in_cur_domain s \ valid_queues s"]) apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P="invs"]) + apply (rule scheduler_equiv_lift'[where P="invs and valid_silc_label aag"]) apply (simp add: choose_thread_def) - apply (wp guarded_switch_to_lift silc_dom_lift | simp)+ + apply (wp guarded_switch_to_lift | simp)+ apply force apply (simp add: choose_thread_def) apply (wp guarded_switch_to_lift switch_to_idle_thread_unobservable switch_to_thread_unobservable @@ -1310,13 +1428,16 @@ lemma choose_thread_reads_respects_scheduler_other_domain: done lemma choose_thread_reads_respects_scheduler: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "midstrength_reads_respects_scheduler aag l (invs and pas_refined aag and valid_queues) + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "midstrength_reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) (choose_thread >>= (\_. set_scheduler_action resume_cur_thread))" apply (rule equiv_valid_cases [where P="\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {}"]) apply (rule equiv_valid_guard_imp) - apply (rule choose_thread_reads_respects_scheduler_cur_domain[OF domains_distinct]) + apply (rule choose_thread_reads_respects_scheduler_cur_domain[OF wellformed]) apply simp apply (rule equiv_valid_guard_imp) apply (rule midstrength_cur_domain_unobservable) @@ -1327,9 +1448,16 @@ lemma choose_thread_reads_respects_scheduler: apply (simp add: scheduler_equiv_def domain_fields_equiv_def) done +crunch next_domain + for typ_at[wp]: "\s. P (typ_at T ptr s)" + (wp: dxo_wp_weak simp: Let_def) + lemma next_domain_snippit: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_scheduler aag l (invs and pas_refined aag and valid_queues) + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and ct_in_cur_domain) (do dom_time \ gets domain_time; y \ when (dom_time = 0) (do y <- arch_prepare_next_domain; next_domain @@ -1340,26 +1468,30 @@ lemma next_domain_snippit: apply (simp add: when_def) apply (rule bind_ev_pre) apply (rule bind_ev_general) - apply (rule choose_thread_reads_respects_scheduler[OF domains_distinct]) + apply (rule choose_thread_reads_respects_scheduler[OF wellformed]) apply (rule ev_weaken_pre_relation[THEN if_ev]) apply (rule bind_ev_general) apply (rule next_domain_midstrength_equiv_scheduler) - apply (rule arch_prepare_next_domain_ev) - apply wp + apply (rule arch_prepare_next_domain_weak_scheduler_reads_respects) + apply wp+ apply fastforce apply (rule ev_weaken_pre_relation) apply wp apply fastforce - apply (wp next_domain_valid_queues)+ + apply (wpsimp wp: valid_silc_label_lift hoare_wp_simps + next_domain_snippet_cur_hyp_in_cur_domain + next_domain_snippet_cur_fpu_in_cur_domain)+ apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) done lemma schedule_choose_new_thread_read_respects_scheduler: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_scheduler aag l (invs and pas_refined aag and valid_queues) - schedule_choose_new_thread" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and ct_in_cur_domain) + schedule_choose_new_thread" unfolding schedule_choose_new_thread_def K_bind_def fun_app_def - by (rule next_domain_snippit[OF domains_distinct]) + by (rule next_domain_snippit[OF wellformed]) end @@ -1464,7 +1596,7 @@ lemma schedule_no_domain_switch: apply (wpsimp wp: hoare_drop_imps gts_wp simp: if_apply_def2 | simp add: schedule_choose_new_thread_def | wpc - | rule hoare_pre_cont[where f=next_domain] )+ + | rule hoare_pre_cont[where f=next_domain])+ done lemma schedule_no_domain_fields: @@ -1475,7 +1607,7 @@ lemma schedule_no_domain_fields: apply (wpsimp wp: hoare_drop_imps gts_wp simp: if_apply_def2 | simp add: schedule_choose_new_thread_def | wpc - | rule hoare_pre_cont[where f=next_domain] )+ + | rule hoare_pre_cont[where f=next_domain])+ done lemma set_scheduler_action_unobservable: @@ -1525,20 +1657,25 @@ lemma dec_domain_time_reads_respects_scheduler[wp]: apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def scheduler_globals_frame_equiv_def silc_dom_equiv_def states_equiv_for_def scheduler_affects_equiv_def equiv_for_def equiv_asids_def idle_equiv_def) + apply simp done end + context Scheduler_IF_2 begin lemma reads_respects_scheduler_invisible_domain_switch: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (\s. pas_refined aag s \ invs s \ valid_queues s - \ guarded_pas_domain aag s \ domain_time s = 0 - \ scheduler_action s = choose_new_thread - \ \ reads_scheduler_cur_domain aag l s) + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (\s. pas_refined aag s \ valid_silc_label aag s \ invs s \ valid_queues s + \ guarded_pas_domain aag s \ domain_time s = 0 + \ scheduler_action s = choose_new_thread \ ct_in_cur_domain s + \ cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s + \ \ reads_scheduler_cur_domain aag l s) schedule" + supply valid_silc_label_lift[wp] apply (rule equiv_valid_guard_imp) apply (simp add: schedule_def) apply (simp add: equiv_valid_def2) @@ -1553,7 +1690,7 @@ lemma reads_respects_scheduler_invisible_domain_switch: apply simp apply (rule equiv_valid_2_bind_pre) apply (rule equiv_valid_2) - apply (rule schedule_choose_new_thread_read_respects_scheduler[OF domains_distinct]) + apply (rule schedule_choose_new_thread_read_respects_scheduler[OF wellformed]) apply (rule_tac P="\" and S="\" and P'="pas_refined aag and (\s. runnable rva @@ -1602,10 +1739,12 @@ crunch schedule simp: crunch_simps) lemma choose_thread_unobservable: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "\(\s. \ reads_scheduler_cur_domain aag l s) and scheduler_affects_equiv aag l st and - invs and valid_queues and pas_refined aag and scheduler_equiv aag st\ + invs and valid_queues and pas_refined aag and valid_silc_label aag and + scheduler_equiv aag st and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain\ choose_thread \\_. scheduler_affects_equiv aag l st\" apply (simp add: choose_thread_def) @@ -1627,10 +1766,12 @@ lemma tcb_sched_action_scheduler_equiv[wp]: by (rule scheduler_equiv_lift; wp) lemma schedule_choose_new_thread_schedule_affects_no_switch: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows - "\\s. invs s \ pas_refined aag s \ valid_queues s \ domain_time s \ 0 + "\\s. invs s \ pas_refined aag s \ valid_silc_label aag s \ valid_queues s \ domain_time s \ 0 \ \ reads_scheduler_cur_domain aag l s \ scheduler_equiv aag st s + \ cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s \ scheduler_affects_equiv aag l st s \ cur_domain st = cur_domain s\ schedule_choose_new_thread \\_. scheduler_affects_equiv aag l st\" @@ -1638,26 +1779,40 @@ lemma schedule_choose_new_thread_schedule_affects_no_switch: by (wpsimp wp: set_scheduler_action_unobservable choose_thread_unobservable hoare_pre_cont[where f=next_domain]) +lemma silc_dom_equiv_updates'[simp]: + "\f. silc_dom_equiv aag st (domain_index_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (domain_time_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (cur_domain_update f s) = silc_dom_equiv aag st s" + by (auto simp add: silc_dom_equiv_def equiv_for_def) + +crunch next_domain + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: dxo_wp_weak simp: Let_def) + +crunch schedule + for silc_dom_equiv[wp]: "silc_dom_equiv aag (st :: det_state)" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + lemma reads_respects_scheduler_invisible_no_domain_switch: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l - (\s. pas_refined aag s \ invs s \ valid_sched s \ guarded_pas_domain aag s - \ domain_time s \ 0 \ \ reads_scheduler_cur_domain aag l s) - schedule" - supply if_split[split del] + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (\s. pas_refined aag s \ valid_silc_label aag s \ invs s \ valid_sched s \ + guarded_pas_domain aag s \ cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s \ + domain_time s \ 0 \ \ reads_scheduler_cur_domain aag l s) + schedule" + supply if_split[split del] valid_silc_label_lift[wp] apply (rule reads_respects_scheduler_unobservable''[where P=Q and P'=Q and Q=Q for Q]) apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P="invs and (\s. domain_time s \ 0)"]) - apply (wp schedule_no_domain_switch schedule_no_domain_fields - silc_dom_lift | simp)+ + apply (rule scheduler_equiv_lift'[where P="invs and valid_silc_label aag and (\s. domain_time s \ 0)"]) + apply (wp schedule_no_domain_switch schedule_no_domain_fields| simp)+ apply (simp add: schedule_def) apply (wp guarded_switch_to_lift scheduler_equiv_lift schedule_choose_new_thread_schedule_affects_no_switch set_scheduler_action_unobservable tcb_sched_action_unobservable - switch_to_thread_unobservable silc_dom_lift + switch_to_thread_unobservable gts_wp hoare_vcg_all_lift hoare_vcg_disj_lift @@ -1670,65 +1825,71 @@ lemma reads_respects_scheduler_invisible_no_domain_switch: apply (wp hoare_if[rotated]) apply (wp tcb_sched_action_unobservable gts_wp schedule_choose_new_thread_schedule_affects_no_switch - hoare_vcg_all_lift hoare_vcg_imp_lift' )+ + hoare_vcg_all_lift hoare_vcg_imp_lift')+ apply (clarsimp simp: if_apply_def2) (* slow 15s *) by (safe; (fastforce simp: switch_thread_runnable | fastforce dest!: switch_to_cur_domain cur_thread_cur_domain | fastforce simp: st_tcb_at_def obj_at_def))+ + lemma read_respects_scheduler_switch_thread_case: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l - (invs and valid_queues and (\s. scheduler_action s = switch_thread t) - and valid_sched_action and pas_refined aag) - (do tcb_sched_action tcb_sched_enqueue t; - set_scheduler_action choose_new_thread; - schedule_choose_new_thread - od)" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and valid_queues and (\s. scheduler_action s = switch_thread t) + and valid_sched_action and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) + (do tcb_sched_action tcb_sched_enqueue t; + set_scheduler_action choose_new_thread; + schedule_choose_new_thread + od)" unfolding schedule_choose_new_thread_def apply (rule equiv_valid_guard_imp) apply simp apply (rule bind_ev) apply (rule bind_ev) - apply (rule next_domain_snippit[OF domains_distinct]) + apply (rule next_domain_snippit[OF wellformed]) apply wp[1] apply (simp add: pred_conj_def) apply (rule hoare_vcg_conj_lift) - apply (wp tcb_action_reads_respects_scheduler)+ + apply (wp tcb_action_reads_respects_scheduler valid_silc_label_lift)+ apply (clarsimp simp: valid_sched_action_def weak_valid_sched_action_def) done lemma read_respects_scheduler_switch_thread_case_app: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l - (invs and valid_queues and (\s. scheduler_action s = switch_thread t) - and valid_sched_action and pas_refined aag) - (do tcb_sched_action tcb_sched_append t; - set_scheduler_action choose_new_thread; - schedule_choose_new_thread - od)" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and valid_queues and (\s. scheduler_action s = switch_thread t) + and valid_sched_action and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) + (do tcb_sched_action tcb_sched_append t; + set_scheduler_action choose_new_thread; + schedule_choose_new_thread + od)" unfolding schedule_choose_new_thread_def apply (rule equiv_valid_guard_imp) apply simp apply (rule bind_ev) apply (rule bind_ev) - apply (rule next_domain_snippit[OF domains_distinct]) + apply (rule next_domain_snippit[OF wellformed]) apply wp[1] apply (simp add: pred_conj_def) apply (rule hoare_vcg_conj_lift) - apply (wp tcb_action_reads_respects_scheduler)+ + apply (wp tcb_action_reads_respects_scheduler valid_silc_label_lift)+ apply (clarsimp simp: valid_sched_action_def weak_valid_sched_action_def) done lemma schedule_reads_respects_scheduler_cur_domain: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (invs and pas_refined aag and valid_sched - and guarded_pas_domain aag - and (\s. reads_scheduler_cur_domain aag l s)) schedule" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_sched + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and guarded_pas_domain aag and (\s. reads_scheduler_cur_domain aag l s)) + schedule" + supply valid_silc_label_lift[wp] apply (simp add: schedule_def schedule_switch_thread_fastfail_def) apply (rule equiv_valid_guard_imp) apply (rule bind_ev)+ @@ -1738,17 +1899,17 @@ lemma schedule_reads_respects_scheduler_cur_domain: prefer 2 (* choose new thread *) apply (rule bind_ev) - apply (rule schedule_choose_new_thread_read_respects_scheduler[OF domains_distinct]) + apply (rule schedule_choose_new_thread_read_respects_scheduler[OF wellformed]) apply ((wpsimp wp: when_ev gts_wp get_thread_state_reads_respects_scheduler)+)[2] (* switch thread *) apply (rule bind_ev)+ apply (rule if_ev) - apply (rule read_respects_scheduler_switch_thread_case[OF domains_distinct]) + apply (rule read_respects_scheduler_switch_thread_case[OF wellformed]) apply (rule if_ev) - apply (rule read_respects_scheduler_switch_thread_case_app[OF domains_distinct]) + apply (rule read_respects_scheduler_switch_thread_case_app[OF wellformed]) apply simp apply (rule ev_weaken_pre_relation) - apply (rule guarded_switch_to_thread_midstrength_reads_respects_scheduler[OF domains_distinct]) + apply (rule guarded_switch_to_thread_midstrength_reads_respects_scheduler[OF wellformed]) apply fastforce apply (rule gets_highest_prio_ev_from_weak_sae) apply fastforce @@ -1781,11 +1942,10 @@ lemma schedule_reads_respects_scheduler_cur_domain: apply (frule st_tcb_at_tcb_at, drule (1) etcb_in_domains_of_state) apply (drule (1) bspec) apply simp - by (metis Int_emptyI assms pas_domains_distinct_inj) + by (metis Int_emptyI assms pas_domains_distinct_inj[OF domains_distinct]) end - lemma switch_to_cur_domain': "\ valid_sched_action s; scheduler_action s = switch_thread x; pas_refined aag s \ \ pasObjectAbs aag x \ pasDomainAbs aag (cur_domain s)" @@ -1825,21 +1985,24 @@ definition tick_done where "tick_done s \ domain_time s = 0 \ scheduler_action s = choose_new_thread" lemma schedule_reads_respects_scheduler: - assumes domains_distinct: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (invs and pas_refined aag and valid_sched - and guarded_pas_domain aag and tick_done) schedule" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_sched + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and guarded_pas_domain aag and tick_done) + schedule" apply (rule_tac P="\s. reads_scheduler_cur_domain aag l s" in equiv_valid_cases) apply (rule equiv_valid_guard_imp) - apply (rule schedule_reads_respects_scheduler_cur_domain[OF domains_distinct]) + apply (rule schedule_reads_respects_scheduler_cur_domain[OF wellformed]) apply simp apply (rule_tac P="\s. domain_time s = 0" in equiv_valid_cases) apply (rule equiv_valid_guard_imp) - apply (rule reads_respects_scheduler_invisible_domain_switch[OF domains_distinct]) + apply (rule reads_respects_scheduler_invisible_domain_switch[OF wellformed]) apply (clarsimp simp: tick_done_def valid_sched_def) apply (rule equiv_valid_guard_imp) - apply (rule reads_respects_scheduler_invisible_no_domain_switch[OF domains_distinct]) + apply (rule reads_respects_scheduler_invisible_no_domain_switch[OF wellformed]) apply simp apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def)+ done @@ -1914,13 +2077,8 @@ lemma thread_set_time_slice_reads_respect_scheduler[wp]: "reads_respects_scheduler aag l (invs and (\s. t \ idle_thread s \ pasObjectAbs aag t \ SilcLabel) and guarded_pas_domain aag) (thread_set (tcb_time_slice_update f) t)" - apply (rule reads_respects_scheduler_cases[where P'=\]) - prefer 3 - apply (rule reads_respects_scheduler_unobservable'') - apply (wp | simp | elim conjE)+ - apply (simp add: thread_set_def) - apply wp - apply (fastforce simp: scheduler_affects_equiv_def get_tcb_def states_equiv_for_def equiv_for_def)+ + apply (wp thread_set_reads_respects_scheduler) + apply (clarsimp simp: valid_tcb_context_update_def) done lemma thread_set_time_slice_pas_refined[wp]: @@ -2005,7 +2163,7 @@ lemma timer_tick_reads_respects_scheduler_unobservable: apply (intro impI conjI allI) apply (fastforce dest: st_tcb_at_not_idle_thread) apply (fastforce dest!: cur_thread_cur_domain)+ - apply ((clarsimp simp add: st_tcb_at_def obj_at_def valid_sched_def )+)[2] + apply ((clarsimp simp add: st_tcb_at_def obj_at_def valid_sched_def)+)[2] apply (fastforce dest: st_tcb_at_not_idle_thread) apply (fastforce dest!: cur_thread_cur_domain) apply force @@ -2034,22 +2192,6 @@ lemma gets_ev': "equiv_valid_inv I A (P and K(\s t. P s \ P t \ I s t \ A s t \ f s = f t)) (gets f)" by (clarsimp simp: equiv_valid_def2 equiv_valid_2_def gets_def get_def bind_def return_def) -lemma irq_inactive_or_timer: - "\domain_sep_inv False st and Q IRQTimer and Q IRQInactive\ - get_irq_state irq - \Q\" - apply (simp add:get_irq_state_def) - apply wp - apply (clarsimp simp add: domain_sep_inv_def) - apply (drule_tac x=irq in spec) - apply (drule_tac x=a in spec) (*makes yellow variables*) - apply (drule_tac x=b in spec) - apply (drule_tac x=aa in spec, drule_tac x=ba in spec) - apply clarsimp - apply (case_tac "interrupt_states st irq") - apply clarsimp+ - done - (*FIXME: MOVE corres-like statement for out of step equiv_valid. Move to scheduler_IF?*) lemma equiv_valid_2_bind_right: "\ \rv. equiv_valid_2 D A A R T' (Q rv) g' (g rv); @@ -2095,16 +2237,15 @@ context Scheduler_IF_2 begin lemma handle_interrupt_reads_respects_scheduler: assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (invs and guarded_pas_domain aag and pas_refined aag and - valid_sched and domain_sep_inv False st and silc_inv aag st' and - K (irq \ maxIRQ)) - (handle_interrupt irq)" - apply (simp add: handle_interrupt_def ) - apply (rule conjI; rule impI ) + shows "reads_respects_scheduler aag l (invs and guarded_pas_domain aag and pas_refined aag + and valid_sched and domain_sep_inv False st + and silc_inv aag st' and K (irq \ maxIRQ)) + (handle_interrupt irq)" + apply (simp add: handle_interrupt_def) + apply (rule conjI; rule impI) apply (rule gen_asm_ev) apply simp - apply (wp modify_wp | simp )+ + apply (wp modify_wp | simp)+ apply (rule ackInterrupt_reads_respects_scheduler) apply (rule_tac Q="rv = IRQTimer \ rv = IRQInactive" in gen_asm_ev(2)) apply (elim disjE) @@ -2124,25 +2265,51 @@ lemma thread_set_scheduler_equiv[wp]: apply (wpsimp wp: thread_set_context_globals_equiv | simp)+ done +lemma set_thread_state_def2: + "set_thread_state ref ts \ do + thread_set (tcb_state_update (\_. ts)) ref; + set_thread_state_act ref + od" + by (simp add: set_thread_state_def thread_set_def bind_assoc) + + lemma sts_reads_respects_scheduler: "reads_respects_scheduler aag l (K (pasObjectAbs aag rv \ reads_scheduler aag l) and reads_scheduler_cur_domain aag l - and valid_idle and (\s. rv \ idle_thread s)) + and valid_idle and valid_arch_state + and (\s. rv \ idle_thread s)) (set_thread_state rv st)" - apply (simp add: set_thread_state_def) + apply (simp add: set_thread_state_def2) apply (simp add: set_thread_state_act_def) - apply (wp when_ev get_thread_state_reads_respects_scheduler gts_wp set_object_wp) + apply (wp when_ev get_thread_state_reads_respects_scheduler gts_wp + set_object_wp thread_set_reads_respects_scheduler thread_set_wp) apply (clarsimp simp: get_tcb_scheduler_equiv valid_idle_def pred_tcb_at_def obj_at_def) + apply (clarsimp simp: valid_tcb_context_update_def) + done + +lemma as_user_def2: + "as_user t m = do + tcb \ gets_the (get_tcb t); + (a,uc) \ select_f (m (arch_tcb_context_get (tcb_arch tcb))); + thread_set (\tcb. tcb\tcb_arch := arch_tcb_context_set uc (tcb_arch tcb)\) t; + return a + od" + apply (simp add: thread_set_def as_user_def) + apply (rule ext) + apply (rule bind_apply_cong [OF refl])+ + apply (simp add: select_f_def in_monad gets_the_def gets_def) + apply (clarsimp simp add: get_def bind_def return_def assert_opt_def) done lemma as_user_reads_respects_scheduler: "reads_respects_scheduler aag l (K (pasObjectAbs aag rv \ reads_scheduler aag l) and - (\s. rv \ idle_thread s) and K (det f)) + (\s. rv \ idle_thread s) and valid_arch_state and K (det f)) (as_user rv f)" apply (rule gen_asm_ev) - apply (simp add: as_user_def) - apply (wp select_f_ev | wpc | simp)+ + apply (simp add: as_user_def2) + apply (wp select_f_ev thread_set_reads_respects_scheduler | wpc | simp)+ apply (clarsimp simp: get_tcb_scheduler_equiv) + apply (clarsimp simp: valid_tcb_context_update_def) done end @@ -2177,15 +2344,6 @@ lemma sts_silc_dom_equiv[wp]: apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) done -lemma as_user_silc_dom_equiv[wp]: - "\K (pasObjectAbs aag x \ SilcLabel) and silc_dom_equiv aag st\ - as_user x f - \\_. silc_dom_equiv aag st\" - apply (simp add: as_user_def) - apply (wp dxo_wp_weak set_object_wp | wpc | simp)+ - apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) - done - lemma set_scheduler_action_wp[wp]: "\\s. P () (s\scheduler_action := a\)\ set_scheduler_action a \P\" by (simp add: set_scheduler_action_def | wp)+ @@ -2241,7 +2399,6 @@ lemma agnostic_to_ev2: shows "equiv_valid_2 I A B (\r r'. r = (g u) \ r' = (g u')) P P (f u) (f u')" proof - have b: "\a b s u. (a,b) \ fst (f u s) \ a = g u" - apply (erule use_valid[OF _ ret_agnostic]) apply simp done @@ -2282,7 +2439,7 @@ lemma op_eq_unit_dc: lemma cur_thread_idle': "\ valid_idle s; only_idle s \ \ ct_idle s = (cur_thread s = idle_thread s)" apply (rule iffI) - apply (clarsimp simp: only_idle_def ct_in_state_def ) + apply (clarsimp simp: only_idle_def ct_in_state_def) apply (clarsimp simp: valid_idle_def ct_in_state_def pred_tcb_at_def obj_at_def) done @@ -2295,6 +2452,10 @@ lemma cur_thread_idle: context Scheduler_IF_2 begin +lemma silc_inv_valid_silc_label[elim!]: + "silc_inv aag st s \ valid_silc_label aag s" + by (simp add: silc_inv_def valid_silc_label_def) + lemma activate_thread_reads_respects_scheduler[wp]: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects_scheduler aag l (invs and silc_inv aag st and guarded_pas_domain aag) @@ -2314,7 +2475,7 @@ lemma activate_thread_reads_respects_scheduler[wp]: guarded_pas_domain aag s \ invs s"]) apply ((wp scheduler_equiv_lift'[where P="invs and silc_inv aag st"] globals_equiv_scheduler_inv'[where P="valid_arch_state and valid_idle"] - set_thread_state_globals_equiv gts_wp + set_thread_state_globals_equiv gts_wp valid_silc_label_lift | wpc | clarsimp simp: restart_not_idle silc_inv_not_cur_thread | force)+)[1] @@ -2328,15 +2489,8 @@ lemma thread_set_reads_respect_scheduler[wp]: and (\s. t = idle_thread s \ tc = idle_context s) and guarded_pas_domain aag) (thread_set (tcb_arch_update (arch_tcb_context_set tc)) t)" - apply (rule reads_respects_scheduler_cases[where P'=\]) - prefer 3 - apply (rule reads_respects_scheduler_unobservable'') - apply (wp | simp | elim conjE)+ - apply (simp add: thread_set_def) - apply wp - apply (fastforce simp: scheduler_affects_equiv_def get_tcb_def states_equiv_for_def - equiv_for_def scheduler_equiv_def domain_fields_equiv_def equiv_asids_def - split: option.splits kernel_object.splits)+ + apply (wp thread_set_reads_respects_scheduler) + apply (clarsimp simp: valid_tcb_context_update_def) done lemma context_update_cur_thread_snippit_unobservable: diff --git a/proof/infoflow/Syscall_IF.thy b/proof/infoflow/Syscall_IF.thy index e54755b18f..7ac4717621 100644 --- a/proof/infoflow/Syscall_IF.thy +++ b/proof/infoflow/Syscall_IF.thy @@ -61,23 +61,29 @@ locale Syscall_IF_1 = and arch_mask_irq_signal_globals_equiv[wp]: "arch_mask_irq_signal irq \globals_equiv st\" and handle_reserved_irq_globals_equiv[wp]: - "handle_reserved_irq irq \globals_equiv st\" + "\globals_equiv st and invs\ handle_reserved_irq irq \\_. globals_equiv st\" and handle_spurious_irq_globals_equiv[wp]: "handle_spurious_irq \globals_equiv st\" and arch_prepare_set_domain_globals_equiv[wp]: - "arch_prepare_set_domain t new_dom \globals_equiv st\" + "\globals_equiv st and invs\ arch_prepare_set_domain t new_dom \\_. globals_equiv st\" and arch_prepare_set_domain_valid_arch_state[wp]: "arch_prepare_set_domain t new_dom \\s :: det_state. valid_arch_state s\" and handle_vm_fault_reads_respects: - "reads_respects aag l (K (is_subject aag thread)) (handle_vm_fault thread vmfault_type)" + "reads_respects aag l (pas_refined aag and valid_cur_hyp + and schact_is_rct and ct_in_cur_domain + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_vm_fault thread vmfault_type)" and handle_hypervisor_fault_reads_respects: - "reads_respects aag l \ (handle_hypervisor_fault thread hypfault_type)" + "pas_domains_distinct aag \ + reads_respects aag l (invs and pas_refined aag and pas_cur_domain aag + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_hypervisor_fault thread hypfault_type)" and handle_vm_fault_globals_equiv: "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ handle_vm_fault thread vmfault_type \\_. globals_equiv st\" and handle_hypervisor_fault_globals_equiv: - "handle_hypervisor_fault thread hypfault_type \globals_equiv st\" + "\globals_equiv st and invs\ handle_hypervisor_fault thread hypfault_type \\_. globals_equiv st\" and arch_activate_idle_thread_globals_equiv[wp]: "arch_activate_idle_thread t \globals_equiv st\" and select_f_setNextPC_reads_respects[wp]: @@ -264,7 +270,7 @@ lemma invoke_cnode_reads_respects_f: apply (clarsimp simp: cnode_inv_auth_derivations_def authorised_cnode_inv_def) apply (auto intro: real_cte_emptyable_strg[rule_format] simp: silc_inv_def reads_equiv_f_def requiv_cur_thread_eq caps_of_state_cteD - aag_cap_auth_recycle_EndpointCap cte_wp_at_weak_derived_ReplyCap ) + aag_cap_auth_recycle_EndpointCap cte_wp_at_weak_derived_ReplyCap) done lemma cap_swap_reads_respects_g: @@ -792,12 +798,6 @@ lemma handle_recv_reads_respects_f_g: apply simp+ done -lemma dmo_return_reads_respects: - "reads_respects aag l \ (do_machine_op (return ()))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects; wp) - done - lemma dmo_return_globals_equiv: "do_machine_op (return ()) \globals_equiv st\" by simp @@ -886,7 +886,9 @@ lemma handle_interrupt_globals_equiv: done lemma handle_vm_fault_reads_respects_g: - "reads_respects_g aag l (K (is_subject aag t) and (valid_arch_state and (\s. t \ idle_thread s))) + "reads_respects_g aag l (pas_refined aag and valid_cur_hyp and schact_is_rct and ct_in_cur_domain + and is_subject aag \ cur_thread and K (is_subject aag t) + and (valid_arch_state and (\s. t \ idle_thread s))) (handle_vm_fault t vmfault_type)" apply (rule reads_respects_g) apply (rule handle_vm_fault_reads_respects) @@ -896,23 +898,28 @@ lemma handle_vm_fault_reads_respects_g: done lemma handle_hypervisor_fault_reads_respects_g: - "reads_respects_g aag l \ (handle_hypervisor_fault thread hyp)" - apply (rule reads_respects_g[where P="\" and Q="\", simplified]) - apply (rule handle_hypervisor_fault_reads_respects) - apply (rule doesnt_touch_globalsI) - apply (wp handle_hypervisor_fault_globals_equiv) + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_g aag l (invs and pas_refined aag and pas_cur_domain aag + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_hypervisor_fault thread hyp)" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_g[OF handle_hypervisor_fault_reads_respects]) + apply wp + apply (rule doesnt_touch_globalsI) + apply (wp handle_hypervisor_fault_globals_equiv) apply simp done (* we explicitly exclude the case where ev is Interrupt since this is a scheduler action *) lemma handle_event_reads_respects_f_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_f_g aag l (silc_inv aag st and only_timer_irq_inv irq st' and einvs - and schact_is_rct and is_subject aag \ cur_thread - and domain_sep_inv (pasMaySendIrqs aag) st' - and (\s. ev \ Interrupt \ (ct_active s)) - and pas_refined aag and pas_cur_domain aag - and K (\ pasMaySendIrqs aag)) + shows "reads_respects_f_g aag l (silc_inv aag st and only_timer_irq_inv irq st' + and einvs and valid_cur_hyp + and schact_is_rct and is_subject aag \ cur_thread + and domain_sep_inv (pasMaySendIrqs aag) st' + and (\s. ev \ Interrupt \ (ct_active s)) + and pas_refined aag and pas_cur_domain aag + and K (\ pasMaySendIrqs aag)) (handle_event ev)" apply (rule gen_asm_ev) apply (rule_tac Q="ev \ Interrupt" in equiv_valid_hoist_guard) @@ -953,17 +960,22 @@ lemma handle_event_reads_respects_f_g: | clarsimp simp: reads_equiv_f_g_conj requiv_g_cur_thread_eq schact_is_rct_simple | wpc | intro impI conjI allI)+ apply (rule equiv_valid_guard_imp) - apply ((wp reads_respects_f_g'[OF handle_hypervisor_fault_reads_respects_g, where Q=\] + apply ((wp reads_respects_f_g'[OF handle_hypervisor_fault_reads_respects_g] handle_hypervisor_fault_silc_inv | simp)+)[1] - prefer 2 - apply ((wp reads_respects_f_g'[OF handle_fault_reads_respects_g, where st=st] | simp)+)[1] - apply (simp add: validE_E_def) - apply (wp hv_invs handle_vm_fault_silc_inv)+ - apply (simp add: invs_imps invs_mdb invs_valid_idle)+ + apply simp + apply (wp hv_invs handle_vm_fault_silc_inv)+ apply (fastforce simp: requiv_g_cur_thread_eq reads_equiv_f_g_conj ct_active_not_idle) done +lemma getRestartPC_reads_respects: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (as_user t getRestartPC)" + by (wpsimp wp: as_user_reads_respects simp: det_getRestartPC) + +lemma setNextPC_reads_respects: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (as_user t (setNextPC pc))" + by (wpsimp wp: as_user_reads_respects simp: det_setNextPC) + lemma activate_thread_reads_respects: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects aag (l :: 'a subject_label) @@ -971,9 +983,9 @@ lemma activate_thread_reads_respects: activate_thread" apply (simp add: activate_thread_def) apply (wpsimp wp: set_thread_state_runnable_reads_respects get_thread_state_rev) - by (wp set_object_reads_respects get_thread_state_rev - | simp add: as_user_def select_f_returns tcb_at_st_tcb_at[symmetric] cur_tcb_def - | rule hoare_drop_imps conjI requiv_cur_thread_eq requiv_get_tcb_eq' + by (wpsimp wp: set_object_reads_respects get_thread_state_rev + getRestartPC_reads_respects setNextPC_reads_respects + | rule hoare_drop_imps conjI requiv_cur_thread_eq | clarsimp simp: st_tcb_at_def obj_at_def is_tcb_def)+ lemma activate_thread_globals_equiv: diff --git a/proof/infoflow/Tcb_IF.thy b/proof/infoflow/Tcb_IF.thy index 8ebed3048a..1188438143 100644 --- a/proof/infoflow/Tcb_IF.thy +++ b/proof/infoflow/Tcb_IF.thy @@ -22,7 +22,7 @@ lemma setup_reply_master_globals_equiv: setup_reply_master t \\_. globals_equiv st\" unfolding setup_reply_master_def - apply (wp set_cap_globals_equiv'' set_original_globals_equiv get_cap_wp) + apply (wp set_cap_globals_equiv set_original_globals_equiv get_cap_wp) apply clarsimp done @@ -42,7 +42,7 @@ lemma cap_swap_for_delete_globals_equiv[wp]: cap_swap_for_delete a b \\_. globals_equiv st\" unfolding cap_swap_for_delete_def cap_swap_def set_original_def - by (wp modify_wp set_cdt_globals_equiv set_cap_globals_equiv'' dxo_wp_weak | simp)+ + by (wp modify_wp set_cdt_globals_equiv set_cap_globals_equiv dxo_wp_weak | simp)+ lemma rec_del_preservation2': assumes finalise_cap_P: "\cap final. \R cap and P\ finalise_cap cap final \\_. P\" @@ -191,7 +191,7 @@ locale Tcb_IF_1 = and arch_post_modify_registers_reads_respects_f[wp]: "reads_respects_f aag l \ (arch_post_modify_registers cur t)" and arch_get_sanitise_register_info_reads_respects_f[wp]: - "reads_respects_f aag l \ (arch_get_sanitise_register_info t)" + "reads_respects_f aag l (K (aag_can_read_or_affect aag l t)) (arch_get_sanitise_register_info t)" begin crunch cap_swap_for_delete @@ -206,7 +206,7 @@ lemma rec_del_globals_equiv: rec_del_preservation2[where Q="valid_arch_state" and R="\cap s. invs s \ valid_cap cap s \ (\p. cap = ThreadCap p \ p \ idle_thread s)"]) - apply (wp set_cap_globals_equiv'') + apply (wp set_cap_globals_equiv) apply simp apply (wp empty_slot_globals_equiv)+ apply simp @@ -295,9 +295,12 @@ locale Tcb_IF_2 = Tcb_IF_1 + and K (authorised_tcb_inv aag ti \ authorised_tcb_inv_extra aag ti)) (invoke_tcb ti)" and arch_post_set_flags_globals_equiv[wp]: - "arch_post_set_flags t flags \globals_equiv st\" + "\globals_equiv st and invs\ + arch_post_set_flags t flags + \\_. globals_equiv st\" and arch_post_set_flags_reads_respects_f: - "reads_respects_f aag l \ (arch_post_set_flags t flags)" + "pas_domains_distinct aag \ + reads_respects_f aag l (silc_inv aag st and valid_cur_fpu and K (is_subject aag t)) (arch_post_set_flags t flags)" begin crunch suspend, restart @@ -325,9 +328,8 @@ lemma invoke_tcb_globals_equiv: weak_if_wp')+ apply (intro conjI impI; clarsimp simp: no_cap_to_idle_thread)+ apply (simp del: invoke_tcb.simps tcb_inv_wf.simps) - apply (wp invoke_tcb_thread_preservation cap_delete_globals_equiv - cap_insert_globals_equiv'' thread_set_globals_equiv set_mcpriority_globals_equiv - set_priority_globals_equiv + apply (wp invoke_tcb_thread_preservation cap_delete_globals_equiv cap_insert_globals_equiv + thread_set_globals_equiv set_mcpriority_globals_equiv set_priority_globals_equiv | fastforce)+ done @@ -417,7 +419,7 @@ lemma set_mcpriority_reads_respects: assumes domains_distinct: "pas_domains_distinct aag" shows "reads_respects aag (l :: 'a subject_label) \ (set_mcpriority x y)" unfolding set_mcpriority_def - by (rule thread_set_reads_respects[OF domains_distinct]) + by (rule thread_set_reads_respects) lemma checked_cap_insert_only_timer_irq_inv: "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \only_timer_irq_inv irq (st :: det_state)\" @@ -481,6 +483,10 @@ lemma thread_set_tcb_flags_update_silc_inv[wp]: "thread_set (tcb_flags_update f) t \silc_inv aag st\" by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) +crunch set_flags + for silc_inv[wp]: "silc_inv aag st" + (ignore: thread_set) + lemma set_flags_reads_respects_f: assumes "pas_domains_distinct aag" shows "reads_respects_f aag l (silc_inv aag st) (set_flags t flags)" @@ -528,7 +534,7 @@ lemma invoke_tcb_reads_respects_f: idle_no_ex_cap[OF invs_valid_global_refs invs_valid_objs]\) defer apply ((wp suspend_reads_respects_f[where st=st] restart_reads_respects_f[where st=st] - | simp add: authorised_tcb_inv_def )+)[2] + | simp add: authorised_tcb_inv_def)+)[2] \ \NotificationControl\ apply (rename_tac option) apply (case_tac option, simp_all)[1] diff --git a/proof/infoflow/UserOp_IF.thy b/proof/infoflow/UserOp_IF.thy index 9e720918d7..fc15748bbd 100644 --- a/proof/infoflow/UserOp_IF.thy +++ b/proof/infoflow/UserOp_IF.thy @@ -116,6 +116,14 @@ locale UserOp_IF_1 = arch_globals_equiv ct it kh kh' as as' ms ms'" "\f. arch_globals_equiv ct it kh kh' as as' ms (device_state_update f ms') = arch_globals_equiv ct it kh kh' as as' ms ms'" + and no_hyp_modify[wp,simp]: + "\f. no_hyp (modify (\ms :: machine_state. ms\underlying_memory := f ms\))" + "\f. no_hyp (modify (\ms :: machine_state. ms\device_state := f ms\))" + "\f. no_hyp (modify (\ms :: machine_state. ms\machine_state_rest := f ms\))" + and no_fpu_modify[wp,simp]: + "\f. no_fpu (modify (\ms :: machine_state. ms\underlying_memory := f ms\))" + "\f. no_fpu (modify (\ms :: machine_state. ms\device_state := f ms\))" + "\f. no_fpu (modify (\ms :: machine_state. ms\machine_state_rest := f ms\))" begin (* Assumptions: @@ -132,13 +140,10 @@ lemma dmo_user_memory_update_reads_respects_g: apply (subgoal_tac "reads_respects aag l \ (do_machine_op (user_memory_update um))") apply (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad do_machine_op_def user_memory_update_def select_f_def idle_equiv_def) - apply (rule use_spec_ev) apply (simp add: user_memory_update_def) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: equiv_valid_def2) - apply (rule modify_ev2) - apply (fastforce intro: equiv_forI elim: equiv_forE split: option.splits) - apply (wp | simp)+ + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (fastforce intro: equiv_forI elim: equiv_forE split: option.splits) + apply wpsimp+ done lemma dmo_device_state_update_reads_respects_g: @@ -150,13 +155,10 @@ lemma dmo_device_state_update_reads_respects_g: apply (subgoal_tac "reads_respects aag l \ (do_machine_op (device_memory_update um))") apply (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad do_machine_op_def device_memory_update_def select_f_def idle_equiv_def) - apply (rule use_spec_ev) apply (simp add: device_memory_update_def) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: equiv_valid_def2) - apply (rule modify_ev2) - apply (fastforce intro: map_add_eq equiv_forI elim: equiv_forE split: option.splits) - apply (wp | simp)+ + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (fastforce intro: map_add_eq equiv_forI elim: equiv_forE split: option.splits) + apply wpsimp+ done end From a0af1c6530dcec6514ce1c3de9b8558c9f76dfe1 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Wed, 10 Jun 2026 12:13:06 +1000 Subject: [PATCH 06/11] aarch64 infoflow: prove refinement Signed-off-by: Ryan Barry --- .../refine/AARCH64/ArchADT_IF_Refine.thy | 81 +++++--- .../refine/AARCH64/ArchADT_IF_Refine_C.thy | 133 ++++++++++-- proof/infoflow/refine/ADT_IF_Refine.thy | 16 +- proof/infoflow/refine/ADT_IF_Refine_C.thy | 196 +++++++++--------- 4 files changed, 281 insertions(+), 145 deletions(-) diff --git a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy index 3fd515bd2c..13186268c7 100644 --- a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy +++ b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy @@ -8,7 +8,7 @@ theory ArchADT_IF_Refine imports ADT_IF_Refine begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems ADT_IF_Refine_assms @@ -167,7 +167,7 @@ lemma do_user_op_if_corres[ADT_IF_Refine_assms]: apply (rule corres_split[where r'="(=)"]) apply (clarsimp simp: select_def corres_underlying_def) apply clarsimp - apply (rule corres_split[OF corres_machine_op,where r'="(=)"]) + apply (rule corres_split[OF corres_machine_op', where r'="(=)"]) apply (rule corres_underlying_trivial) apply (clarsimp simp: user_memory_update_def) apply (rule no_fail_modify) @@ -285,7 +285,7 @@ lemma getActiveIRQ_nf: done lemma dmo_getActiveIRQ_corres[ADT_IF_Refine_assms]: - "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel'))" + "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel))" apply (rule SubMonad_R.corres_machine_op) apply (rule corres_Id) apply (simp add: getActiveIRQ_def non_kernel_IRQs_def) @@ -296,7 +296,7 @@ lemma dmo_getActiveIRQ_corres[ADT_IF_Refine_assms]: lemma dmo'_getActiveIRQ_wp[ADT_IF_Refine_assms]: "\\s. P (irq_at (irq_state (ksMachineState s) + 1) (irq_masks (ksMachineState s))) (s\ksMachineState := (ksMachineState s\irq_state := irq_state (ksMachineState s) + 1\)\)\ - doMachineOp (getActiveIRQ in_kernel) + doMachineOp (getActiveIRQ False) \P\" apply(simp add: doMachineOp_def getActiveIRQ_def non_kernel_IRQs_def) apply(wp modify_wp | wpc)+ @@ -356,30 +356,63 @@ lemma handleEvent_corres_arch_extras[ADT_IF_Refine_assms]: (handle_event event) (handleEvent event)" by (fastforce intro: corres_guard2_imp[OF handleEvent_corres]) -lemma getActiveIRQ_corres_True_False: - "corres_underlying Id False True (=) \ \ (getActiveIRQ True) (getActiveIRQ False)" - unfolding getActiveIRQ_def - by (corres simp: non_kernel_IRQs_def) - -lemma maybeHandleInterrupt_corres_True_False[ADT_IF_Refine_assms]: - "corres dc einvs invs' (maybe_handle_interrupt True) (maybeHandleInterrupt False)" - unfolding maybe_handle_interrupt_def maybeHandleInterrupt_def - apply (corres corres: corres_machine_op getActiveIRQ_corres_True_False - handleInterrupt_corres[@lift_corres_args] - simp: irq_state_independent_def - | corres_cases_both)+ - apply (wpsimp wp: hoare_drop_imps) - apply clarsimp - apply (strengthen contract_all_imp_strg[where P'=True, simplified]) - apply (wpsimp wp: doMachineOp_getActiveIRQ_IRQ_active' hoare_vcg_all_lift) - apply clarsimp - apply (clarsimp simp: invs'_def valid_state'_def) +lemma handle_event_valid_domain_time_IRQ: + "\\s. 0 < domain_time s \ + handle_event Interrupt + \\_ s::det_state. domain_time s = 0 \ scheduler_action s = choose_new_thread\, -" + by (wpsimp wp: maybe_handle_interrupt_valid_domain_time wp_del: handle_event_domain_time_valid) + +lemma kernel_entry_if_corres[ADT_IF_Refine_assms]: + "corres (prod_lift (dc \ dc)) + (einvs and no_domain_caps + and (\s. event \ Interrupt \ ct_running s) + and schact_is_rct + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and (\s. event \ Interrupt \ ct_running' s) + and arch_extras + and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (kernel_entry_if event tc) (kernelEntry_if event tc)" + supply local.getActiveIRQ_inv[wp del] + supply Machine_AI.AARCH64.getActiveIRQ_inv[wp del] + apply (simp add: kernel_entry_if_def kernelEntry_if_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply (rule corres_split) + apply simp + apply (rule threadset_corresT) + apply (erule arch_tcb_context_set_tcb_relation) + apply (clarsimp simp: tcb_cap_cases_def) + apply (rule allI[OF ball_tcb_cte_casesI]; clarsimp) + apply fastforce + apply fastforce + apply fastforce + apply (rule corres_split[OF handleEvent_corres_arch_extras]) + apply (rule corres_stateAssert_assume_stronger[where Q=\ and + P="\s. valid_domain_list s \ + (event \ Interrupt \ 0 < domain_time s) \ + (event = Interrupt \ domain_time s = 0 \ + scheduler_action s = choose_new_thread)"]) + apply (clarsimp simp: prod_lift_def) + apply (clarsimp simp: state_relation_def) + apply (wp add: threadSet_invs_trivial thread_set_invs_trivial thread_set_ct_in_state + threadSet_ct_running' thread_set_not_state_valid_sched + hoare_vcg_const_imp_lift + handle_interrupt_valid_domain_time handle_event_valid_domain_time_IRQ + handle_event_noIRQ_domain_time_inv + no_domain_caps_sep_inv_lift[OF thread_set_tcb_arch_update_domain_sep_inv] + del: handle_event_domain_time_valid + | simp add: tcb_cap_cases_def schact_is_rct_def maybe_handle_interrupt_def + arch_tcb_update_aux2 + | wpc + | wps + | wp (once) hoare_drop_imp)+ + apply (fastforce simp: invs_def cur_tcb_def valid_state_def) + apply force done end -requalify_consts - RISCV64.doUserOp_if +arch_requalify_consts doUserOp_if global_interpretation ADT_IF_Refine_1?: ADT_IF_Refine_1 doUserOp_if diff --git a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy index d45cb057a3..dfabbfc18a 100644 --- a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy @@ -12,25 +12,6 @@ context kernel_m begin named_theorems ADT_IF_Refine_assms -lemma handleInterrupt_ccorres[ADT_IF_Refine_assms]: - "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs') - (UNIV) - [] - (handleEvent Interrupt) - (handleInterruptEntry_C_body_if)" - apply (rule ccorres_guard_imp2) - apply (simp add: handleEvent_def minus_one_norm handleInterruptEntry_C_body_if_def) - apply (rule ccorres_add_return2) - apply (ctac (no_vcg) add: checkInterrupt_ccorres) - apply (rule_tac R="\_. rv = Inr ()" in ccorres_return[where R'=UNIV]) - apply (rule conseqPre, vcg) - apply (clarsimp simp: return_def) - apply (simp add: liftE_def) - apply wpsimp - apply clarsimp - done - lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and arch_extras and ct_active' and sch_act_simple) @@ -182,6 +163,8 @@ lemma check_active_irq_corres_C[ADT_IF_Refine_assms]: apply (rule ccorres_rel_imp, rule ccorres_guard_imp) apply (rule getActiveIRQ_ccorres) apply simp+ + apply (clarsimp split: option.splits) + apply simp+ apply (rule no_fail_dmo') apply (rule no_fail_getActiveIRQ) apply (rule corres_trivial, clarsimp split: if_split option.splits) @@ -224,10 +207,120 @@ lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: apply simp done + +definition handleHypervisorFault_C_body_if :: "machine_word \ (globals myvars, int, strictc_errortype) com" + where + "handleHypervisorFault_C_body_if hyp_fault_type == + IF hyp_fault_type = 0x2000000 \ \UNKNOWN_FAULT\ THEN + \ret__unsigned_long :== CALL getESR();; + \current_fault :== CALL seL4_Fault_UserException_new(\ret__unsigned_long,0);; + CALL handleFault(\ksCurThread) + ELSE + \current_fault :== CALL seL4_Fault_VCPUFault_new(hyp_fault_type);; + CALL handleFault(\ksCurThread) + FI;; + \ret__unsigned_long :== scast EXCEPTION_NONE" + +definition hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" where + "hyp_fault_type_from_H fault \ + case fault of hyp_fault_type.ARMVCPUFault f \ ucast f" + +lemma handleHypervisorFault_C_body_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (UNIV) [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + apply (rule ccorres_guard_imp) + apply (simp add: liftE_def bind_assoc handleHypervisorFault_C_body_if_def) + apply (rule ccorres_pre_getCurThread) + apply (rule ccorres_split_nothrow_novcg) + apply (simp only: handleHypervisorFault_def handleHypervisorFault_C_body_if_def hyp_fault_type_from_H_def) + apply wpc + apply (rule_tac P="ARMVCPUFault x = ARMVCPUFault 0x2000000" in ccorres_cases) + apply clarsimp + apply (rule ccorres_cond_univ) + apply (rule ccorres_rhs_assoc)+ + apply (ctac (no_vcg) add: getESR_ccorres) + apply (rule ccorres_symb_exec_r) + apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) + apply (rule_tac xf'=xfdc in ccorres_call) + apply (ctac (no_vcg) add: handleFault_ccorres) + apply simp + apply simp + apply simp + apply vcg + apply (clarsimp, rule conseqPre, vcg) + apply clarsimp + apply wp + apply (prop_tac "ucast x \ (0x2000000 :: machine_word)") + apply (fastforce dest: eq_ucast_ucast_eq[rotated, OF sym]) + apply clarsimp + apply (rule ccorres_cond_empty) + apply (rule ccorres_symb_exec_r) + apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) + apply (rule_tac xf'=xfdc in ccorres_call) + apply (ctac (no_vcg) add: handleFault_ccorres) + apply simp + apply simp + apply simp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply ceqv + apply clarsimp + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: return_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def + cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift + seL4_Fault_VCPUFault_lift ucast_and_mask_drop + elim: pred_tcb'_weakenE st_tcb_ex_cap'' + dest: st_tcb_at_idle_thread' rf_sr_ksCurThread split: if_splits) + done + +declare handleSpuriousIRQ_ccorres[ADT_IF_Refine_assms] +declare hvmf_invs_lift[ADT_IF_Refine_assms] + +lemma checkInterrupt_ccorres'[ADT_IF_Refine_assms]: + "ccorres dc xfdc (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) UNIV [] + (maybeHandleInterrupt inKernel) (Call checkInterrupt_'proc)" + unfolding maybeHandleInterrupt_def + apply cinit' + apply (rule ccorres_guard_imp) + apply (simp add: liftE_def bind_assoc) + apply (ctac (no_vcg) add: getActiveIRQ_ccorres) + apply (rule_tac P="\_. rv \ None" and R=\ in ccorres_cond_both) + apply (auto split: option.splits)[1] + apply (rule_tac P="rv \ None" in ccorres_gen_asm) + apply clarsimp + apply wpfix + apply (rule ccorres_call[where xf'=xfdc, OF handleInterrupt_ccorres]; simp) + apply (rule_tac P="rv = None" in ccorres_gen_asm) + apply clarsimp + apply wpfix + apply (ctac (no_vcg) add: handleSpuriousIRQ_ccorres) + apply wp + apply (simp add: guard_is_UNIV_def) + apply (rule_tac Q'="\rv s. invs' s \ (\irq. rv = Some irq \ irq \ non_kernel_IRQs \ + sch_act_not (ksCurThread s) s)" + in hoare_post_imp) + apply (solves clarsimp) + apply (wpsimp wp: dmo_getActiveIRQ_inKernel_sch_act_not) + apply assumption + apply assumption + apply (clarsimp simp: invs'_def valid_state'_def) + done + end -sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if handleHypervisorFault_C_body_if hyp_fault_type_from_H proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/refine/ADT_IF_Refine.thy b/proof/infoflow/refine/ADT_IF_Refine.thy index 973429862a..f676605584 100644 --- a/proof/infoflow/refine/ADT_IF_Refine.thy +++ b/proof/infoflow/refine/ADT_IF_Refine.thy @@ -229,11 +229,11 @@ locale ADT_IF_Refine_1 = (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running') (do_user_op_if f tc) (doUserOp_if f tc)" and dmo_getActiveIRQ_corres: - "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel'))" + "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel))" and dmo'_getActiveIRQ_wp: "\\s. P (irq_at (irq_state (ksMachineState s) + 1) (irq_masks (ksMachineState s))) (s\ksMachineState := (ksMachineState s\irq_state := irq_state (ksMachineState s) + 1\)\)\ - doMachineOp (getActiveIRQ in_kernel) + doMachineOp (getActiveIRQ False) \P\" and handlePreemption_arch_extras[wp]: "handlePreemption_if tc \arch_extras\" @@ -359,11 +359,6 @@ lemma checkActiveIRQ_ex_abs[wp]: apply (clarsimp simp: ex_abs_def) done -lemma handlePreemption_invs'[wp]: - "handlePreemption_if tc \invs'\" - unfolding handlePreemption_if_def - by (wpsimp wp: dmo'_getActiveIRQ_wp hoare_drop_imps) - lemma handle_preemption_if_corres: "corres (=) (einvs and valid_domain_list and (\s. 0 < domain_time s)) (invs') (handle_preemption_if tc) (handlePreemption_if tc)" @@ -831,6 +826,11 @@ lemma ex_abs_pred_conjD1: (* FIXME: move *) "ex_abs (P and Q) s \ ex_abs P s" by (auto simp: ex_abs_def) +lemma handlePreemption_invs'[wp]: + "handlePreemption_if tc \invs'\" + unfolding handlePreemption_if_def + by (wpsimp wp: dmo'_getActiveIRQ_wp hoare_drop_imps) + lemma haskell_invs: "global_automaton_invs checkActiveIRQ_H_if (doUserOp_H_if uop) kernelCall_H_if handlePreemption_H_if @@ -966,7 +966,7 @@ lemma extras_inter'[dest!]: lemma fw_sim_abs_conc: "LI (ADT_abs) (ADT_conc) (lift_fst_rel srel) (invs_abs \ invs_conc)" - apply (unfold LI_def ) + apply (unfold LI_def) apply (intro conjI allI) apply (rule init_refinement) apply (clarsimp simp: rel_semi_def relcomp_unfold lift_fst_rel_def diff --git a/proof/infoflow/refine/ADT_IF_Refine_C.thy b/proof/infoflow/refine/ADT_IF_Refine_C.thy index 59807b8b25..df07eb67c7 100644 --- a/proof/infoflow/refine/ADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/ADT_IF_Refine_C.thy @@ -82,11 +82,69 @@ definition handleVMFaultEvent_C_body_if context kernel_m begin +definition + checkActiveIRQ_C_if :: "user_context \ (cstate, irq option \ user_context) nondet_monad" + where + "checkActiveIRQ_C_if tc \ + do + getActiveIRQ_C; + irq \ gets ret__unsigned_long_'; + return (if irq = ucast irqInvalid then None else Some (ucast irq), tc) + od" + +definition + check_active_irq_C_if + where + "check_active_irq_C_if \ {((tc, s), irq, (tc', s')). ((irq, tc'), s') \ fst (checkActiveIRQ_C_if tc s)}" + definition handleInterruptEntry_C_body_if (*:: "(globals myvars, int, l4c_errortype) com"*) where -"handleInterruptEntry_C_body_if \ ( + "handleInterruptEntry_C_body_if \ ( (CALL checkInterrupt());; \ret__unsigned_long :== scast EXCEPTION_NONE)" +definition + handlePreemption_C_if :: "user_context \ (cstate,user_context) nondet_monad" where + "handlePreemption_C_if tc \ do (exec_C \ handleInterruptEntry_C_body_if); return tc od" + +end + + +locale ADT_IF_Refine_1 = kernel_m + + fixes doUserOp_C_if :: + "user_transition_if \ user_context \ (cstate, (event option \ user_context)) nondet_monad" + and handleHypervisorFault_C_body_if :: "machine_word \ (globals myvars, int, strictc_errortype) com" + and hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" + assumes do_user_op_if_C_corres: + "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs and (\_. uop_nonempty f)) + \ (doUserOp_if f tc) (doUserOp_C_if f tc)" + and handleInvocation_ccorres': + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_active' and sch_act_simple) + (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] + (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" + and handleHypervisorFault_C_body_ccorres: + "ccorres ((\irq :: irq. K dc irq) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (UNIV) [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + and checkInterrupt_ccorres': + "ccorres dc xfdc (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) UNIV [] + (maybeHandleInterrupt inKernel) (Call checkInterrupt_'proc)" + and hvmf_invs_lift: + "\ \s m. P (s\ksMachineState := ksMachineState s\machine_state_rest := m\\) = P s \ + \ \P\ handleVMFault t hf \\_ _. True\, \\_. P\" + and check_active_irq_corres_C: + "corres_underlying rf_sr False False (=) \ \ (checkActiveIRQ_if tc) (checkActiveIRQ_C_if tc)" + and obs_cpspace_user_data_relation: + "\ pspace_aligned' bd; pspace_distinct' bd; + cpspace_user_data_relation (ksPSpace bd) (underlying_memory (ksMachineState bd)) hgs \ + \ cpspace_user_data_relation (ksPSpace bd) + (underlying_memory (observable_memory (ksMachineState bd) (user_mem' bd))) hgs" +begin + definition "callKernel_C_body_if e \ case e of SyscallEvent n \ (handleSyscall_C_body_if (ucast (syscall_from_H n))) @@ -94,7 +152,7 @@ definition | UserLevelFault w1 w2 \ (handleUserLevelFault_C_body_if w1 w2) | Interrupt \ (handleInterruptEntry_C_body_if) | VMFaultEvent t \ (handleVMFaultEvent_C_body_if (vm_fault_type_from_H t)) - | HypervisorEvent t \ (SKIP ;; \ret__unsigned_long :== scast EXCEPTION_NONE)" + | HypervisorEvent t \ (handleHypervisorFault_C_body_if (hyp_fault_type_from_H t))" definition kernelEntry_C_if (*:: @@ -121,51 +179,10 @@ definition {(s, b, (tc,s'))|s b tc s' r. ((r,tc),s') \ fst (split (kernelEntry_C_if fp e) s) \ b = (case r of Inl x \ True | Inr x \ False)}" -definition - checkActiveIRQ_C_if :: "user_context \ (cstate, irq option \ user_context) nondet_monad" - where - "checkActiveIRQ_C_if tc \ - do - getActiveIRQ_C; - irq \ gets ret__unsigned_long_'; - return (if irq = ucast irqInvalid then None else Some (ucast irq), tc) - od" - -definition - check_active_irq_C_if - where - "check_active_irq_C_if \ {((tc, s), irq, (tc', s')). ((irq, tc'), s') \ fst (checkActiveIRQ_C_if tc s)}" - -lemma corres_select_f': - "\ \s s'. P s \ P' s' \ \s' \ fst S'. \s \ fst S. rvr s s'; nf' \ \ snd S' \ - \ corres_underlying sr nf nf' rvr P P' (select_f S) (select_f S')" - by (clarsimp simp: select_f_def corres_underlying_def) - -lemma cur_thread_of_absKState[simp]: - "cur_thread (absKState s) = (ksCurThread s)" - by (clarsimp simp: cstate_relation_def Let_def absKState_def cstate_to_H_def) - -lemma absKState_crelation: - "\ cstate_relation s (globals s'); invs' s; ksReadyQueues_asrt s\ - \ cstate_to_A s' = absKState s" - apply (clarsimp simp add: cstate_to_H_correct invs'_def cstate_to_A_def) - apply (clarsimp simp: absKState_def absExst_def observable_memory_def) - apply (case_tac s) - apply clarsimp - apply (case_tac ksMachineState) - apply clarsimp - apply (rule ext) - by (clarsimp simp: option_to_0_def user_mem'_def pointerInUserData_def ko_wp_at'_def - obj_at'_def typ_at'_def ps_clear_def - split: if_splits) - -definition - handlePreemption_C_if :: "user_context \ (cstate,user_context) nondet_monad" where - "handlePreemption_C_if tc \ do (exec_C \ handleInterruptEntry_C_body_if); return tc od" - lemma handleInterrupt_no_fail: "no_fail (ex_abs (einvs) and invs' - and (\s. intStateIRQTable (ksInterruptState s) a \ irqstate.IRQInactive)) + and (\s. intStateIRQTable (ksInterruptState s) a \ irqstate.IRQInactive) + and (\s. a \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (handleInterrupt a)" apply (rule no_fail_pre) apply (rule corres_nofail) @@ -181,54 +198,31 @@ lemma handleSpuriousIRQ_no_fail[intro!, wp, simp]: by wpsimp lemma handleEvent_Interrupt_no_fail: - "no_fail (invs' and ex_abs einvs) (handleEvent Interrupt)" + "no_fail (invs' and ex_abs einvs and (\s. ksSchedulerAction s = ResumeCurrentThread)) (handleEvent Interrupt)" apply (simp add: handleEvent_def maybeHandleInterrupt_def) apply (wpsimp wp: handleInterrupt_no_fail) apply (simp add: crunch_simps) apply (rule_tac Q'="\r s. ex_abs (einvs) s \ invs' s \ (\irq. r = Some irq - \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive)" + \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive) + \ (\irq. r = Some irq \ irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)" in hoare_strengthen_post) apply (rule hoare_vcg_conj_lift) apply (rule corres_ex_abs_lift) apply (rule dmo_getActiveIRQ_corres) apply wpsimp apply (wpsimp wp: doMachineOp_getActiveIRQ_IRQ_active) + apply (wp hoare_vcg_all_lift hoare_drop_imps) + apply wpsimp apply clarsimp apply wpsimp apply (clarsimp simp: invs'_def valid_state'_def) done -end - - -locale ADT_IF_Refine_1 = kernel_m + - fixes doUserOp_C_if :: - "user_transition_if \ user_context \ (cstate, (event option \ user_context)) nondet_monad" - assumes do_user_op_if_C_corres: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs and (\_. uop_nonempty f)) - \ (doUserOp_if f tc) (doUserOp_C_if f tc)" - and handleInvocation_ccorres': - "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and arch_extras and ct_active' and sch_act_simple) - (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] - (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" - and checkInterrupt_ccorres': - "ccorres dc xfdc (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) UNIV [] - (maybeHandleInterrupt inKernel) (Call checkInterrupt_'proc)" - and check_active_irq_corres_C: - "corres_underlying rf_sr False False (=) \ \ (checkActiveIRQ_if tc) (checkActiveIRQ_C_if tc)" - and obs_cpspace_user_data_relation: - "\ pspace_aligned' bd; pspace_distinct' bd; - cpspace_user_data_relation (ksPSpace bd) (underlying_memory (ksMachineState bd)) hgs \ - \ cpspace_user_data_relation (ksPSpace bd) - (underlying_memory (observable_memory (ksMachineState bd) (user_mem' bd))) hgs" -begin - lemma handleInterrupt_if_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) - (UNIV) + UNIV [] (liftE (maybeHandleInterrupt inKernel)) (handleInterruptEntry_C_body_if)" @@ -352,7 +346,8 @@ lemma handleEvent_ccorres: apply simp apply simp apply simp - apply (wp hv_inv_ex') + apply (wp hvmf_invs_lift) + apply (fastforce simp: invs'_machine valid_machine_state'_def) apply (simp add: guard_is_UNIV_def) apply (vcg exspec=handleVMFault_modifies) apply ceqv @@ -362,20 +357,12 @@ lemma handleEvent_ccorres: apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) - apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def - cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift - elim: pred_tcb'_weakenE st_tcb_ex_cap'' - dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) \ \HypervisorEvent\ - apply (simp add: liftE_def bind_assoc) - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l) - apply (case_tac x6; simp add: handleHypervisorFault_def) - apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: return_def) - apply wp+ - apply clarsimp + apply (rule handleHypervisorFault_C_body_ccorres) + apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def + cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift + elim: pred_tcb'_weakenE st_tcb_ex_cap'' + dest: st_tcb_at_idle_thread' rf_sr_ksCurThread split: if_splits) done lemma kernelEntry_corres_C: @@ -511,11 +498,6 @@ lemma handle_preemption_corres_C: apply (fastforce simp: ex_abs_def schedaction_related)+ done -end - - -context kernel_m begin - definition handle_preemption_C_if where @@ -613,6 +595,34 @@ lemma preserves'_trivial: "preserves' mode UNIV f" apply (simp add: preserves'_def) done +lemma corres_select_f': + "\ \s s'. P s \ P' s' \ \s' \ fst S'. \s \ fst S. rvr s s'; nf' \ \ snd S' \ + \ corres_underlying sr nf nf' rvr P P' (select_f S) (select_f S')" + by (clarsimp simp: select_f_def corres_underlying_def) + + +context kernel_m begin + +lemma cur_thread_of_absKState[simp]: + "cur_thread (absKState s) = (ksCurThread s)" + by (clarsimp simp: cstate_relation_def Let_def absKState_def cstate_to_H_def) + +lemma absKState_crelation: + "\ cstate_relation s (globals s'); invs' s; ksReadyQueues_asrt s\ + \ cstate_to_A s' = absKState s" + apply (clarsimp simp add: cstate_to_H_correct invs'_def cstate_to_A_def) + apply (clarsimp simp: absKState_def absExst_def observable_memory_def) + apply (case_tac s) + apply clarsimp + apply (case_tac ksMachineState) + apply clarsimp + apply (rule ext) + by (clarsimp simp: option_to_0_def user_mem'_def pointerInUserData_def ko_wp_at'_def + obj_at'_def typ_at'_def ps_clear_def + split: if_splits) + +end + context ADT_IF_Refine_1 begin From 1525485f03f3b511a84cd277ef894da478b62ca5 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Wed, 10 Jun 2026 12:14:09 +1000 Subject: [PATCH 07/11] aarch64 infoflow: update example state proofs Signed-off-by: Ryan Barry --- .../infoflow/AARCH64/Example_Valid_State.thy | 722 +++--- .../refine/AARCH64/Example_Valid_StateH.thy | 1970 +++++++++++------ 2 files changed, 1636 insertions(+), 1056 deletions(-) diff --git a/proof/infoflow/AARCH64/Example_Valid_State.thy b/proof/infoflow/AARCH64/Example_Valid_State.thy index f07b67b666..69d6fa2b7b 100644 --- a/proof/infoflow/AARCH64/Example_Valid_State.thy +++ b/proof/infoflow/AARCH64/Example_Valid_State.thy @@ -12,6 +12,8 @@ imports "AInvs.KernelInit_AI" begin +(* FIXME AARCH64 IF: major cleanup *) + section \Example\ (* This example is a classic 'one way information flow' @@ -27,8 +29,13 @@ consts s0_context :: user_context (* define the irqs to come regularly every 10 *) +definition timer_irq :: irq where + "timer_irq \ 0" + +abbreviation (input) "timer_int \ 10" + axiomatization where - irq_oracle_def: "AARCH64.irq_oracle \ \pos. if pos mod 10 = 0 then 10 else 0" + irq_oracle_def: "AARCH64.irq_oracle \ \pos. if pos mod timer_int = 0 then timer_irq else 0" context begin interpretation Arch . (*FIXME: arch-split*) @@ -202,29 +209,29 @@ subsubsection \Defining the State\ definition "ntfn_ptr \ pptr_base + 0x20" -definition "Low_tcb_ptr \ pptr_base + 0x400" -definition "High_tcb_ptr = pptr_base + 0x800" -definition "idle_tcb_ptr = pptr_base + 0x1000" +definition "Low_tcb_ptr \ pptr_base + 0x800" +definition "idle_tcb_ptr = pptr_base + 0x1000" (* FIXME IF: change to idle_thread_ptr *) +definition "High_tcb_ptr = pptr_base + 0x1800" + +lemma "arm_global_pt_ptr = pptr_base + 0x2000" using arm_global_pt_ptr_def . definition "Low_pt_ptr = pptr_base + 0x4000" definition "High_pt_ptr = pptr_base + 0x5000" -definition "Low_pd_ptr = pptr_base + 0x7000" +definition "Low_pd_ptr = pptr_base + 0x6000" definition "High_pd_ptr = pptr_base + 0x8000" -definition "Low_pool_ptr = pptr_base + 0x9000" -definition "High_pool_ptr = pptr_base + 0xA000" +definition "Low_pool_ptr = pptr_base + 0xA000" +definition "High_pool_ptr = pptr_base + 0xB000" -definition "Low_cnode_ptr = pptr_base + 0x10000" -definition "High_cnode_ptr = pptr_base + 0x18000" -definition "Silc_cnode_ptr = pptr_base + 0x20000" -definition "irq_cnode_ptr = pptr_base + 0x28000" +definition "Low_cnode_ptr = pptr_base + 0x18000" +definition "High_cnode_ptr = pptr_base + 0x20000" +definition "Silc_cnode_ptr = pptr_base + 0x28000" +definition "irq_cnode_ptr = pptr_base + 0x30000" -definition "shared_page_ptr_virt = pptr_base + 0x200000" +definition "shared_page_ptr_virt = pptr_base + 0x40000000" definition "shared_page_ptr_phys = addrFromPPtr shared_page_ptr_virt" -definition "timer_irq \ 10" (* not sure exactly how this fits in *) - definition "Low_mcp \ 5 :: priority" definition "Low_prio \ 5 :: priority" definition "High_mcp \ 5 :: priority" @@ -373,6 +380,14 @@ lemma empty_cnode_eq_None[simp]: by (clarsimp simp: empty_cnode_def) +definition max_page_size where + "max_page_size \ if config_ARM_PA_SIZE_BITS_40 then ARMLargePage else ARMHugePage" + +lemma max_page_size_def2: + "max_page_size = vmsize_of_level (max_pt_level - 1)" + by (auto simp: max_page_size_def max_pt_level_def2 vmsize_of_level_def) + + text \Low's CSpace\ definition Low_caps :: cnode_contents where @@ -383,13 +398,13 @@ definition Low_caps :: cnode_contents where (the_nat_to_bl_10 2) \ CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), (the_nat_to_bl_10 3) - \ ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0))), + \ ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0))), (the_nat_to_bl_10 4) \ ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid), (the_nat_to_bl_10 5) - \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid,0))), + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid,0))), (the_nat_to_bl_10 6) - \ ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0))), + \ ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0))), (the_nat_to_bl_10 318) \ NotificationCap ntfn_ptr 0 {AllowSend})" @@ -413,10 +428,10 @@ lemma Low_caps_ran: "ran Low_caps = {ThreadCap Low_tcb_ptr, CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), - ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0))), - ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0))), + ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0))), + ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0))), ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid), - ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid,0))), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid,0))), NotificationCap ntfn_ptr 0 {AllowSend}, NullCap}" apply (rule equalityI) @@ -437,13 +452,13 @@ definition High_caps :: cnode_contents where (the_nat_to_bl_10 2) \ CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2), (the_nat_to_bl_10 3) - \ ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0))), + \ ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0))), (the_nat_to_bl_10 4) \ ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid), (the_nat_to_bl_10 5) - \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid,0))), + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid,0))), (the_nat_to_bl_10 6) - \ ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0))), + \ ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0))), (the_nat_to_bl_10 318) \ NotificationCap ntfn_ptr 0 {AllowRecv}) " @@ -454,10 +469,10 @@ lemma High_caps_ran: "ran High_caps = {ThreadCap High_tcb_ptr, CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2), - ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0))), - ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0))), + ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0))), + ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0))), ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid), - ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid,0))), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid,0))), NotificationCap ntfn_ptr 0 {AllowRecv}, NullCap}" apply (rule equalityI) @@ -476,7 +491,7 @@ definition Silc_caps :: cnode_contents where ((the_nat_to_bl_10 2) \ CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2), (the_nat_to_bl_10 5) - \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0))), + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid,0))), (the_nat_to_bl_10 318) \ NotificationCap ntfn_ptr 0 {AllowSend})" @@ -486,7 +501,7 @@ definition Silc_cnode :: kernel_object where lemma Silc_caps_ran: "ran Silc_caps = {CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2), - ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0))), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid,0))), NotificationCap ntfn_ptr 0 {AllowSend}, NullCap}" apply (rule equalityI) @@ -502,30 +517,20 @@ text \notification between Low and High\ definition ntfn :: kernel_object where "ntfn \ Notification \ntfn_obj = WaitingNtfn [High_tcb_ptr], ntfn_bound_tcb=None\" - -text \global page table is mapped into the top-level page tables of each vspace\ - -abbreviation init_global_pt' where - "init_global_pt' \ (\idx. if idx \ kernel_mapping_slots then global_pte idx else InvalidPTE)" - - text \Low's VSpace (PageDirectory)\ -abbreviation ppn_from_addr :: "paddr \ pte_ppn" where - "ppn_from_addr addr \ ucast (addr >> pt_bits)" - abbreviation Low_pt' :: pt where "Low_pt' \ - (\_. InvalidPTE) - (0 := PagePTE (ppn_from_addr shared_page_ptr_phys) {} vm_read_write)" + NormalPT ((\_. InvalidPTE) + (0 := PagePTE shared_page_ptr_phys False {} vm_read_write))" definition Low_pt :: kernel_object where "Low_pt \ ArchObj (PageTable Low_pt')" abbreviation Low_pd' :: pt where "Low_pd' \ - init_global_pt' - (0 := PageTablePTE (ppn_from_addr (addrFromPPtr Low_pt_ptr)) {})" + VSRootPT ((\_. InvalidPTE) + (0 := PageTablePTE (ppn_from_pptr Low_pt_ptr)))" definition Low_pd :: kernel_object where "Low_pd \ ArchObj (PageTable Low_pd')" @@ -535,16 +540,16 @@ text \High's VSpace (PageDirectory)\ abbreviation High_pt' :: pt where "High_pt' \ - (\_. InvalidPTE) - (0 := PagePTE (ppn_from_addr shared_page_ptr_phys) {} vm_read_only)" + NormalPT ((\_. InvalidPTE) + (0 := PagePTE shared_page_ptr_phys False {} vm_read_only))" definition High_pt :: kernel_object where "High_pt \ ArchObj (PageTable High_pt')" abbreviation High_pd' :: pt where "High_pd' \ - init_global_pt' - (0 := PageTablePTE (ppn_from_addr (addrFromPPtr High_pt_ptr)) {})" + VSRootPT ((\_. InvalidPTE) + (0 := PageTablePTE (ppn_from_pptr High_pt_ptr)))" definition High_pd :: kernel_object where "High_pd \ ArchObj (PageTable High_pd')" @@ -554,7 +559,7 @@ text \Low's tcb\ definition Low_tcb :: kernel_object where "Low_tcb \ TCB \tcb_ctable = CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), - tcb_vtable = ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0))), + tcb_vtable = ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0))), tcb_reply = ReplyCap Low_tcb_ptr True {AllowGrant, AllowWrite}, tcb_caller = NullCap, tcb_ipcframe = NullCap, @@ -568,14 +573,14 @@ definition Low_tcb :: kernel_object where tcb_time_slice = Low_time_slice, tcb_domain = Low_domain, tcb_flags = {}, - tcb_arch = \tcb_context = undefined\\" + tcb_arch = \tcb_context = empty_context, tcb_vcpu = None, tcb_cur_fpu = False\\" text \High's tcb\ definition High_tcb :: kernel_object where "High_tcb \ TCB \tcb_ctable = CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2) , - tcb_vtable = ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0))), + tcb_vtable = ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0))), tcb_reply = ReplyCap High_tcb_ptr True {AllowGrant, AllowWrite}, tcb_caller = NullCap, tcb_ipcframe = NullCap, @@ -589,7 +594,7 @@ definition High_tcb :: kernel_object where tcb_time_slice = High_time_slice, tcb_domain = High_domain, tcb_flags = {}, - tcb_arch = \tcb_context = undefined\\" + tcb_arch = \tcb_context = empty_context, tcb_vcpu = None, tcb_cur_fpu = False\\" text \idle's tcb\ @@ -610,25 +615,25 @@ definition idle_tcb :: kernel_object where tcb_time_slice = timeSlice, tcb_domain = default_domain, tcb_flags = {}, - tcb_arch = \tcb_context = empty_context\\" + tcb_arch = \tcb_context = empty_context, tcb_vcpu = None, tcb_cur_fpu = False\\" definition "irq_cnode \ CNode 0 (Map.empty([] \ cap.NullCap))" -abbreviation - "Low_pool' \ \idx. if idx = asid_low_bits_of Low_asid then Some Low_pd_ptr else None" +abbreviation Low_pool' :: asid_pool where + "Low_pool' \ \idx. if idx = asid_low_bits_of Low_asid then Some (ASIDPoolVSpace Low_pd_ptr) else None" definition "Low_pool \ ArchObj (ASIDPool Low_pool')" abbreviation - "High_pool' \ \idx. if idx = asid_low_bits_of High_asid then Some High_pd_ptr else None" + "High_pool' \ \idx. if idx = asid_low_bits_of High_asid then Some (ASIDPoolVSpace High_pd_ptr) else None" definition "High_pool \ ArchObj (ASIDPool High_pool')" definition - "shared_page \ ArchObj (DataPage False RISCVLargePage)" + "shared_page \ ArchObj (DataPage False max_page_size)" definition kh0 :: kheap where "kh0 \ (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x @@ -649,12 +654,12 @@ definition kh0 :: kheap where High_tcb_ptr \ High_tcb, idle_tcb_ptr \ idle_tcb, shared_page_ptr_virt \ shared_page, - arm_global_pt_ptr \ init_global_pt)" + arm_global_pt_ptr \ ArchObj global_pt_obj)" lemma irq_node_offs_min: - "init_irq_node_ptr \ init_irq_node_ptr + (ucast (irq :: irq) << 5)" + "init_irq_node_ptr \ init_irq_node_ptr + (ucast (irq::irq) << 5)" apply (rule_tac sz=59 in machine_word_plus_mono_right_split) - apply (simp add: unat_word_ariths mask_def shiftl_t2n s0_ptr_defs) + apply (simp add: unat_word_ariths mask_def shiftl_t2n s0_ptr_defs cte_level_bits_def) apply (cut_tac x=irq and 'a=64 in ucast_less) apply simp apply (simp add: word_less_nat_alt) @@ -662,56 +667,55 @@ lemma irq_node_offs_min: done lemma irq_node_offs_max: - "init_irq_node_ptr + (ucast (irq:: irq) << 5) < init_irq_node_ptr + 0x7E1" - apply (simp add: s0_ptr_defs shiftl_t2n) - apply (cut_tac x=irq and 'a=64 in ucast_less) + "init_irq_node_ptr + (ucast (irq::irq) << 5) < init_irq_node_ptr + 0x4000" + apply (simp add: s0_ptr_defs cte_level_bits_def shiftl_t2n) + apply (cut_tac x=irq and 'a=machine_word_len in ucast_less) apply simp - apply (simp add: word_less_nat_alt unat_word_ariths) + apply (simp add: word_less_nat_alt unat_word_ariths + cte_level_bits_def irq_len_val) done + definition irq_node_offs_range where - "irq_node_offs_range \ {x. init_irq_node_ptr \ x \ x < init_irq_node_ptr + 0x7E1} + "irq_node_offs_range \ {x. init_irq_node_ptr \ x \ x < init_irq_node_ptr + 0x4000} \ {x. is_aligned x 5}" lemma irq_node_offs_in_range: - "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ irq_node_offs_range" + "init_irq_node_ptr + (ucast (irq::irq) << 5) + \ irq_node_offs_range" apply (clarsimp simp: irq_node_offs_min irq_node_offs_max irq_node_offs_range_def) apply (rule is_aligned_add[OF _ is_aligned_shift]) - apply (simp add: is_aligned_def s0_ptr_defs) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def) done lemma irq_node_offs_range_correct: "x \ irq_node_offs_range - \ \irq. x = init_irq_node_ptr + (ucast (irq:: irq) << 5)" - apply (clarsimp simp: irq_node_offs_min irq_node_offs_max irq_node_offs_range_def s0_ptr_defs) - apply (rule_tac x="ucast ((x - 0xFFFFFFC000003000) >> 5)" in exI) - apply (clarsimp simp: ucast_ucast_mask) + \ \irq. x = init_irq_node_ptr + (ucast (irq::irq) << 5)" + unfolding irq_node_offs_range_def + apply clarsimp + apply (rule_tac x="ucast ((x - init_irq_node_ptr) >> 5)" in exI) + apply (simp add: ucast_ucast_mask) apply (subst aligned_shiftr_mask_shiftl) apply (rule aligned_sub_aligned) apply assumption - apply (simp add: is_aligned_def) - apply simp - apply simp - apply (rule_tac n=11 in mask_eqI) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def) + apply (simp add: cte_level_bits_def) + apply (rule_tac n="irq_len + 5" in mask_eqI) apply (subst mask_add_aligned) - apply (simp add: is_aligned_def) - apply (simp add: mask_twice) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply (simp add: mask_twice irq_len_val cte_level_bits_def) apply (simp add: diff_conv_add_uminus del: add_uminus_conv_diff) apply (subst add.commute[symmetric]) apply (subst mask_add_aligned) - apply (simp add: is_aligned_def) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) apply simp apply (simp add: diff_conv_add_uminus del: add_uminus_conv_diff) apply (subst add_mask_lower_bits) - apply (simp add: is_aligned_def) - apply clarsimp - apply (cut_tac x=x and y="0xFFFFFFC0000037E0" and n=14 in neg_mask_mono_le) - apply (force dest: word_less_sub_1) - apply (drule_tac n=11 in aligned_le_sharp) - apply (simp add: is_aligned_def) - apply (simp add: mask_def is_aligned_mask) - apply word_bitwise - apply fastforce + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply (clarsimp simp: cte_level_bits_def irq_len_val) + apply (erule (1) aligned_intvl_neg_mask_start) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply (simp add: cte_level_bits_def irq_len_val) done lemma irq_node_offs_range_distinct[simp]: @@ -731,7 +735,7 @@ lemma irq_node_offs_range_distinct[simp]: "idle_tcb_ptr \ irq_node_offs_range" "arm_global_pt_ptr \ irq_node_offs_range" "shared_page_ptr_virt \ irq_node_offs_range" - by(simp add:irq_node_offs_range_def s0_ptr_defs)+ + by(simp add: irq_node_offs_range_def irq_len_val cte_level_bits_def s0_ptr_defs)+ lemma irq_node_offs_distinct[simp]: "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_cnode_ptr" @@ -755,14 +759,14 @@ lemma irq_node_offs_distinct[simp]: lemma kh0_dom: "dom kh0 = {shared_page_ptr_virt, arm_global_pt_ptr, idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, High_pt_ptr, Low_pt_ptr, High_pd_ptr, Low_pd_ptr, irq_cnode_ptr, ntfn_ptr, - Silc_cnode_ptr, High_pool_ptr, Low_pool_ptr, High_cnode_ptr, Low_cnode_ptr} - \ irq_node_offs_range" + Silc_cnode_ptr, High_pool_ptr, Low_pool_ptr, High_cnode_ptr, Low_cnode_ptr} \ + irq_node_offs_range" apply (rule equalityI) apply (simp add: kh0_def dom_def) apply (clarsimp simp: irq_node_offs_in_range) apply (clarsimp simp: dom_def) apply (rule conjI, clarsimp simp: kh0_def)+ - apply (force simp: kh0_def dest: irq_node_offs_range_correct) + apply (force simp: kh0_def cte_level_bits_def dest: irq_node_offs_range_correct) done lemmas kh0_SomeD' = set_mp[OF equalityD1[OF kh0_dom[simplified dom_def]], OF CollectI, simplified, OF exI] @@ -770,7 +774,7 @@ lemmas kh0_SomeD' = set_mp[OF equalityD1[OF kh0_dom[simplified dom_def]], OF Col lemma kh0_SomeD: "kh0 x = Some y \ x = shared_page_ptr_virt \ y = shared_page \ - x = arm_global_pt_ptr \ y = init_global_pt \ + x = arm_global_pt_ptr \ y = ArchObj global_pt_obj \ x = idle_tcb_ptr \ y = idle_tcb \ x = High_tcb_ptr \ y = High_tcb \ x = Low_tcb_ptr \ y = Low_tcb \ @@ -793,7 +797,7 @@ lemma kh0_SomeD: lemmas kh0_obj_def = Low_cnode_def High_cnode_def Silc_cnode_def Low_pool_def High_pool_def Low_pd_def High_pd_def Low_pt_def High_pt_def Low_tcb_def High_tcb_def idle_tcb_def irq_cnode_def ntfn_def - init_global_pt_def global_pte_def vm_kernel_only_def shared_page_def + global_pt_obj_def vm_kernel_only_def shared_page_def definition exst0 :: "det_ext" where @@ -805,14 +809,32 @@ definition machine_state0 :: "machine_state" where irq_state = 0, underlying_memory = const 0, device_state = Map.empty, + vcpu_state = default_vcpu_state, + fpu_state = FPUState (\_. 0) 0 0, + fpu_enabled = False, machine_state_rest = undefined\" +(* FIXME AARCH64 IF: override in Init_A *) +definition init_vspace_uses :: "vspace_ref \ arm_vspace_region_use" where + "init_vspace_uses p \ + if p \ kernel_window_range then ArmVSpaceKernelWindow + else ArmVSpaceInvalidRegion" + +definition max_numlistregs :: nat where + "max_numlistregs \ if config_ARM_GIC_V3 then 16 else 64" + definition arch_state0 :: "arch_state" where "arch_state0 \ \ arm_asid_table = [asid_high_bits_of Low_asid \ Low_pool_ptr, - asid_high_bits_of High_asid \ High_pool_ptr], - arm_kernel_vspace = (\level. if level = max_pt_level then {arm_global_pt_ptr} else {}), - riscv_kernel_vspace = init_vspace_uses + asid_high_bits_of High_asid \ High_pool_ptr], + arm_kernel_vspace = init_vspace_uses, + arm_asid_map = Map.empty, + arm_vmid_table = Map.empty, + arm_next_vmid = 0, + arm_us_global_vspace = arm_global_pt_ptr, + arm_current_vcpu = None, + arm_gicvcpu_numlistregs = max_numlistregs - 1, + arm_current_fpu_owner = None \" definition s0_internal :: "det_ext state" where @@ -824,8 +846,9 @@ definition s0_internal :: "det_ext state" where cur_thread = Low_tcb_ptr, idle_thread = idle_tcb_ptr, scheduler_action = resume_cur_thread, - domain_list = [(0, 10), (1, 10)], + domain_list = [(0, 10), (1, 10), (0, 0)], domain_index = 0, + domain_start_index = 0, cur_domain = 0, domain_time = 5, ready_queues = (const (const [])), @@ -839,7 +862,7 @@ definition s0_internal :: "det_ext state" where lemma kh_s0_def: "(kheap s0_internal x = Some y) = ( x = shared_page_ptr_virt \ y = shared_page \ - x = arm_global_pt_ptr \ y = init_global_pt \ + x = arm_global_pt_ptr \ y = ArchObj global_pt_obj \ x = idle_tcb_ptr \ y = idle_tcb \ x = High_tcb_ptr \ y = High_tcb \ x = Low_tcb_ptr \ y = Low_tcb \ @@ -865,7 +888,7 @@ subsubsection \Defining the policy graph\ definition Sys1AgentMap :: "(auth_graph_label subject_label) agent_map" where "Sys1AgentMap \ \ \set the range of the shared_page to Low, default everything else to IRQ0\ - (\p. if p \ ptr_range shared_page_ptr_virt (pageBitsForSize RISCVLargePage) + (\p. if p \ ptr_range shared_page_ptr_virt (pageBitsForSize max_page_size) then partition_label Low else partition_label IRQ0) (Low_cnode_ptr := partition_label Low, @@ -898,7 +921,7 @@ lemma Sys1AgentMap_simps: "Sys1AgentMap Low_tcb_ptr = partition_label Low" "Sys1AgentMap High_tcb_ptr = partition_label High" "Sys1AgentMap idle_tcb_ptr = partition_label Low" - "\p. p \ ptr_range shared_page_ptr_virt (pageBitsForSize RISCVLargePage) + "\p. p \ ptr_range shared_page_ptr_virt (pageBitsForSize max_page_size) \ Sys1AgentMap p = partition_label Low" unfolding Sys1AgentMap_def apply simp_all @@ -946,28 +969,28 @@ lemma s0_caps_of_state : (p,cap) \ { ((Low_cnode_ptr,(the_nat_to_bl_10 1)), ThreadCap Low_tcb_ptr), ((Low_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)), - ((Low_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0)))), - ((Low_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0)))), ((Low_cnode_ptr,(the_nat_to_bl_10 4)), ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid)), - ((Low_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid, 0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid, 0)))), ((Low_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowSend}), ((High_cnode_ptr,(the_nat_to_bl_10 1)), ThreadCap High_tcb_ptr), ((High_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)), - ((High_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0)))), - ((High_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0)))), ((High_cnode_ptr,(the_nat_to_bl_10 4)), ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid)), - ((High_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid, 0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid, 0)))), ((High_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowRecv}) , ((Silc_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2)), - ((Silc_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid, 0)))), + ((Silc_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid, 0)))), ((Silc_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowSend}), ((Low_tcb_ptr,(tcb_cnode_index 0)), CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)), - ((Low_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0)))), + ((Low_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0)))), ((Low_tcb_ptr,(tcb_cnode_index 2)), ReplyCap Low_tcb_ptr True {AllowGrant, AllowWrite}), ((Low_tcb_ptr,(tcb_cnode_index 3)), NullCap), ((Low_tcb_ptr,(tcb_cnode_index 4)), NullCap), ((High_tcb_ptr,(tcb_cnode_index 0)), CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)), - ((High_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0)))), + ((High_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0)))), ((High_tcb_ptr,(tcb_cnode_index 2)), ReplyCap High_tcb_ptr True {AllowGrant, AllowWrite}), ((High_tcb_ptr,(tcb_cnode_index 3)), NullCap), ((High_tcb_ptr,(tcb_cnode_index 4)), NullCap)} " @@ -1039,36 +1062,83 @@ lemma pts_of_s0: High_pd_ptr \ High_pd', Low_pt_ptr \ Low_pt', High_pt_ptr \ High_pt', - arm_global_pt_ptr \ init_global_pt']" + arm_global_pt_ptr \ VSRootPT (\_. InvalidPTE)]" by (auto simp: opt_map_def s0_internal_def kh0_def kh0_obj_def split: option.splits if_splits)+ lemma ptes_of_s0_PageTablePTE: - "\ ptes_of s0_internal ptr = Some pte; is_PageTablePTE pte \ - \ table_base ptr = Low_pd_ptr \ pte = PageTablePTE (ppn_from_addr (addrFromPPtr Low_pt_ptr)) {} - \ table_base ptr = High_pd_ptr \ pte = PageTablePTE (ppn_from_addr (addrFromPPtr High_pt_ptr)) {}" + "\ ptes_of s0_internal VSRootPT_T ptr = Some pte; is_PageTablePTE pte \ + \ table_base VSRootPT_T ptr = Low_pd_ptr \ pte = PageTablePTE (ppn_from_pptr Low_pt_ptr) + \ table_base VSRootPT_T ptr = High_pd_ptr \ pte = PageTablePTE (ppn_from_pptr High_pt_ptr)" by (auto simp: ptes_of_def pts_of_s0 obind_def kh0_obj_def split: option.splits if_splits) lemma Low_pt_is_aligned[simp]: - "is_aligned Low_pt_ptr pt_bits" + "is_aligned Low_pt_ptr (pt_bits NormalPT_T)" by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) +lemma Low_pt_is_aligned'[simp]: + "is_aligned Low_pt_ptr pageBits" + by (fold pt_bits_NormalPT_T) simp + +lemma is_aligned_pptr_base: + "is_aligned pptr_base pptrBaseOffset_alignment" + by (simp add: is_aligned_def pptr_base_def pptrBase_def pptrBaseOffset_alignment_def) + +lemma pptr_base_leq[simp]: + "pptr_base \ Low_pt_ptr" + "pptr_base \ Low_pd_ptr" + "pptr_base \ High_pt_ptr" + "pptr_base \ High_pd_ptr" + unfolding Low_pt_ptr_def Low_pd_ptr_def High_pt_ptr_def High_pd_ptr_def + apply (all \rule is_aligned_no_wrap'[OF is_aligned_pptr_base]\) + apply (simp_all add: pptrBaseOffset_alignment_def) + done + +lemma pptr_base_less[simp]: + "Low_pt_ptr < pptrTop" + "Low_pd_ptr < pptrTop" + "High_pt_ptr < pptrTop" + "High_pd_ptr < pptrTop" + by (auto simp: Low_pt_ptr_def Low_pd_ptr_def High_pt_ptr_def High_pd_ptr_def pptrTop_def pptr_base_def pptrBase_def) + lemma High_pt_is_aligned[simp]: - "is_aligned High_pt_ptr pt_bits" + "is_aligned High_pt_ptr (pt_bits NormalPT_T)" by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) +lemma High_pt_is_aligned'[simp]: + "is_aligned High_pt_ptr pageBits" + by (fold pt_bits_NormalPT_T) simp + lemma Low_pd_is_aligned[simp]: - "is_aligned Low_pd_ptr pt_bits" + "is_aligned Low_pd_ptr (pt_bits VSRootPT_T)" by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) lemma High_pd_is_aligned[simp]: - "is_aligned High_pd_ptr pt_bits" + "is_aligned High_pd_ptr (pt_bits VSRootPT_T)" by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma ptrFromPAddr_simps[simp]: + "ptrFromPAddr (paddr_from_ppn (ppn_from_pptr Low_pt_ptr)) = Low_pt_ptr" + "ptrFromPAddr (paddr_from_ppn (ppn_from_pptr High_pt_ptr)) = High_pt_ptr" + by (auto simp: ptrFromPAddr_addr_from_ppn) + +lemma table_base_simps[simp]: + "table_base VSRootPT_T (pt_slot_offset max_pt_level Low_pd_ptr vref) = Low_pd_ptr" + "table_base VSRootPT_T (pt_slot_offset max_pt_level High_pd_ptr vref) = High_pd_ptr" + by (auto intro: table_base_pt_slot_offset[where level=max_pt_level, simplified level_type_max]) + lemma shared_page_ptr_is_aligned[simp]: - "is_aligned shared_page_ptr_virt pt_bits" - by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + "is_aligned shared_page_ptr_virt (pageBitsForSize max_page_size)" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def max_page_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def pageBits_def) + +lemma asid_high_low: + "\ asid_high_bits_of asid = asid_high_bits_of asid'; + asid_low_bits_of asid = asid_low_bits_of asid' \ \ + asid = asid'" + unfolding asid_high_bits_of_def asid_low_bits_of_def asid_high_bits_def asid_low_bits_def + by word_bitwise simp lemma vs_lookup_s0_SomeD: "vs_lookup_table lvl asid vref s0_internal = Some (lvl', p) @@ -1081,26 +1151,60 @@ lemma vs_lookup_s0_SomeD: apply (clarsimp simp: vs_lookup_table_def obind_def split: option.splits if_splits) apply (clarsimp simp: pool_for_asid_s0 split: if_splits) apply (case_tac "lvl = max_pt_level") - apply (clarsimp simp: asid_pools_of_s0 pool_for_asid_s0 asid_high_low vspace_for_pool_def + apply (clarsimp simp: asid_pools_of_s0 pool_for_asid_s0 asid_high_low vspace_for_pool_def entry_for_pool_def split: if_splits) apply (case_tac "lvl = max_pt_level - 1") apply (clarsimp simp: pt_walk.simps split: if_splits) apply (drule (1) ptes_of_s0_PageTablePTE) - apply (auto simp: pptr_from_pte_def ptrFromPAddr_addr_from_ppn' ptes_of_def asid_high_low - kh0_obj_def pts_of_s0 pool_for_asid_s0 asid_pools_of_s0 vspace_for_pool_def + apply (auto simp: pptr_from_pte_def ptes_of_def asid_high_low + kh0_obj_def pts_of_s0 pool_for_asid_s0 asid_pools_of_s0 vspace_for_pool_def entry_for_pool_def split: if_splits)[2] apply (clarsimp simp: pt_walk.simps) apply (clarsimp split: if_splits) apply (drule (1) ptes_of_s0_PageTablePTE) apply (erule disjE; clarsimp) - by (clarsimp simp: pptr_from_pte_def ptrFromPAddr_addr_from_ppn' kh0_obj_def - pt_walk.simps ptes_of_def pts_of_s0 asid_high_low - pool_for_asid_s0 asid_pools_of_s0 vspace_for_pool_def - split: if_splits)+ - -lemma pt_bits_left_max_minus_1_pageBitsForSize: - "pt_bits_left (max_pt_level - 1) = pageBitsForSize RISCVLargePage" - apply (clarsimp simp: pt_bits_left_def max_pt_level_def2) + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pptr_from_pte_def asid_pools_of_s0 pool_for_asid_s0 + split: if_splits) + apply (clarsimp simp: pts_of_s0 asid_high_low) + apply (subst (asm) pt_walk.simps) + apply (clarsimp split: if_splits) + apply (clarsimp simp: level_pte_of_def pt_apply_def split: pt.splits option.splits if_splits simp: obind_def) + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pptr_from_pte_def asid_pools_of_s0 pool_for_asid_s0 + split: if_splits) + apply (clarsimp simp: pts_of_s0 asid_high_low) + apply (subst (asm) pt_walk.simps) + apply (clarsimp split: if_splits) + apply (clarsimp simp: level_pte_of_def pt_apply_def split: pt.splits option.splits if_splits simp: obind_def) + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pptr_from_pte_def asid_pools_of_s0 pool_for_asid_s0 + split: if_splits) + apply (clarsimp simp: pts_of_s0 asid_high_low) + apply (clarsimp simp: pts_of_s0 asid_high_low) + done + +lemma ptr_range_weaken: + "\ (x :: machine_word) \ ptr_range ptr sz'; sz' \ sz; sz \ word_bits; is_aligned ptr sz \ \ x \ ptr_range ptr sz" + apply (clarsimp simp: ptr_range_def) + apply (erule order.trans) + apply (frule (1) order.trans) + apply (subgoal_tac "ptr + mask sz' \ ptr + mask sz") + apply (clarsimp simp: mask_def p_assoc_help) + apply (subgoal_tac "is_aligned ptr sz \ is_aligned ptr sz'") + apply (rule aligned_mask_step; clarsimp simp: is_aligned_no_overflow_mask) + apply (auto elim: is_aligned_weaken) + done + +lemma max_page_level_def2: + "max_page_level = max_pt_level - 1" + by (simp add: max_pt_level_def max_page_level_def asid_pool_level_def) + +lemma ptr_range_max_pt_level_minus_1: + "\ (x :: machine_word) \ ptr_range ptr (pt_bits_left (max_pt_level - 1)); + is_aligned ptr (pageBitsForSize max_page_size)\ + \ x \ ptr_range ptr (pageBitsForSize max_page_size)" + apply (erule ptr_range_weaken) + apply (clarsimp simp: max_page_size_def2 max_page_level_def2) + apply (clarsimp simp: word_bits_def max_page_size_def pageBits_def ptTranslationBits_def split: if_splits) + apply assumption done lemma Sys1_pas_refined: @@ -1109,7 +1213,7 @@ lemma Sys1_pas_refined: apply (intro conjI) apply (simp add: Sys1_pas_wellformed) apply (clarsimp simp: irq_map_wellformed_aux_def s0_internal_def Sys1AgentMap_def Sys1PAS_def) - apply (clarsimp simp: s0_ptr_defs ptr_range_def) + apply (clarsimp simp: s0_ptr_defs ptr_range_def ptTranslationBits_def pageBits_def cte_level_bits_def) apply word_bitwise apply (clarsimp simp: tcb_domain_map_wellformed_aux_def minBound_word High_domain_def Low_domain_def Sys1PAS_def Sys1AgentMap_def default_domain_def) @@ -1132,9 +1236,13 @@ lemma Sys1_pas_refined: apply (elim disjE; clarsimp) apply ((clarsimp simp: s0_internal_def kh0_obj_def opt_map_def vs_refs_aux_def vm_read_only_def vspace_cap_rights_to_auth_def pte_ref2_def - Sys1AuthGraph_def Sys1AgentMap_simps graph_of_def ptrFromPAddr_addr_from_ppn' - shared_page_ptr_phys_def pt_bits_left_max_minus_1_pageBitsForSize - dest!: kh0_SomeD split: option.splits if_splits)+)[6] + Sys1AuthGraph_def Sys1AgentMap_simps graph_of_def + shared_page_ptr_phys_def + dest!: kh0_SomeD split: option.splits if_splits | drule ptr_range_max_pt_level_minus_1)+)[6] + apply (clarsimp simp: state_hyp_refs_of_def hyp_refs_of_def tcb_vcpu_refs_def + s0_internal_def refs_of_ao_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (auto dest: kh0_SomeD simp: kh0_obj_def)[2] apply (rule subsetI, clarsimp) apply (erule state_asids_to_policy_aux.cases) apply (drule s0_caps_of_state, clarsimp) @@ -1178,7 +1286,7 @@ lemma Sys1_pas_wellformed_noninterference: lemma Sys1AgentMap_shared_page_ptr: "Sys1AgentMap shared_page_ptr_virt = partition_label Low" - by (clarsimp simp: Sys1AgentMap_def s0_ptr_defs ptr_range_def bit_simps) + by (clarsimp simp: Sys1AgentMap_def s0_ptr_defs ptr_range_def bit_simps max_page_size_def) lemma silc_inv_s0: "silc_inv Sys1PAS s0_internal s0_internal" @@ -1224,7 +1332,6 @@ lemma only_timer_irq_s0: "only_timer_irq timer_irq s0_internal" apply (clarsimp simp: only_timer_irq_def s0_internal_def irq_is_recurring_def is_irq_at_def irq_at_def Let_def irq_oracle_def machine_state0_def timer_irq_def) - apply presburger done lemma domain_sep_inv_s0: @@ -1232,6 +1339,7 @@ lemma domain_sep_inv_s0: apply (clarsimp simp: domain_sep_inv_def) apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state | rule conjI allI | clarsimp simp: s0_internal_def)+ + apply (clarsimp simp: timer_irq_def non_kernel_IRQs_def irqVGICMaintenance_def irqVTimerEvent_def) done lemma only_timer_irq_inv_s0: @@ -1269,13 +1377,13 @@ lemma valid_caps_s0[simp]: "s0_internal \ CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2)" "s0_internal \ ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid)" "s0_internal \ ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid)" - "s0_internal \ ArchObjectCap (PageTableCap Low_pd_ptr (Some (Low_asid,0)))" - "s0_internal \ ArchObjectCap (PageTableCap High_pd_ptr (Some (High_asid,0)))" - "s0_internal \ ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0)))" - "s0_internal \ ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0)))" - "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write RISCVLargePage False (Some (Low_asid,0)))" - "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (High_asid,0)))" - "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only RISCVLargePage False (Some (Silc_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid,0)))" "s0_internal \ NotificationCap ntfn_ptr 0 {AllowWrite}" "s0_internal \ NotificationCap ntfn_ptr 0 {AllowRead}" "s0_internal \ ReplyCap Low_tcb_ptr True {AllowGrant,AllowWrite}" @@ -1284,7 +1392,8 @@ lemma valid_caps_s0[simp]: valid_cap_def cap_aligned_def is_aligned_def obj_at_def cte_level_bits_def is_ntfn_def is_tcb_def is_cap_table_def a_type_def the_nat_to_bl_def nat_to_bl_def Low_asid_def High_asid_def Silc_asid_def asid_low_bits_def asid_bits_def - wellformed_mapdata_def valid_vm_rights_def vmsz_aligned_def) + wellformed_mapdata_def valid_vm_rights_def vmsz_aligned_def + max_page_size_def pageBits_def ptTranslationBits_def) lemma valid_obj_s0[simp]: "valid_obj Low_cnode_ptr Low_cnode s0_internal" @@ -1301,7 +1410,7 @@ lemma valid_obj_s0[simp]: "valid_obj Low_tcb_ptr Low_tcb s0_internal" "valid_obj High_tcb_ptr High_tcb s0_internal" "valid_obj idle_tcb_ptr idle_tcb s0_internal" - "valid_obj arm_global_pt_ptr init_global_pt s0_internal" + "valid_obj arm_global_pt_ptr (ArchObj global_pt_obj) s0_internal" "valid_obj shared_page_ptr_virt shared_page s0_internal" apply (simp_all add: valid_obj_def kh0_obj_def) apply (simp add: valid_cs_def Low_caps_ran High_caps_ran Silc_caps_ran @@ -1310,6 +1419,7 @@ lemma valid_obj_s0[simp]: apply (simp add: valid_cs_def valid_cs_size_def word_bits_def cte_level_bits_def well_formed_cnode_n_def) apply (clarsimp simp: valid_tcb_def tcb_cap_cases_def valid_tcb_state_def valid_arch_tcb_def + valid_pt_range_def invalid_mapping_slots_def is_valid_vtable_root_def is_master_reply_cap_def is_ntfn_def obj_at_def wellformed_pte_def valid_vm_rights_def vm_kernel_only_def | fastforce simp: s0_internal_def kh0_def kh0_obj_def)+ @@ -1317,20 +1427,20 @@ lemma valid_obj_s0[simp]: lemma valid_objs_s0: "valid_objs s0_internal" - apply (clarsimp simp: valid_objs_def) - apply (subst (asm) s0_internal_def, clarsimp) - apply (drule kh0_SomeD) - apply (elim disjE; clarsimp) - apply (fastforce simp: valid_obj_def valid_cs_def valid_cs_size_def + apply (clarsimp simp: valid_objs_def) + apply (subst (asm) s0_internal_def, clarsimp) + apply (drule kh0_SomeD) + apply (elim disjE; clarsimp) + apply (fastforce simp: valid_obj_def valid_cs_def valid_cs_size_def cte_level_bits_def word_bits_def well_formed_cnode_n_def) - done + done lemma pspace_aligned_s0: "pspace_aligned s0_internal" apply (clarsimp simp: pspace_aligned_def s0_internal_def) apply (drule kh0_SomeD) apply (auto simp: cte_level_bits_def irq_node_offs_range_def - is_aligned_def s0_ptr_defs kh0_obj_def bit_simps) + is_aligned_def s0_ptr_defs kh0_obj_def bit_simps max_page_size_def) done lemma pspace_distinct_s0: @@ -1346,12 +1456,13 @@ lemma pspace_distinct_s0: apply auto[1] apply (elim disjE) (* slow *) - by (simp | clarsimp simp: kh0_obj_def cte_level_bits_def s0_ptr_defs pte_bits_def bit_simps - | fastforce - | clarsimp simp: irq_node_offs_range_def s0_ptr_defs, - drule_tac x="0x1F" in word_plus_strict_mono_right, simp, simp add: add.commute, - drule(1) notE[rotated, OF less_trans, OF _ _ leD, rotated 2] - | drule(1) notE[rotated, OF le_less_trans, OF _ _ leD, rotated 2], simp, assumption)+ + by ((simp | clarsimp simp: kh0_obj_def cte_level_bits_def s0_ptr_defs pte_bits_def bit_simps + | fastforce split: if_split_asm + | clarsimp simp: irq_node_offs_range_def s0_ptr_defs irq_len_def cte_level_bits_def, + drule_tac x="0x1F" in word_plus_strict_mono_right, simp, simp add: add.commute, + drule(1) notE[rotated, OF less_trans, OF _ _ leD, rotated 2] + | drule(1) notE[rotated, OF le_less_trans, OF _ _ leD, rotated 2], simp, assumption)+) + lemma valid_pspace_s0[simp]: "valid_pspace s0_internal" @@ -1360,7 +1471,7 @@ lemma valid_pspace_s0[simp]: apply (clarsimp simp: if_live_then_nonz_cap_def) apply (subst (asm) s0_internal_def) apply (clarsimp simp: ex_nonz_cap_to_def live_def arch_tcb_live_def - hyp_live_def obj_at_def kh0_def kh0_obj_def + hyp_live_def obj_at_def kh0_def kh0_obj_def arch_live_def split: if_splits) apply (rule_tac x="High_cnode_ptr" in exI) apply (rule_tac x="the_nat_to_bl_10 1" in exI) @@ -1378,7 +1489,7 @@ lemma valid_pspace_s0[simp]: apply (force dest: s0_caps_of_state simp: cte_wp_at_caps_of_state zombies_final_def is_zombie_def) apply (clarsimp simp: sym_refs_def state_refs_of_def state_hyp_refs_of_def refs_of_def s0_internal_def kh0_def kh0_obj_def) - apply (clarsimp simp: sym_refs_def state_hyp_refs_of_def s0_internal_def kh0_def) + apply (clarsimp simp: sym_refs_def state_hyp_refs_of_def s0_internal_def kh0_def kh0_obj_def) done lemma descendants_s0[simp]: @@ -1477,18 +1588,38 @@ lemma valid_global_refs_s0[simp]: | simp only: s0_ptr_defs, force)+ done + +lemma valid_uses_init_A_st[simp]: "valid_uses_2 init_vspace_uses" +proof - + have "\p. p < pptrTop \ canonical_address p" + by (simp add: canonical_address_range canonical_bit_def mask_def pptrTop_def + word_le_nat_alt word_less_nat_alt) + moreover + have "pptr_base < pptrTop" + by (simp add: pptrTop_def pptr_base_def pptrBase_def) + moreover + have "pptrTop < kdev_base" + by (simp add: kdev_base_def kdevBase_def pptrTop_def) + ultimately + show ?thesis + unfolding valid_uses_2_def init_vspace_uses_def window_defs + by (auto simp: kernel_window_range_def) +qed + lemma valid_arch_state_s0[simp]: "valid_arch_state s0_internal" apply (clarsimp simp: valid_arch_state_def s0_internal_def arch_state0_def) apply (intro conjI) - apply (auto simp: valid_asid_table_def kh0_def kh0_obj_def opt_map_def split: option.splits)[1] - apply (fastforce simp: valid_global_arch_objs_def obj_at_def kh0_def a_type_def - init_global_pt_def max_pt_level_not_asid_pool_level[symmetric]) - apply (clarsimp simp: valid_global_tables_def pt_walk.simps obind_def) - apply (fastforce dest: pt_walk_max_level - simp: obind_def opt_map_def asid_pool_level_eq geq_max_pt_level pte_of_def kh0_def - kh0_obj_def pte_rights_of_def - split: if_splits) + apply (auto simp: valid_asid_table_def kh0_def kh0_obj_def opt_map_def asid_entry_def + asid_high_bits_of_def asid_low_bits_def Low_asid_def High_asid_def + split: option.splits)[1] + apply (clarsimp simp: vmid_inv_def is_inv_def) + apply (clarsimp simp: valid_vmid_table_def) + apply (clarsimp simp: cur_vcpu_def) + apply (clarsimp simp: valid_global_arch_objs_def obj_at_def kh0_def a_type_def + max_pt_level_not_asid_pool_level[symmetric] global_pt_obj_def) + apply (clarsimp simp: valid_global_tables_def opt_map_def kh0_def global_pt_obj_def empty_pt_def) + apply (clarsimp simp: valid_numlistregs_def word_bits_def max_numlistregs_def) done lemma valid_irq_node_s0[simp]: @@ -1497,15 +1628,15 @@ lemma valid_irq_node_s0[simp]: apply (rule conjI) apply (simp add: s0_internal_def) apply (rule injI) - apply simp + apply (simp add: cte_level_bits_def) apply (rule ccontr) - apply (rule_tac bnd="0x40" and 'a=64 in shift_distinct_helper[rotated 3]) + apply (rule_tac bnd="0x200" and 'a=64 in shift_distinct_helper[rotated 3]) apply assumption - apply simp + apply (simp add: cte_level_bits_def) apply simp - apply (rule ucast_less[where 'b=6, simplified]) + apply (rule ucast_less[where 'b=9, simplified]) apply simp - apply (rule ucast_less[where 'b=6, simplified]) + apply (rule ucast_less[where 'b=9, simplified]) apply simp apply (rule notI) apply (drule ucast_up_inj) @@ -1534,10 +1665,11 @@ lemma valid_arch_objs_s0[simp]: "valid_vspace_objs s0_internal" apply (clarsimp simp: valid_vspace_objs_def obj_at_def) apply (drule vs_lookup_s0_SomeD) - apply (auto simp: aobjs_of_Some kh_s0_def kh0_obj_def data_at_def obj_at_def - ptrFromPAddr_addr_from_ppn' vmpage_size_of_level_def max_pt_level_def2 - shared_page_ptr_phys_def) - done + apply (elim disjE) + by (auto simp: aobjs_of_Some kh_s0_def kh0_obj_def data_at_def obj_at_def + max_pt_level_def2 vmsize_of_level_def max_page_level_def + shared_page_ptr_phys_def max_page_size_def opt_map_def + split: option.splits) lemma valid_vs_lookup_s0_internal: "valid_vs_lookup s0_internal" @@ -1548,7 +1680,7 @@ lemma valid_vs_lookup_s0_internal: apply (clarsimp simp: valid_vs_lookup_def vs_lookup_target_def vs_lookup_slot_def split: if_splits) \ \asid pool level\ apply (drule vs_lookup_level) - apply (clarsimp simp: pool_for_asid_vs_lookup pool_for_asid_s0 asid_pools_of_s0 + apply (clarsimp simp: pool_for_asid_vs_lookup pool_for_asid_s0 asid_pools_of_s0 entry_for_pool_def vspace_for_pool_def user_region_def vref_for_level_asid_pool dest!: asid_high_low split: if_splits) \ \High asid\ @@ -1573,89 +1705,113 @@ lemma valid_vs_lookup_s0_internal: prefer 2 \ \bot level = max pt level\ - apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 + apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 entry_for_pool_def dest!: asid_high_low split: if_splits) \ \High asid\ apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) apply (rule_tac x=High_cnode_ptr in exI) apply (rule_tac x="(the_nat_to_bl_10 6)" in exI) - apply (rule_tac x="ArchObjectCap (PageTableCap High_pt_ptr (Some (High_asid,0)))" in exI) + apply (rule_tac x="ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0)))" in exI) apply (subst (asm) s0_internal_def) - apply (clarsimp simp: in_omonad ptes_of_def High_pd_def ptrFromPAddr_addr_from_ppn' + apply (clarsimp simp: in_omonad ptes_of_def High_pd_def dest!: kh0_SomeD split: if_splits) - apply (intro conjI) + apply (intro conjI) apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_simps s0_internal_def kh0_def well_formed_cnode_n_def) - apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (word_bitwise, fastforce) - apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + apply (clarsimp simp: pptr_from_pte_def) + apply (clarsimp simp: vref_for_level_def user_region_simps mask_def bit_simps pt_simps asid_pool_level_def s0_ptr_defs split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) \ \Low asid\ apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) apply (rule_tac x=Low_cnode_ptr in exI) apply (rule_tac x="(the_nat_to_bl_10 6)" in exI) - apply (rule_tac x="ArchObjectCap (PageTableCap Low_pt_ptr (Some (Low_asid,0)))" in exI) + apply (rule_tac x="ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0)))" in exI) apply (subst (asm) s0_internal_def) - apply (clarsimp simp: in_omonad ptes_of_def Low_pd_def ptrFromPAddr_addr_from_ppn' + apply (clarsimp simp: in_omonad ptes_of_def Low_pd_def dest!: kh0_SomeD split: if_splits) - apply (intro conjI) + apply (intro conjI) apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps s0_internal_def kh0_def well_formed_cnode_n_def) - apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (word_bitwise, fastforce) - apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + apply (clarsimp simp: pptr_from_pte_def) + apply (clarsimp simp: vref_for_level_def user_region_simps mask_def bit_simps pt_simps asid_pool_level_def s0_ptr_defs split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) \ \bot level < max pt level\ - apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 + apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 entry_for_pool_def dest!: asid_high_low split: if_splits) \ \High asid\ apply (subst (asm) ptes_of_def) apply (clarsimp simp: pts_of_s0) - apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def ptrFromPAddr_addr_from_ppn' + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def split: if_splits) apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) apply (prop_tac "pt_walk (max_pt_level - 1) bot_level High_pt_ptr vref (ptes_of s0_internal) = Some (max_pt_level - 1, High_pt_ptr)") apply (clarsimp simp: pt_walk.simps) apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) - apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def ptrFromPAddr_addr_from_ppn' - split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) apply (rule_tac x=High_cnode_ptr in exI) apply (rule_tac x="the_nat_to_bl_10 5" in exI) apply (rule exI, intro conjI) apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_simps s0_internal_def kh0_def well_formed_cnode_n_def) - apply clarsimp - apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (word_bitwise, fastforce) - \ \Low asid\ - prefer 2 + apply (clarsimp split: if_splits) + apply (clarsimp split: if_splits) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply word_bitwise + apply word_bitwise apply (subst (asm) ptes_of_def) apply (clarsimp simp: pts_of_s0) - apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def ptrFromPAddr_addr_from_ppn' + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def split: if_splits) - apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) - apply (prop_tac "pt_walk (max_pt_level - 1) bot_level Low_pt_ptr vref (ptes_of s0_internal) = - Some (max_pt_level - 1, Low_pt_ptr)") + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level High_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, High_pt_ptr)") apply (clarsimp simp: pt_walk.simps) apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) - apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def ptrFromPAddr_addr_from_ppn' - split: if_splits) - apply (rule_tac x=Low_cnode_ptr in exI) - apply (rule_tac x="the_nat_to_bl_10 5" in exI) - apply (rule exI, intro conjI) - apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps - s0_internal_def kh0_def well_formed_cnode_n_def) - apply clarsimp - apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (word_bitwise, fastforce) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) + + \ \Low asid\ + + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def + split: if_splits) + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level Low_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, Low_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="the_nat_to_bl_10 5" in exI) + apply (rule exI, intro conjI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp split: if_splits) + apply (clarsimp split: if_splits) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply word_bitwise + apply word_bitwise + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) + \ \No lookups to other ptes\ - apply (clarsimp simp: in_omonad ptes_of_def pts_of_s0 split: if_splits) - apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) - apply (clarsimp simp: in_omonad ptes_of_def pts_of_s0 split: if_splits) - apply (clarsimp simp: kh0_obj_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs) - apply (rule FalseE, word_bitwise, fastforce simp: elf_index_value) + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def + split: if_splits) + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level Low_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, Low_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) done lemma valid_arch_caps_s0[simp]: @@ -1715,112 +1871,30 @@ lemma equal_kernel_mappings_s0[simp]: pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 apply (clarsimp simp: equal_kernel_mappings_def obj_at_def vspace_for_asid_def vspace_for_pool_def pool_for_asid_s0 asid_pools_of_s0) - apply (clarsimp simp: obind_def pts_of_s0) - apply (clarsimp simp: has_kernel_mappings_def split: if_splits) - apply (rule conjI; clarsimp) - apply (clarsimp simp: kernel_mapping_slots_def s0_ptr_defs misc) - apply (fastforce simp: pts_of_s0 s0_internal_def arch_state0_def - kh0_obj_def opt_map_def riscv_global_pt_def - dest!: kh0_SomeD split: if_splits option.splits) - apply (clarsimp simp: pts_of_s0) - apply (clarsimp simp: s0_internal_def riscv_global_pt_def arch_state0_def kh0_obj_def - kernel_mapping_slots_def s0_ptr_defs misc elf_index_value)+ done lemma valid_asid_map_s0[simp]: "valid_asid_map s0_internal" by (clarsimp simp: valid_asid_map_def s0_internal_def arch_state0_def) -lemma valid_global_pd_mappings_s0_helper: - "\ pptr_base \ vref; vref < pptr_base + (1 << kernel_window_bits) \ - \ \a b. pt_lookup_target 0 arm_global_pt_ptr vref (ptes_of s0_internal) = Some (a, b) \ - is_aligned b (pt_bits_left a) \ - addrFromPPtr b + (vref && mask (pt_bits_left a)) = addrFromPPtr vref" - supply misc = vref_for_level_def pt_bits_left_def asid_pool_level_size - pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 - apply (clarsimp simp: pt_lookup_target_def obind_def split: option.splits) - apply (prop_tac "pt_lookup_slot_from_level max_pt_level 0 arm_global_pt_ptr vref (ptes_of s0_internal) = - Some (max_pt_level, pt_slot_offset max_pt_level arm_global_pt_ptr vref)") - apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) - apply (fastforce simp: ptes_of_def in_omonad s0_internal_def kh0_def init_global_pt_def - global_pte_def is_aligned_pt_slot_offset_pte) - apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) - apply (rule conjI; clarsimp dest!: pt_walk_max_level simp: max_pt_level_def2 split: if_splits) - apply (rule conjI; clarsimp) - apply (clarsimp simp: ptes_of_def pts_of_s0 global_pte_def kernel_window_bits_def - table_index_offset_pt_bits_left is_aligned_pt_slot_offset_pte - split: if_splits) - apply (clarsimp simp: misc s0_ptr_defs) - apply (word_bitwise, fastforce) - apply (clarsimp simp: misc s0_ptr_defs kernel_mapping_slots_def) - apply (word_bitwise, fastforce) - apply (clarsimp simp: ptes_of_def pts_of_s0 is_aligned_pt_slot_offset_pte global_pte_def - split: if_splits) - apply (clarsimp simp: addr_from_ppn_def ptrFromPAddr_def addrFromPPtr_def bit_simps - mask_def s0_ptr_defs pt_bits_left_def max_pt_level_def2 - pptrBaseOffset_def paddrBase_def is_aligned_def kernel_window_bits_def) - apply (word_bitwise, fastforce) - apply (clarsimp simp: addr_from_ppn_def ptrFromPAddr_def addrFromPPtr_def bit_simps is_aligned_def - s0_ptr_defs pt_bits_left_def max_pt_level_def2 kernel_mapping_slots_def - mask_def pt_slot_offset_def pt_index_def pptrBaseOffset_def paddrBase_def - toplevel_bits_value elf_index_value kernel_window_bits_def) - apply (word_bitwise, fastforce) - done - -lemma ptes_of_elf_window: - "\kernel_elf_base \ vref; vref < kernel_elf_base + 2 ^ pageBits\ - \ ptes_of s0_internal (pt_slot_offset max_pt_level arm_global_pt_ptr vref) - = Some (global_pte elf_index)" - unfolding ptes_of_def pts_of_s0 - apply (clarsimp simp: obind_def elf_window_4k is_aligned_pt_slot_offset_pte) - done - -lemma valid_global_pd_mappings_s0_helper': - "\ kernel_elf_base \ vref; vref < kernel_elf_base + (1 << pageBits) \ - \ \a b. pt_lookup_target 0 arm_global_pt_ptr vref (ptes_of s0_internal) = Some (a, b) \ - is_aligned b (pt_bits_left a) \ - addrFromPPtr b + (vref && mask (pt_bits_left a)) = addrFromKPPtr vref" - supply misc = vref_for_level_def pt_bits_left_def asid_pool_level_size - pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 - apply (clarsimp simp: pt_lookup_target_def obind_def split: option.splits) - apply (prop_tac "pt_lookup_slot_from_level max_pt_level 0 arm_global_pt_ptr vref (ptes_of s0_internal) = - Some (max_pt_level, pt_slot_offset max_pt_level arm_global_pt_ptr vref)") - apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) - apply (fastforce simp: ptes_of_def in_omonad s0_internal_def kh0_def init_global_pt_def - global_pte_def is_aligned_pt_slot_offset_pte) - apply (rule conjI; clarsimp) - apply (rule conjI; clarsimp) - apply (clarsimp simp: pt_lookup_slot_from_level_def pt_walk.simps) - apply (rule conjI; clarsimp) - apply (clarsimp simp: ptes_of_elf_window global_pte_def split: if_splits) - apply (clarsimp simp: ptes_of_elf_window global_pte_def elf_index_value) - apply (clarsimp simp: is_aligned_ptrFromPAddr_kernelELFPAddrBase kernelELFPAddrBase_addrFromKPPtr) - done - lemma valid_global_pd_mappings_s0[simp]: "valid_global_vspace_mappings s0_internal" - unfolding valid_global_vspace_mappings_def Let_def - apply (intro conjI) - apply (simp add: s0_internal_def arch_state0_def riscv_global_pt_def) - apply (fastforce simp: s0_internal_def arch_state0_def in_omonad kernel_window_def - init_vspace_uses_def translate_address_def riscv_global_pt_def - dest!: valid_global_pd_mappings_s0_helper split: if_splits) - apply (fastforce simp: translate_address_def in_omonad s0_internal_def arch_state0_def - riscv_global_pt_def kernel_elf_window_def init_vspace_uses_def - dest!: valid_global_pd_mappings_s0_helper' split: if_splits) - done + unfolding valid_global_vspace_mappings_def by simp lemma pspace_in_kernel_window_s0[simp]: "pspace_in_kernel_window s0_internal" - apply (clarsimp simp: pspace_in_kernel_window_def kernel_window_def + apply (clarsimp simp: pspace_in_kernel_window_def kernel_window_def kernel_window_range_def init_vspace_uses_def s0_internal_def arch_state0_def) - apply (subgoal_tac "x \ {pptr_base.. {pptr_base..Haskell state\ @@ -1922,6 +1999,11 @@ lemma Sys1_valid_initial_state_noenabled: domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain idle_equiv_refl) apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + apply (intro conjI) + apply (clarsimp simp: valid_cur_hyp_def valid_cur_vcpu_def pred_tcb_at_def obj_at_def kh0_def + kh0_obj_def active_cur_vcpu_of_def arch_state0_def) + apply (clarsimp simp: cur_hyp_in_cur_domain_def cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def arch_state0_def) + apply (clarsimp simp: cur_fpu_in_cur_domain_def arch_state0_def) apply (simp add: det_inv_s0) apply (simp add: s0_internal_def exst0_def) apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq diff --git a/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy index a7df9032df..448a462ae6 100644 --- a/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy +++ b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy @@ -9,6 +9,53 @@ theory Example_Valid_StateH imports "InfoFlow.Example_Valid_State" ArchADT_IF_Refine begin +(* FIXME AARCH64 IF: major cleanup *) + +context Arch begin arch_global_naming + +definition pg_index_bits :: nat where + "pg_index_bits \ pageBitsForSize (max_page_size) - pageBits" + +lemma pg_index_bits_def2: + "pg_index_bits \ if config_ARM_PA_SIZE_BITS_40 then 9 else 18" + apply (rule eq_reflection) + apply (simp add: pg_index_bits_def max_page_size_def bit_simps) + done + +lemma pg_index_bits_ge0[simp, intro!]: "0 < pg_index_bits" + by (simp add: pg_index_bits_def2) + +typedef pg_index_len = "{n :: nat. n < pg_index_bits}" by auto + +end + +instantiation AARCH64.pg_index_len :: len0 +begin + interpretation Arch . + definition len_of_pg_index_len: "len_of (x::pg_index_len itself) \ CARD(pg_index_len)" + instance .. +end + +instantiation AARCH64.pg_index_len :: len +begin + interpretation Arch . + instance + proof + show "0 < LENGTH(pg_index_len)" + by (simp add: len_of_pg_index_len type_definition.card[OF type_definition_pg_index_len]) + qed +end + +context Arch begin arch_global_naming + +type_synonym pg_index = "pg_index_len word" + +lemma length_pg_index_len[simp]: + "LENGTH(pg_index_len) = pg_index_bits" + by (simp add: len_of_pg_index_len type_definition.card[OF type_definition_pg_index_len]) + +end + context begin interpretation Arch . section \Haskell state\ @@ -36,16 +83,16 @@ definition Low_capsH :: "cnode_index \ (capability \ mdbnode) (the_nat_to_bl_10 2) \ (CNodeCap Low_cnode_ptr 10 2 10, MDB 0 Low_tcb_ptr False False), (the_nat_to_bl_10 3) - \ (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0))), + \ (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0))), MDB 0 (Low_tcb_ptr + 0x20) False False), (the_nat_to_bl_10 4) \ (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid)), Null_mdb), (the_nat_to_bl_10 5) - \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite RISCVLargePage + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite max_page_size False (Some (ucast Low_asid, 0))), MDB 0 (Silc_cnode_ptr + 0xA0) False False), (the_nat_to_bl_10 6) - \ (ArchObjectCap (PageTableCap Low_pt_ptr (Some (ucast Low_asid, 0))), Null_mdb), + \ (ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (ucast Low_asid, 0))), Null_mdb), (the_nat_to_bl_10 318) \ (NotificationCap ntfn_ptr 0 True False, MDB (Silc_cnode_ptr + 318 * 0x20) 0 False False))" @@ -69,16 +116,16 @@ definition High_capsH :: "cnode_index \ (capability \ mdbnode (the_nat_to_bl_10 2) \ (CNodeCap High_cnode_ptr 10 2 10, MDB 0 High_tcb_ptr False False), (the_nat_to_bl_10 3) - \ (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0))), + \ (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0))), MDB 0 (High_tcb_ptr + 0x20) False False), (the_nat_to_bl_10 4) \ (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid)), Null_mdb), (the_nat_to_bl_10 5) - \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast High_asid, 0))), MDB (Silc_cnode_ptr + 0xA0) 0 False False), (the_nat_to_bl_10 6) - \ (ArchObjectCap (PageTableCap High_pt_ptr (Some (ucast High_asid, 0))), + \ (ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (ucast High_asid, 0))), Null_mdb), (the_nat_to_bl_10 318) \ (NotificationCap ntfn_ptr 0 False True, MDB 0 (Silc_cnode_ptr + 318 * 0x20) False False))" @@ -101,7 +148,7 @@ definition Silc_capsH :: "cnode_index \ (capability \ mdbnode ((the_nat_to_bl_10 2) \ (CNodeCap Silc_cnode_ptr 10 2 10, Null_mdb), (the_nat_to_bl_10 5) - \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast Silc_asid, 0))), MDB (Low_cnode_ptr + 0xA0) (High_cnode_ptr + 0xA0) False False), (the_nat_to_bl_10 318) @@ -126,48 +173,32 @@ definition ntfnH :: notification where text \Global page table\ -definition global_pteH' :: "pt_index \ pte" where - "global_pteH' idx \ - if idx = 0x100 - then PagePTE ((ucast (idx && mask (ptTranslationBits - 1)) << ptTranslationBits * size max_pt_level)) - False False False VMKernelOnly - else if idx = elf_index - then PagePTE (ucast ((kernelELFPAddrBase && ~~mask toplevel_bits) >> pageBits)) False False False VMKernelOnly - else InvalidPTE" - -definition global_pteH where - "global_pteH \ (\idx. if idx \ kernel_mapping_slots then global_pteH' idx else InvalidPTE)" +abbreviation (input) pt_lift where + "pt_lift pt_t pt \ \base offs. + if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ (pt_bits pt_t) - 1 + then Some (KOArch (KOPTE (pt (ucast (offs - base >> 3))))) + else None" definition global_ptH :: "obj_ref \ obj_ref \ kernel_object option" where - "global_ptH \ \base. - (map_option (\x. KOArch (KOPTE (global_pteH (x :: pt_index))))) \ - (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 - then Some (ucast (offs - base >> 3)) else None)" - + "global_ptH \ pt_lift VSRootPT_T (\_. InvalidPTE)" text \Low's page tables\ definition Low_pt'H :: "pt_index \ pte" where "Low_pt'H \ (\_. InvalidPTE) - (0 := PagePTE (shared_page_ptr_phys >> pt_bits) False False False VMReadWrite)" + (0 := PagePTE shared_page_ptr_phys False False True False VMReadWrite)" definition Low_ptH :: "obj_ref \ obj_ref \ kernel_object option" where - "Low_ptH \ - \base. (map_option (\x. KOArch (KOPTE (Low_pt'H x)))) \ - (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 - then Some (ucast (offs - base >> 3)) else None)" + "Low_ptH \ pt_lift NormalPT_T Low_pt'H" -definition Low_pd'H :: "pt_index \ pte" where +definition Low_pd'H :: "vs_index \ pte" where "Low_pd'H \ - global_pteH - (0 := PageTablePTE (addrFromPPtr Low_pt_ptr >> pt_bits) False)" + (\_. InvalidPTE) + (0 := PageTablePTE (addrFromPPtr Low_pt_ptr >> pageBits))" definition Low_pdH :: "obj_ref \ obj_ref \ kernel_object option" where - "Low_pdH \ - \base. (map_option (\x. KOArch (KOPTE (Low_pd'H x)))) \ - (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 - then Some (ucast (offs - base >> 3)) else None)" + "Low_pdH \ pt_lift VSRootPT_T Low_pd'H" text \High's page tables\ @@ -175,24 +206,18 @@ text \High's page tables\ definition High_pt'H :: "pt_index \ pte" where "High_pt'H \ (\_. InvalidPTE) - (0 := PagePTE (shared_page_ptr_phys >> pt_bits) False False False VMReadOnly)" + (0 := PagePTE shared_page_ptr_phys False False True False VMReadOnly)" definition High_ptH :: "obj_ref \ obj_ref \ kernel_object option" where - "High_ptH \ - \base. (map_option (\x. KOArch (KOPTE (High_pt'H x)))) \ - (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 - then Some (ucast (offs - base >> 3)) else None)" + "High_ptH \ pt_lift NormalPT_T High_pt'H" -definition High_pd'H :: "pt_index \ pte" where +definition High_pd'H :: "vs_index \ pte" where "High_pd'H \ - global_pteH - (0 := PageTablePTE (addrFromPPtr High_pt_ptr >> pt_bits) False)" + (\_. InvalidPTE) + (0 := PageTablePTE (addrFromPPtr High_pt_ptr >> pageBits))" definition High_pdH :: "obj_ref \ obj_ref \ kernel_object option" where - "High_pdH \ - \base. (map_option (\x. KOArch (KOPTE (High_pd'H x)))) \ - (\offs. if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ 12 - 1 - then Some (ucast (offs - base >> 3)) else None)" + "High_pdH \ pt_lift VSRootPT_T High_pd'H" text \Low's tcb\ @@ -201,7 +226,7 @@ definition Low_tcbH :: tcb where "Low_tcbH \ Thread \ \tcbCTable =\ (CTE (CNodeCap Low_cnode_ptr 10 2 10) (MDB (Low_cnode_ptr + 0x40) 0 False False)) - \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0)))) + \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0)))) (MDB (Low_cnode_ptr + 0x60) 0 False False)) \ \tcbReply =\ (CTE (ReplyCap Low_tcb_ptr True True) (MDB 0 0 True True)) \ \tcbCaller =\ (CTE NullCap Null_mdb) @@ -219,7 +244,7 @@ definition Low_tcbH :: tcb where \ \tcbSchedPrev =\ None \ \tcbSchedNext =\ None \ \tcbFlags =\ 0 - \ \tcbContext =\ (ArchThread undefined)" + \ \tcbContext =\ (ArchThread empty_context None)" text \High's tcb\ @@ -228,7 +253,7 @@ definition High_tcbH :: tcb where "High_tcbH \ Thread \ \tcbCTable =\ (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB (High_cnode_ptr + 0x40) 0 False False)) - \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) + \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) (MDB (High_cnode_ptr + 0x60) 0 False False)) \ \tcbReply =\ (CTE (ReplyCap High_tcb_ptr True True) (MDB 0 0 True True)) \ \tcbCaller =\ (CTE NullCap Null_mdb) @@ -246,8 +271,7 @@ definition High_tcbH :: tcb where \ \tcbSchedPrev =\ None \ \tcbSchedNext =\ None \ \tcbFlags =\ 0 - \ \tcbContext =\ (ArchThread undefined)" - + \ \tcbContext =\ (ArchThread empty_context None)" text \idle's tcb\ @@ -271,13 +295,13 @@ definition idle_tcbH :: tcb where \ \tcbSchedPrev =\ None \ \tcbSchedNext =\ None \ \tcbFlags =\ 0 - \ \tcbContext =\ (ArchThread empty_context)" + \ \tcbContext =\ (ArchThread empty_context None)" text \Low's asid pool\ -abbreviation Low_poolH' :: "obj_ref \ obj_ref" where - "Low_poolH' \ \idx. if idx = ucast (asid_low_bits_of Low_asid) then Some Low_pd_ptr else None" +abbreviation Low_poolH' :: "asid \ asidpool_entry" where + "Low_poolH' \ \idx. if idx = ucast (asid_low_bits_of Low_asid) then Some (ASIDPoolVSpace None Low_pd_ptr) else None" definition Low_poolH :: arch_kernel_object where "Low_poolH \ KOASIDPool (ASIDPool Low_poolH')" @@ -285,8 +309,8 @@ definition Low_poolH :: arch_kernel_object where text \High's asid pool\ -abbreviation High_poolH' :: "obj_ref \ obj_ref" where - "High_poolH' \ \idx. if idx = ucast (asid_low_bits_of High_asid) then Some High_pd_ptr else None" +abbreviation High_poolH' :: "asid \ asidpool_entry" where + "High_poolH' \ \idx. if idx = ucast (asid_low_bits_of High_asid) then Some (ASIDPoolVSpace None High_pd_ptr) else None" definition High_poolH :: arch_kernel_object where "High_poolH \ KOASIDPool (ASIDPool High_poolH')" @@ -296,7 +320,7 @@ text \Shared page\ definition shared_pageH :: "obj_ref \ obj_ref \ kernel_object option" where "shared_pageH \ \base. - (\offs. if is_aligned offs 12 \ base \ offs \ offs \ base + 2 ^ 21 - 1 + (\offs. if is_aligned offs 12 \ base \ offs \ offs \ base + mask (pageBitsForSize max_page_size) then Some KOUserData else None)" @@ -326,67 +350,78 @@ definition kh0H :: "(obj_ref \ kernel_object)" where option_update_range [High_tcb_ptr \ KOTCB High_tcbH] \ option_update_range [idle_tcb_ptr \ KOTCB idle_tcbH] \ option_update_range (shared_pageH shared_page_ptr_virt) \ - option_update_range (global_ptH riscv_global_pt_ptr) + option_update_range (global_ptH arm_global_pt_ptr) ) Map.empty" - lemma s0_ptrs_aligned: - "is_aligned riscv_global_pt_ptr 12" - "is_aligned High_pd_ptr 12" - "is_aligned Low_pd_ptr 12" + "is_aligned arm_global_pt_ptr (pt_bits VSRootPT_T)" + "is_aligned High_pd_ptr (pt_bits VSRootPT_T)" + "is_aligned Low_pd_ptr (pt_bits VSRootPT_T)" + "is_aligned arm_global_pt_ptr 13" + "is_aligned High_pd_ptr 13" + "is_aligned Low_pd_ptr 13" "is_aligned High_pt_ptr 12" "is_aligned Low_pt_ptr 12" "is_aligned Silc_cnode_ptr 15" "is_aligned High_cnode_ptr 15" "is_aligned Low_cnode_ptr 15" - "is_aligned High_tcb_ptr 10" - "is_aligned Low_tcb_ptr 10" - "is_aligned idle_tcb_ptr 10" + "is_aligned High_tcb_ptr 11" + "is_aligned Low_tcb_ptr 11" + "is_aligned idle_tcb_ptr 11" "is_aligned ntfn_ptr 5" - "is_aligned shared_page_ptr_virt 21" + "is_aligned shared_page_ptr_virt 30" "is_aligned irq_cnode_ptr 10" "is_aligned Low_pool_ptr 12" "is_aligned High_pool_ptr 12" - by (simp add: is_aligned_def s0_ptr_defs)+ + by (simp add: is_aligned_def s0_ptr_defs bit_simps)+ text \Page offset lemmas\ +declare pg_index_bits_def2[bit_simps] + lemma page_offs_min': - "is_aligned ptr 21 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pt_index) << 12)" + "is_aligned ptr 30 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pg_index) << 12)" + unfolding bit_simps apply (erule is_aligned_no_wrap') - apply (word_bitwise, auto) + apply (auto split: if_splits) + apply (rule ucast_less_shiftl_helper') + apply (auto simp: bit_simps)[2] done lemma page_offs_min: - "shared_page_ptr_virt \ shared_page_ptr_virt + (ucast (x:: pt_index) << 12)" + "shared_page_ptr_virt \ shared_page_ptr_virt + (ucast (x:: pg_index) << 12)" by (simp_all add: page_offs_min' s0_ptrs_aligned) +lemma pageBitsForSize_max_page_size[bit_simps]: + "pageBitsForSize max_page_size = (if config_ARM_PA_SIZE_BITS_40 then 21 else 30)" + by (auto simp: max_page_size_def bit_simps) + lemma page_offs_max': - "is_aligned ptr 21 \ (ptr :: obj_ref) + (ucast (x :: pt_index) << 12) \ ptr + 0x1FFFFF" + "is_aligned ptr 30 \ (ptr :: obj_ref) + (ucast (x :: pg_index) << 12) \ ptr + mask (pageBitsForSize max_page_size)" apply (rule word_plus_mono_right) apply (simp add: shiftl_t2n mult.commute) apply (rule div_to_mult_word_lt) - apply simp apply (rule plus_one_helper) - apply simp apply (cut_tac ucast_less[where x=x]) - apply simp - apply (fastforce elim: dual_order.strict_trans[rotated]) + apply (auto simp add: bit_simps mask_def split: if_splits)[2] + apply (drule_tac y="pageBitsForSize max_page_size" in is_aligned_weaken) + apply (simp add: bit_simps) apply (drule is_aligned_no_overflow) - apply (simp add: add.commute) + apply (simp add: mask_2pm1 p_assoc_help) done lemma page_offs_max: - "shared_page_ptr_virt + (ucast (x :: pt_index) << 12) \ shared_page_ptr_virt + 0x1FFFFF" + "shared_page_ptr_virt + (ucast (x :: pg_index) << 12) \ shared_page_ptr_virt + mask (pageBitsForSize max_page_size)" by (simp_all add: page_offs_max' s0_ptrs_aligned) + definition page_offs_range where - "page_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 21 - 1} + "page_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + mask (pageBitsForSize max_page_size)} \ {x. is_aligned x 12}" lemma page_offs_in_range': - "is_aligned ptr 21 \ ptr + (ucast (x :: pt_index) << 12) \ page_offs_range ptr" + "is_aligned ptr 30 \ ptr + (ucast (x :: pg_index) << 12) \ page_offs_range ptr" apply (clarsimp simp: page_offs_min' page_offs_max' page_offs_range_def add.commute) apply (rule is_aligned_add[OF _ is_aligned_shift]) apply (erule is_aligned_weaken) @@ -394,13 +429,13 @@ lemma page_offs_in_range': done lemma page_offs_in_range: - "shared_page_ptr_virt + (ucast (x :: pt_index) << 12) \ page_offs_range shared_page_ptr_virt" + "shared_page_ptr_virt + (ucast (x :: pg_index) << 12) \ page_offs_range shared_page_ptr_virt" by (simp_all add: page_offs_in_range' s0_ptrs_aligned) lemma page_offs_range_correct': - "\ x \ page_offs_range ptr; is_aligned ptr 21 \ - \ \y. x = ptr + (ucast (y :: pt_index) << 12)" - apply (clarsimp simp: page_offs_range_def s0_ptr_defs) + "\ x \ page_offs_range ptr; is_aligned ptr 30 \ + \ \y. x = ptr + (ucast (y :: pg_index) << 12)" + apply (clarsimp simp: page_offs_range_def s0_ptr_defs bit_simps) apply (rule_tac x="ucast ((x - ptr) >> 12)" in exI) apply (clarsimp simp: ucast_ucast_mask) apply (subst aligned_shiftr_mask_shiftl) @@ -409,8 +444,30 @@ lemma page_offs_range_correct': apply (erule is_aligned_weaken) apply simp apply simp - apply simp - apply (rule_tac n=21 in mask_eqI) + apply (simp add: bit_simps split: if_splits) + apply (drule is_aligned_weaken[where y=21], solves simp) + apply (rule_tac n=21 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + mask 21" and n=21 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=21 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + apply (rule_tac n=30 in mask_eqI) apply (subst mask_add_aligned) apply (simp add: is_aligned_def) apply (simp add: mask_twice) @@ -423,11 +480,10 @@ lemma page_offs_range_correct': apply (subst add_mask_lower_bits) apply (simp add: is_aligned_def) apply clarsimp - apply (cut_tac x=x and y="ptr + 0x1FFFFF" and n=21 in neg_mask_mono_le) - apply (simp add: add.commute) - apply (drule_tac n=21 in aligned_le_sharp) + apply (cut_tac x=x and y="ptr + mask 30" and n=30 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=30 in aligned_le_sharp) apply (simp add: is_aligned_def) - apply (simp add: add.commute) apply (subst(asm) mask_out_add_aligned[symmetric]) apply (erule is_aligned_weaken) apply simp @@ -436,7 +492,7 @@ lemma page_offs_range_correct': lemma page_offs_range_correct: "x \ page_offs_range shared_page_ptr_virt - \ \y. x = shared_page_ptr_virt + (ucast (y :: pt_index) << 12)" + \ \y. x = shared_page_ptr_virt + (ucast (y :: pg_index) << 12)" by (simp_all add: page_offs_range_correct' s0_ptrs_aligned) @@ -444,66 +500,122 @@ text \Page table offset lemmas\ lemma pt_offs_min': "is_aligned ptr 12 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pt_index) << 3)" + unfolding bit_simps + apply (erule is_aligned_no_wrap') + apply (rule ucast_less_shiftl_helper') + apply (auto simp: bit_simps) + done + +lemma vs_offs_min': + "is_aligned ptr 13 \ (ptr :: obj_ref) \ ptr + (ucast (x :: vs_index) << 3)" + unfolding bit_simps apply (erule is_aligned_no_wrap') - apply (word_bitwise, auto) + apply (auto split: if_splits) + apply (rule ucast_less_shiftl_helper') + apply (auto simp: bit_simps)[2] done lemma pt_offs_min: - "Low_pd_ptr \ Low_pd_ptr + (ucast (x :: pt_index) << 3)" - "High_pd_ptr \ High_pd_ptr + (ucast (x :: pt_index) << 3)" - "Low_pt_ptr \ Low_pt_ptr + (ucast (x :: pt_index) << 3)" - "High_pt_ptr \ High_pt_ptr + (ucast (x :: pt_index) << 3)" - "riscv_global_pt_ptr \ riscv_global_pt_ptr + (ucast (x :: pt_index) << 3)" - by (simp_all add: pt_offs_min' s0_ptrs_aligned) + "Low_pd_ptr \ Low_pd_ptr + (ucast (x :: vs_index) << 3)" + "High_pd_ptr \ High_pd_ptr + (ucast (x :: vs_index) << 3)" + "Low_pt_ptr \ Low_pt_ptr + (ucast (y :: pt_index) << 3)" + "High_pt_ptr \ High_pt_ptr + (ucast (y :: pt_index) << 3)" + "arm_global_pt_ptr \ arm_global_pt_ptr + (ucast (x :: vs_index) << 3)" + by (auto intro: pt_offs_min' vs_offs_min' s0_ptrs_aligned) lemma pt_offs_max': - "is_aligned ptr 12 \ (ptr :: obj_ref) + (ucast (x :: pt_index) << 3) \ ptr + 0xFFF" + assumes "is_aligned ptr 12" + shows "(ptr :: obj_ref) + (ucast (x :: pt_index) << 3) \ ptr + 0xFFF" apply (rule word_plus_mono_right) apply (simp add: shiftl_t2n mult.commute) apply (rule div_to_mult_word_lt) - apply simp + apply (simp add: bit_simps mask_def) apply (rule plus_one_helper) apply simp apply (cut_tac ucast_less[where x=x]) apply simp apply (fastforce elim: dual_order.strict_trans[rotated]) - apply (drule is_aligned_no_overflow) - apply (simp add: add.commute) + apply (insert is_aligned_no_overflow[OF assms]) + apply (auto simp add: add.commute bit_simps mask_def split: if_splits) + done + +lemma vs_offs_max': + assumes "is_aligned ptr (pt_bits VSRootPT_T)" + shows "(ptr :: obj_ref) + (ucast (x :: vs_index) << 3) \ ptr + mask (pt_bits VSRootPT_T)" + apply (rule word_plus_mono_right) + apply (simp add: shiftl_t2n mult.commute) + apply (rule div_to_mult_word_lt) + apply (auto simp add: bit_simps mask_def)[1] + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (simp add: bit_simps split: if_splits) + apply (simp add: bit_simps) + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (simp add: bit_simps split: if_splits) + apply (simp add: bit_simps) + apply (insert is_aligned_no_overflow[OF assms]) + apply (auto simp add: add.commute bit_simps mask_def split: if_splits) done lemma pt_offs_max: - "Low_pd_ptr + (ucast (x :: pt_index) << 3) \ Low_pd_ptr + 0xFFF" - "High_pd_ptr + (ucast (x :: pt_index) << 3) \ High_pd_ptr + 0xFFF" - "Low_pt_ptr + (ucast (x :: pt_index) << 3) \ Low_pt_ptr + 0xFFF" - "High_pt_ptr + (ucast (x :: pt_index) << 3) \ High_pt_ptr + 0xFFF" - "riscv_global_pt_ptr + (ucast (x :: pt_index) << 3) \ riscv_global_pt_ptr + 0xFFF" - by (simp_all add: pt_offs_max' s0_ptrs_aligned) + "Low_pd_ptr + (ucast (x :: vs_index) << 3) \ Low_pd_ptr + mask (pt_bits VSRootPT_T)" + "High_pd_ptr + (ucast (x :: vs_index) << 3) \ High_pd_ptr + mask (pt_bits VSRootPT_T)" + "Low_pt_ptr + (ucast (y :: pt_index) << 3) \ Low_pt_ptr + 0xFFF" + "High_pt_ptr + (ucast (y :: pt_index) << 3) \ High_pt_ptr + 0xFFF" + "arm_global_pt_ptr + (ucast (x :: vs_index) << 3) \ arm_global_pt_ptr + mask (pt_bits VSRootPT_T)" + by (rule pt_offs_max' vs_offs_max', rule s0_ptrs_aligned)+ definition pt_offs_range where - "pt_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 12 - 1} + "pt_offs_range (pt_t :: pt_type) (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ (pt_bits pt_t) - 1} \ {x. is_aligned x 3}" lemma pt_offs_in_range': "is_aligned ptr 12 - \ ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range ptr" - apply (clarsimp simp: pt_offs_min' pt_offs_max' pt_offs_range_def add.commute) + \ ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range NormalPT_T ptr" + apply (clarsimp simp: pt_offs_min' pt_offs_range_def add.commute) + apply (rule conjI) + apply (rule order.trans) + apply (erule pt_offs_max') + apply (simp add: bit_simps add_ac) apply (rule is_aligned_add[OF _ is_aligned_shift]) apply (erule is_aligned_weaken) - apply simp + apply (simp add: bit_simps) + done + +lemma vs_offs_in_range': + "is_aligned ptr 13 + \ ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T ptr" + apply (clarsimp simp: pt_offs_range_def vs_offs_min') + apply (rule conjI) + apply (rule order.trans) + apply (rule vs_offs_max') + apply (erule is_aligned_weaken) + apply (simp add: bit_simps) + apply (simp add: bit_simps add_ac mask_def) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (erule is_aligned_weaken) + apply (simp add: bit_simps) done lemma pt_offs_in_range: - "Low_pd_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range Low_pd_ptr" - "High_pd_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range High_pd_ptr" - "Low_pt_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range Low_pt_ptr" - "High_pt_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range High_pt_ptr" - "riscv_global_pt_ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range riscv_global_pt_ptr" - by (simp_all add: pt_offs_in_range' s0_ptrs_aligned) + "Low_pd_ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T Low_pd_ptr" + "High_pd_ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T High_pd_ptr" + "Low_pt_ptr + (ucast (y :: pt_index) << 3) \ pt_offs_range NormalPT_T Low_pt_ptr" + "High_pt_ptr + (ucast (y :: pt_index) << 3) \ pt_offs_range NormalPT_T High_pt_ptr" + "arm_global_pt_ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + by (simp_all add: pt_offs_in_range' vs_offs_in_range' s0_ptrs_aligned) + +lemma is_aligned_pt_bitsD: + "is_aligned ptr (pt_bits pt_t) \ is_aligned ptr 12" + by (erule is_aligned_weaken, simp add: bit_simps) lemma pt_offs_range_correct': - "\ x \ pt_offs_range ptr; is_aligned ptr 12 \ + "\ x \ pt_offs_range NormalPT_T ptr; is_aligned ptr 12 \ \ \y. x = ptr + (ucast (y :: pt_index) << 3)" - apply (clarsimp simp: pt_offs_range_def s0_ptr_defs) + apply (clarsimp simp: pt_offs_range_def s0_ptr_defs bit_simps) apply (rule_tac x="ucast ((x - ptr) >> 3)" in exI) apply (clarsimp simp: ucast_ucast_mask) apply (subst aligned_shiftr_mask_shiftl) @@ -527,10 +639,67 @@ lemma pt_offs_range_correct': apply (simp add: is_aligned_def) apply clarsimp apply (cut_tac x=x and y="ptr + 0xFFF" and n=12 in neg_mask_mono_le) - apply (simp add: add.commute) + apply (simp add: add_ac) + apply (drule_tac n=12 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma vs_offs_range_correct': + "\ x \ pt_offs_range VSRootPT_T ptr; is_aligned ptr 13 \ + \ \y. x = ptr + (ucast (y :: vs_index) << 3)" + apply (clarsimp simp: pt_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast ((x - ptr) >> 3)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply (simp add: bit_simps split: if_splits) + apply (rule_tac n=13 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0x1FFF" and n=13 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=13 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + apply (drule is_aligned_weaken[where y=12], solves simp) + apply (rule_tac n=12 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0xFFF" and n=12 in neg_mask_mono_le) + apply (simp add: add_ac) apply (drule_tac n=12 in aligned_le_sharp) apply (simp add: is_aligned_def) - apply (simp add: add.commute) apply (subst(asm) mask_out_add_aligned[symmetric]) apply (erule is_aligned_weaken) apply simp @@ -538,12 +707,12 @@ lemma pt_offs_range_correct': done lemma pt_offs_range_correct: - "x \ pt_offs_range Low_pd_ptr \ \y. x = Low_pd_ptr + (ucast (y :: pt_index) << 3)" - "x \ pt_offs_range High_pd_ptr \ \y. x = High_pd_ptr + (ucast (y :: pt_index) << 3)" - "x \ pt_offs_range Low_pt_ptr \ \y. x = Low_pt_ptr + (ucast (y :: pt_index) << 3)" - "x \ pt_offs_range High_pt_ptr \ \y. x = High_pt_ptr + (ucast (y :: pt_index) << 3)" - "x \ pt_offs_range riscv_global_pt_ptr \ \y. x = riscv_global_pt_ptr + (ucast (y :: pt_index) << 3)" - by (simp_all add: pt_offs_range_correct' s0_ptrs_aligned) + "x \ pt_offs_range VSRootPT_T Low_pd_ptr \ \y. x = Low_pd_ptr + (ucast (y :: vs_index) << 3)" + "x \ pt_offs_range VSRootPT_T High_pd_ptr \ \y. x = High_pd_ptr + (ucast (y :: vs_index) << 3)" + "x \ pt_offs_range NormalPT_T Low_pt_ptr \ \y. x = Low_pt_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range NormalPT_T High_pt_ptr \ \y. x = High_pt_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ \y. x = arm_global_pt_ptr + (ucast (y :: vs_index) << 3)" + by (simp_all add: pt_offs_range_correct' vs_offs_range_correct' s0_ptrs_aligned) text \CNode offset lemmas\ @@ -698,7 +867,7 @@ lemma cnode_offs_range_correct: text \TCB offset lemmas\ lemma tcb_offs_min': - "is_aligned ptr 10 \ (ptr :: obj_ref) \ ptr + ucast (x :: 10 word)" + "is_aligned ptr 11 \ (ptr :: obj_ref) \ ptr + ucast (x :: 11 word)" apply (erule is_aligned_no_wrap') apply (cut_tac x=x and 'a=64 in ucast_less) apply simp @@ -706,48 +875,48 @@ lemma tcb_offs_min': done lemma tcb_offs_min: - "Low_tcb_ptr \ Low_tcb_ptr + ucast (x :: 10 word)" - "High_tcb_ptr \ High_tcb_ptr + ucast (x :: 10 word)" - "idle_tcb_ptr \ idle_tcb_ptr + ucast (x :: 10 word)" + "Low_tcb_ptr \ Low_tcb_ptr + ucast (x :: 11 word)" + "High_tcb_ptr \ High_tcb_ptr + ucast (x :: 11 word)" + "idle_tcb_ptr \ idle_tcb_ptr + ucast (x :: 11 word)" by (simp_all add: tcb_offs_min' s0_ptrs_aligned) lemma tcb_offs_max': - "is_aligned ptr 10 \ (ptr :: obj_ref) + ucast (x :: 10 word) \ ptr + 0x3ff" + "is_aligned ptr 11 \ (ptr :: obj_ref) + ucast (x :: 11 word) \ ptr + 0x7FF" apply (rule word_plus_mono_right) apply (rule plus_one_helper) apply (cut_tac ucast_less[where x=x and 'a=64]) apply simp - apply simp + apply (simp add: mask_def) apply (drule is_aligned_no_overflow) apply (simp add: add.commute) done lemma tcb_offs_max: - "Low_tcb_ptr + ucast (x :: 10 word) \ Low_tcb_ptr + 0x3ff" - "High_tcb_ptr + ucast (x :: 10 word) \ High_tcb_ptr + 0x3ff" - "idle_tcb_ptr + ucast (x :: 10 word) \ idle_tcb_ptr + 0x3ff" + "Low_tcb_ptr + ucast (x :: 11 word) \ Low_tcb_ptr + 0x7FF" + "High_tcb_ptr + ucast (x :: 11 word) \ High_tcb_ptr + 0x7FF" + "idle_tcb_ptr + ucast (x :: 11 word) \ idle_tcb_ptr + 0x7FF" by (simp_all add: tcb_offs_max' s0_ptrs_aligned) definition tcb_offs_range where - "tcb_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 10 - 1}" + "tcb_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 0x7FF}" lemma tcb_offs_in_range': - "is_aligned ptr 10 \ ptr + ucast (x :: 10 word) \ tcb_offs_range ptr" + "is_aligned ptr 11 \ ptr + ucast (x :: 11 word) \ tcb_offs_range ptr" by (clarsimp simp: tcb_offs_min' tcb_offs_max' tcb_offs_range_def add.commute) lemma tcb_offs_in_range: - "Low_tcb_ptr + ucast (x :: 10 word) \ tcb_offs_range Low_tcb_ptr" - "High_tcb_ptr + ucast (x :: 10 word) \ tcb_offs_range High_tcb_ptr" - "idle_tcb_ptr + ucast (x :: 10 word) \ tcb_offs_range idle_tcb_ptr" + "Low_tcb_ptr + ucast (x :: 11 word) \ tcb_offs_range Low_tcb_ptr" + "High_tcb_ptr + ucast (x :: 11 word) \ tcb_offs_range High_tcb_ptr" + "idle_tcb_ptr + ucast (x :: 11 word) \ tcb_offs_range idle_tcb_ptr" by (simp_all add: tcb_offs_in_range' s0_ptrs_aligned) lemma tcb_offs_range_correct': - "\ x \ tcb_offs_range ptr; is_aligned ptr 10 \ - \ \y. x = ptr + ucast (y :: 10 word)" + "\ x \ tcb_offs_range ptr; is_aligned ptr 11 \ + \ \y. x = ptr + ucast (y :: 11 word)" apply (clarsimp simp: tcb_offs_range_def s0_ptr_defs) apply (rule_tac x="ucast (x - ptr)" in exI) apply (clarsimp simp: ucast_ucast_mask) - apply (rule_tac n=10 in mask_eqI) + apply (rule_tac n=11 in mask_eqI) apply (subst mask_add_aligned) apply (simp add: is_aligned_def) apply (simp add: mask_twice) @@ -760,11 +929,10 @@ lemma tcb_offs_range_correct': apply (subst add_mask_lower_bits) apply (simp add: is_aligned_def) apply clarsimp - apply (cut_tac x=x and y="ptr + 0x3FF" and n=10 in neg_mask_mono_le) - apply (simp add: add.commute) - apply (drule_tac n=10 in aligned_le_sharp) + apply (cut_tac x=x and y="ptr + 0x7FF" and n=11 in neg_mask_mono_le) + apply (simp add: mask_def) + apply (drule_tac n=11 in aligned_le_sharp) apply (simp add: is_aligned_def) - apply (simp add: add.commute) apply (subst(asm) mask_out_add_aligned[symmetric]) apply (erule is_aligned_weaken) apply simp @@ -772,9 +940,9 @@ lemma tcb_offs_range_correct': done lemma tcb_offs_range_correct: - "x \ tcb_offs_range Low_tcb_ptr \ \y. x = Low_tcb_ptr + ucast (y:: 10 word)" - "x \ tcb_offs_range High_tcb_ptr \ \y. x = High_tcb_ptr + ucast (y:: 10 word)" - "x \ tcb_offs_range idle_tcb_ptr \ \y. x = idle_tcb_ptr + ucast (y:: 10 word)" + "x \ tcb_offs_range Low_tcb_ptr \ \y. x = Low_tcb_ptr + ucast (y:: 11 word)" + "x \ tcb_offs_range High_tcb_ptr \ \y. x = High_tcb_ptr + ucast (y:: 11 word)" + "x \ tcb_offs_range idle_tcb_ptr \ \y. x = idle_tcb_ptr + ucast (y:: 11 word)" by (simp_all add: tcb_offs_range_correct' s0_ptrs_aligned) lemma caps_dom_length_10: @@ -797,7 +965,7 @@ lemmas kh0H_obj_def = global_ptH_def shared_pageH_def High_poolH_def Low_poolH_def lemmas kh0H_all_obj_def = - Low_pd'H_def High_pd'H_def Low_pt'H_def High_pt'H_def global_pteH_def global_pteH'_def + Low_pd'H_def High_pd'H_def Low_pt'H_def High_pt'H_def Low_cte'_def Low_capsH_def High_cte'_def High_capsH_def Silc_cte'_def Silc_capsH_def empty_cte_def kh0H_obj_def @@ -805,14 +973,26 @@ lemma not_in_range_None: "x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x = None" "x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x = None" "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x = None" - "x \ pt_offs_range Low_pd_ptr \ Low_pdH Low_pd_ptr x = None" - "x \ pt_offs_range High_pd_ptr \ High_pdH High_pd_ptr x = None" - "x \ pt_offs_range riscv_global_pt_ptr \ global_ptH riscv_global_pt_ptr x = None" - "x \ pt_offs_range Low_pt_ptr \ Low_ptH Low_pt_ptr x = None" - "x \ pt_offs_range High_pt_ptr \ High_ptH High_pt_ptr x = None" + "x \ pt_offs_range VSRootPT_T Low_pd_ptr \ Low_pdH Low_pd_ptr x = None" + "x \ pt_offs_range VSRootPT_T High_pd_ptr \ High_pdH High_pd_ptr x = None" + "x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ global_ptH arm_global_pt_ptr x = None" + "x \ pt_offs_range NormalPT_T Low_pt_ptr \ Low_ptH Low_pt_ptr x = None" + "x \ pt_offs_range NormalPT_T High_pt_ptr \ High_ptH High_pt_ptr x = None" "x \ page_offs_range shared_page_ptr_virt \ shared_pageH shared_page_ptr_virt x = None" by (auto simp: page_offs_range_def cnode_offs_range_def pt_offs_range_def s0_ptr_defs kh0H_obj_def) +lemma in_range_not_None: + "x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x \ None" + "x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x \ None" + "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x \ None" + "x \ pt_offs_range VSRootPT_T Low_pd_ptr \ Low_pdH Low_pd_ptr x \ None" + "x \ pt_offs_range VSRootPT_T High_pd_ptr \ High_pdH High_pd_ptr x \ None" + "x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ global_ptH arm_global_pt_ptr x \ None" + "x \ pt_offs_range NormalPT_T Low_pt_ptr \ Low_ptH Low_pt_ptr x \ None" + "x \ pt_offs_range NormalPT_T High_pt_ptr \ High_ptH High_pt_ptr x \ None" + "x \ page_offs_range shared_page_ptr_virt \ shared_pageH shared_page_ptr_virt x \ None" + by (auto simp: page_offs_range_def cnode_offs_range_def pt_offs_range_def s0_ptr_defs kh0H_all_obj_def) + lemma kh0H_dom_distinct: "idle_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" "High_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" @@ -835,41 +1015,41 @@ lemma kh0H_dom_distinct: "Low_pool_ptr \ cnode_offs_range High_cnode_ptr" "irq_cnode_ptr \ cnode_offs_range High_cnode_ptr" "ntfn_ptr \ cnode_offs_range High_cnode_ptr" - "idle_tcb_ptr \ pt_offs_range Low_pd_ptr" - "High_tcb_ptr \ pt_offs_range Low_pd_ptr" - "Low_tcb_ptr \ pt_offs_range Low_pd_ptr" - "High_pool_ptr \ pt_offs_range Low_pd_ptr" - "Low_pool_ptr \ pt_offs_range Low_pd_ptr" - "irq_cnode_ptr \ pt_offs_range Low_pd_ptr" - "ntfn_ptr \ pt_offs_range Low_pd_ptr" - "idle_tcb_ptr \ pt_offs_range High_pd_ptr" - "High_tcb_ptr \ pt_offs_range High_pd_ptr" - "Low_tcb_ptr \ pt_offs_range High_pd_ptr" - "High_pool_ptr \ pt_offs_range High_pd_ptr" - "Low_pool_ptr \ pt_offs_range High_pd_ptr" - "irq_cnode_ptr \ pt_offs_range High_pd_ptr" - "ntfn_ptr \ pt_offs_range High_pd_ptr" - "idle_tcb_ptr \ pt_offs_range riscv_global_pt_ptr" - "High_tcb_ptr \ pt_offs_range riscv_global_pt_ptr" - "Low_tcb_ptr \ pt_offs_range riscv_global_pt_ptr" - "High_pool_ptr \ pt_offs_range riscv_global_pt_ptr" - "Low_pool_ptr \ pt_offs_range riscv_global_pt_ptr" - "irq_cnode_ptr \ pt_offs_range riscv_global_pt_ptr" - "ntfn_ptr \ pt_offs_range riscv_global_pt_ptr" - "idle_tcb_ptr \ pt_offs_range Low_pt_ptr" - "High_tcb_ptr \ pt_offs_range Low_pt_ptr" - "Low_tcb_ptr \ pt_offs_range Low_pt_ptr" - "High_pool_ptr \ pt_offs_range Low_pt_ptr" - "Low_pool_ptr \ pt_offs_range Low_pt_ptr" - "irq_cnode_ptr \ pt_offs_range Low_pt_ptr" - "ntfn_ptr \ pt_offs_range Low_pt_ptr" - "idle_tcb_ptr \ pt_offs_range High_pt_ptr" - "High_tcb_ptr \ pt_offs_range High_pt_ptr" - "Low_tcb_ptr \ pt_offs_range High_pt_ptr" - "High_pool_ptr \ pt_offs_range High_pt_ptr" - "Low_pool_ptr \ pt_offs_range High_pt_ptr" - "irq_cnode_ptr \ pt_offs_range High_pt_ptr" - "ntfn_ptr \ pt_offs_range High_pt_ptr" + "idle_tcb_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "High_tcb_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "Low_tcb_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "High_pool_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "Low_pool_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "irq_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "ntfn_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "idle_tcb_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "High_tcb_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "Low_tcb_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "High_pool_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "Low_pool_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "irq_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "ntfn_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "idle_tcb_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "High_tcb_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "Low_tcb_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "High_pool_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "Low_pool_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "irq_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "ntfn_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "idle_tcb_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "High_tcb_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "Low_tcb_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "High_pool_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "Low_pool_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "irq_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "ntfn_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "idle_tcb_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "High_tcb_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "Low_tcb_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "High_pool_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "Low_pool_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "irq_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "ntfn_ptr \ pt_offs_range NormalPT_T High_pt_ptr" "idle_tcb_ptr \ tcb_offs_range Low_tcb_ptr" "High_tcb_ptr \ tcb_offs_range Low_tcb_ptr" "High_pool_ptr \ tcb_offs_range Low_tcb_ptr" @@ -895,82 +1075,100 @@ lemma kh0H_dom_distinct: "Low_pool_ptr \ page_offs_range shared_page_ptr_virt" "irq_cnode_ptr \ page_offs_range shared_page_ptr_virt" "ntfn_ptr \ page_offs_range shared_page_ptr_virt" + "idle_tcb_ptr \ cnode_offs_range init_irq_node_ptr" + "High_tcb_ptr \ cnode_offs_range init_irq_node_ptr" + "Low_tcb_ptr \ cnode_offs_range init_irq_node_ptr" + "High_pool_ptr \ cnode_offs_range init_irq_node_ptr" + "Low_pool_ptr \ cnode_offs_range init_irq_node_ptr" + "irq_cnode_ptr \ cnode_offs_range init_irq_node_ptr" + "ntfn_ptr \ cnode_offs_range init_irq_node_ptr" by (auto simp: tcb_offs_range_def pt_offs_range_def page_offs_range_def - cnode_offs_range_def kh0H_obj_def s0_ptr_defs) + cnode_offs_range_def kh0H_obj_def s0_ptr_defs bit_simps) lemma kh0H_dom_sets_distinct: "irq_node_offs_range \ cnode_offs_range Silc_cnode_ptr = {}" "irq_node_offs_range \ cnode_offs_range High_cnode_ptr = {}" "irq_node_offs_range \ cnode_offs_range Low_cnode_ptr = {}" - "irq_node_offs_range \ pt_offs_range riscv_global_pt_ptr = {}" - "irq_node_offs_range \ pt_offs_range High_pd_ptr = {}" - "irq_node_offs_range \ pt_offs_range Low_pd_ptr = {}" - "irq_node_offs_range \ pt_offs_range High_pt_ptr = {}" - "irq_node_offs_range \ pt_offs_range Low_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "irq_node_offs_range \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "irq_node_offs_range \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range NormalPT_T Low_pt_ptr = {}" "irq_node_offs_range \ tcb_offs_range High_tcb_ptr = {}" "irq_node_offs_range \ tcb_offs_range Low_tcb_ptr = {}" "irq_node_offs_range \ tcb_offs_range idle_tcb_ptr = {}" "irq_node_offs_range \ page_offs_range shared_page_ptr_virt = {}" "cnode_offs_range Silc_cnode_ptr \ cnode_offs_range High_cnode_ptr = {}" "cnode_offs_range Silc_cnode_ptr \ cnode_offs_range Low_cnode_ptr = {}" - "cnode_offs_range Silc_cnode_ptr \ pt_offs_range riscv_global_pt_ptr = {}" - "cnode_offs_range Silc_cnode_ptr \ pt_offs_range High_pd_ptr = {}" - "cnode_offs_range Silc_cnode_ptr \ pt_offs_range Low_pd_ptr = {}" - "cnode_offs_range Silc_cnode_ptr \ pt_offs_range High_pt_ptr = {}" - "cnode_offs_range Silc_cnode_ptr \ pt_offs_range Low_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" "cnode_offs_range Silc_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" "cnode_offs_range High_cnode_ptr \ cnode_offs_range Low_cnode_ptr = {}" - "cnode_offs_range High_cnode_ptr \ pt_offs_range riscv_global_pt_ptr = {}" - "cnode_offs_range High_cnode_ptr \ pt_offs_range High_pd_ptr = {}" - "cnode_offs_range High_cnode_ptr \ pt_offs_range Low_pd_ptr = {}" - "cnode_offs_range High_cnode_ptr \ pt_offs_range High_pt_ptr = {}" - "cnode_offs_range High_cnode_ptr \ pt_offs_range Low_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" "cnode_offs_range High_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" "cnode_offs_range High_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" "cnode_offs_range High_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" "cnode_offs_range High_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" - "cnode_offs_range Low_cnode_ptr \ pt_offs_range riscv_global_pt_ptr = {}" - "cnode_offs_range Low_cnode_ptr \ pt_offs_range High_pd_ptr = {}" - "cnode_offs_range Low_cnode_ptr \ pt_offs_range Low_pd_ptr = {}" - "cnode_offs_range Low_cnode_ptr \ pt_offs_range High_pt_ptr = {}" - "cnode_offs_range Low_cnode_ptr \ pt_offs_range Low_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" "cnode_offs_range Low_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" "cnode_offs_range Low_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" "cnode_offs_range Low_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" "cnode_offs_range Low_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" - "pt_offs_range riscv_global_pt_ptr \ pt_offs_range High_pd_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ pt_offs_range Low_pd_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ pt_offs_range High_pt_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ pt_offs_range Low_pt_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" - "pt_offs_range riscv_global_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" - "pt_offs_range High_pd_ptr \ pt_offs_range Low_pd_ptr = {}" - "pt_offs_range High_pd_ptr \ pt_offs_range High_pt_ptr = {}" - "pt_offs_range High_pd_ptr \ pt_offs_range Low_pt_ptr = {}" - "pt_offs_range High_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" - "pt_offs_range High_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" - "pt_offs_range High_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" - "pt_offs_range High_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" - "pt_offs_range Low_pd_ptr \ pt_offs_range High_pt_ptr = {}" - "pt_offs_range Low_pd_ptr \ pt_offs_range Low_pt_ptr = {}" - "pt_offs_range Low_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" - "pt_offs_range Low_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" - "pt_offs_range Low_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" - "pt_offs_range Low_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" - "pt_offs_range High_pt_ptr \ pt_offs_range Low_pt_ptr = {}" - "pt_offs_range High_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" - "pt_offs_range High_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" - "pt_offs_range High_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" - "pt_offs_range High_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" - "pt_offs_range Low_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" - "pt_offs_range Low_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" - "pt_offs_range Low_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" - "pt_offs_range Low_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range init_irq_node_ptr \ cnode_offs_range High_cnode_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ cnode_offs_range Low_cnode_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" "tcb_offs_range High_tcb_ptr \ tcb_offs_range Low_tcb_ptr = {}" "tcb_offs_range High_tcb_ptr \ tcb_offs_range idle_tcb_ptr = {}" "tcb_offs_range High_tcb_ptr \ page_offs_range shared_page_ptr_virt = {}" @@ -978,8 +1176,8 @@ lemma kh0H_dom_sets_distinct: "tcb_offs_range Low_tcb_ptr \ page_offs_range shared_page_ptr_virt = {}" "page_offs_range shared_page_ptr_virt \ tcb_offs_range idle_tcb_ptr = {}" by (rule disjointI, clarsimp simp: tcb_offs_range_def pt_offs_range_def page_offs_range_def - irq_node_offs_range_def cnode_offs_range_def s0_ptr_defs - , drule (1) order_trans le_less_trans, fastforce)+ + irq_node_offs_range_def cnode_offs_range_def s0_ptr_defs bit_simps + , drule (1) order_trans le_less_trans, fastforce split: if_splits)+ lemmas offs_in_range = pt_offs_in_range page_offs_in_range tcb_offs_in_range cnode_offs_in_range irq_node_offs_in_range @@ -990,6 +1188,8 @@ lemmas offs_range_correct = lemma kh0H_dom_distinct': fixes y :: pt_index + and v :: vs_index + and z :: "pg_index" shows "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" @@ -1012,20 +1212,20 @@ lemma kh0H_dom_distinct': "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" - "Low_pd_ptr + (ucast y << 3) \ idle_tcb_ptr" - "Low_pd_ptr + (ucast y << 3) \ High_tcb_ptr" - "Low_pd_ptr + (ucast y << 3) \ Low_tcb_ptr" - "Low_pd_ptr + (ucast y << 3) \ High_pool_ptr" - "Low_pd_ptr + (ucast y << 3) \ Low_pool_ptr" - "Low_pd_ptr + (ucast y << 3) \ irq_cnode_ptr" - "Low_pd_ptr + (ucast y << 3) \ ntfn_ptr" - "High_pd_ptr + (ucast y << 3) \ idle_tcb_ptr" - "High_pd_ptr + (ucast y << 3) \ High_tcb_ptr" - "High_pd_ptr + (ucast y << 3) \ Low_tcb_ptr" - "High_pd_ptr + (ucast y << 3) \ High_pool_ptr" - "High_pd_ptr + (ucast y << 3) \ Low_pool_ptr" - "High_pd_ptr + (ucast y << 3) \ irq_cnode_ptr" - "High_pd_ptr + (ucast y << 3) \ ntfn_ptr" + "Low_pd_ptr + (ucast v << 3) \ idle_tcb_ptr" + "Low_pd_ptr + (ucast v << 3) \ High_tcb_ptr" + "Low_pd_ptr + (ucast v << 3) \ Low_tcb_ptr" + "Low_pd_ptr + (ucast v << 3) \ High_pool_ptr" + "Low_pd_ptr + (ucast v << 3) \ Low_pool_ptr" + "Low_pd_ptr + (ucast v << 3) \ irq_cnode_ptr" + "Low_pd_ptr + (ucast v << 3) \ ntfn_ptr" + "High_pd_ptr + (ucast v << 3) \ idle_tcb_ptr" + "High_pd_ptr + (ucast v << 3) \ High_tcb_ptr" + "High_pd_ptr + (ucast v << 3) \ Low_tcb_ptr" + "High_pd_ptr + (ucast v << 3) \ High_pool_ptr" + "High_pd_ptr + (ucast v << 3) \ Low_pool_ptr" + "High_pd_ptr + (ucast v << 3) \ irq_cnode_ptr" + "High_pd_ptr + (ucast v << 3) \ ntfn_ptr" "Low_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" "Low_pt_ptr + (ucast y << 3) \ High_tcb_ptr" "Low_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" @@ -1040,27 +1240,27 @@ lemma kh0H_dom_distinct': "High_pt_ptr + (ucast y << 3) \ Low_pool_ptr" "High_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" "High_pt_ptr + (ucast y << 3) \ ntfn_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ High_tcb_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ High_pool_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ Low_pool_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" - "riscv_global_pt_ptr + (ucast y << 3) \ ntfn_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ idle_tcb_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ High_tcb_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ Low_tcb_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ High_pool_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ Low_pool_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ irq_cnode_ptr" - "shared_page_ptr_virt + (ucast y << 12) \ ntfn_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ idle_tcb_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ High_tcb_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ Low_tcb_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ High_pool_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ Low_pool_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ irq_cnode_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ ntfn_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ idle_tcb_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ High_tcb_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ Low_tcb_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ High_pool_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ Low_pool_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ irq_cnode_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ ntfn_ptr" apply (drule offs_in_range, fastforce simp: kh0H_dom_distinct)+ - apply (cut_tac x=y in offs_in_range(1), fastforce simp: kh0H_dom_distinct)+ - apply (cut_tac x=y in offs_in_range(2), fastforce simp: kh0H_dom_distinct)+ - apply (cut_tac x=y in offs_in_range(3), fastforce simp: kh0H_dom_distinct)+ - apply (cut_tac x=y in offs_in_range(4), fastforce simp: kh0H_dom_distinct)+ - apply (cut_tac x=y in offs_in_range(5), fastforce simp: kh0H_dom_distinct)+ - apply (cut_tac x=y in offs_in_range(6), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=v in offs_in_range(1), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=v in offs_in_range(2), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac y=y in offs_in_range(3), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac y=y in offs_in_range(4), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=v in offs_in_range(5), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=z in offs_in_range(6), fastforce simp: kh0H_dom_distinct)+ done lemma not_disjointI: @@ -1068,15 +1268,17 @@ lemma not_disjointI: by fastforce lemma shared_pageH_KOUserData[simp]: - "shared_pageH shared_page_ptr_virt (shared_page_ptr_virt + (UCAST(9 \ 64) y << 12)) = Some KOUserData" + "shared_pageH shared_page_ptr_virt (shared_page_ptr_virt + (UCAST(pg_index_len \ 64) y << 12)) = Some KOUserData" apply (clarsimp simp: shared_pageH_def page_offs_min page_offs_max add.commute) - apply (cut_tac shared_page_ptr_is_aligned) - apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs bit_simps) - apply word_bitwise + apply (rule is_aligned_add) + apply (rule is_aligned_weaken, rule s0_ptrs_aligned, simp) + apply (clarsimp simp: is_aligned_mask) done lemma kh0H_simps[simp]: fixes y :: pt_index + and v :: vs_index + and z :: "pg_index" shows "kh0H (init_irq_node_ptr + (ucast (irq :: irq) << 5)) = Some (KOCTE (CTE NullCap Null_mdb))" "kh0H ntfn_ptr = Some (KONotification ntfnH)" @@ -1089,16 +1291,16 @@ lemma kh0H_simps[simp]: "length x = 10 \ kh0H (Low_cnode_ptr + of_bl x * 0x20) = Low_cte Low_cnode_ptr (Low_cnode_ptr + of_bl x * 0x20)" "length x = 10 \ kh0H (High_cnode_ptr + of_bl x * 0x20) = High_cte High_cnode_ptr (High_cnode_ptr + of_bl x * 0x20)" "length x = 10 \ kh0H (Silc_cnode_ptr + of_bl x * 0x20) = Silc_cte Silc_cnode_ptr (Silc_cnode_ptr + of_bl x * 0x20)" - "kh0H (Low_pd_ptr + (ucast y << 3)) = Low_pdH Low_pd_ptr (Low_pd_ptr + (ucast y << 3))" - "kh0H (High_pd_ptr + (ucast y << 3)) = High_pdH High_pd_ptr (High_pd_ptr + (ucast y << 3))" + "kh0H (Low_pd_ptr + (ucast v << 3)) = Low_pdH Low_pd_ptr (Low_pd_ptr + (ucast v << 3))" + "kh0H (High_pd_ptr + (ucast v << 3)) = High_pdH High_pd_ptr (High_pd_ptr + (ucast v << 3))" "kh0H (Low_pt_ptr + (ucast y << 3)) = Low_ptH Low_pt_ptr (Low_pt_ptr + (ucast y << 3))" "kh0H (High_pt_ptr + (ucast y << 3)) = High_ptH High_pt_ptr (High_pt_ptr + (ucast y << 3))" - "kh0H (riscv_global_pt_ptr + (ucast y << 3)) = global_ptH riscv_global_pt_ptr (riscv_global_pt_ptr + (ucast y << 3))" - "kh0H (shared_page_ptr_virt + (ucast y << 12)) = Some KOUserData" + "kh0H (arm_global_pt_ptr + (ucast v << 3)) = global_ptH arm_global_pt_ptr (arm_global_pt_ptr + (ucast v << 3))" + "kh0H (shared_page_ptr_virt + (ucast z << 12)) = Some KOUserData" supply option.case_cong[cong] apply (fastforce simp: kh0H_def option_update_range_def) by ((clarsimp simp: kh0H_def kh0H_dom_distinct kh0H_dom_distinct' - option_update_range_def not_in_range_None offs_in_range + option_update_range_def not_in_range_None offs_in_range | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_None | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_None | rule conjI | clarsimp split: option.splits)+, @@ -1115,11 +1317,11 @@ lemma kh0H_dom: cnode_offs_range Silc_cnode_ptr \ cnode_offs_range High_cnode_ptr \ cnode_offs_range Low_cnode_ptr \ - pt_offs_range riscv_global_pt_ptr \ - pt_offs_range High_pd_ptr \ - pt_offs_range Low_pd_ptr \ - pt_offs_range High_pt_ptr \ - pt_offs_range Low_pt_ptr" + pt_offs_range VSRootPT_T arm_global_pt_ptr \ + pt_offs_range VSRootPT_T High_pd_ptr \ + pt_offs_range VSRootPT_T Low_pd_ptr \ + pt_offs_range NormalPT_T High_pt_ptr \ + pt_offs_range NormalPT_T Low_pt_ptr" apply (rule equalityI) apply (simp add: kh0H_def dom_def) apply (clarsimp simp: offs_in_range option_update_range_def not_in_range_None split: if_split_asm) @@ -1127,12 +1329,9 @@ lemma kh0H_dom: apply (rule conjI) apply (force simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None dest: irq_node_offs_range_correct split: option.splits) - by (rule conjI - | clarsimp simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None - split: option.splits - , frule offs_range_correct - , clarsimp simp: kh0H_all_obj_def cnode_offs_range_def page_offs_range_def pt_offs_range_def - split: if_split_asm)+ + apply (intro conjI) + by (auto simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None in_range_not_None + split: option.splits) lemmas kh0H_SomeD' = set_mp[OF equalityD1[OF kh0H_dom[simplified dom_def]], OF CollectI, simplified, OF exI] @@ -1142,13 +1341,13 @@ lemma kh0H_SomeD: x = Low_tcb_ptr \ y = KOTCB Low_tcbH \ x = High_tcb_ptr \ y = KOTCB High_tcbH \ x = idle_tcb_ptr \ y = KOTCB idle_tcbH \ - x \ pt_offs_range riscv_global_pt_ptr \ global_ptH riscv_global_pt_ptr x \ None - \ y = the (global_ptH riscv_global_pt_ptr x) \ + x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ global_ptH arm_global_pt_ptr x \ None + \ y = the (global_ptH arm_global_pt_ptr x) \ x \ irq_node_offs_range \ y = KOCTE (CTE NullCap Null_mdb) \ - x \ pt_offs_range Low_pt_ptr \ Low_ptH Low_pt_ptr x \ None \ y = the (Low_ptH Low_pt_ptr x) \ - x \ pt_offs_range High_pt_ptr \ High_ptH High_pt_ptr x \ None \ y = the (High_ptH High_pt_ptr x) \ - x \ pt_offs_range Low_pd_ptr \ Low_pdH Low_pd_ptr x \ None \ y = the (Low_pdH Low_pd_ptr x) \ - x \ pt_offs_range High_pd_ptr \ High_pdH High_pd_ptr x \ None \ y = the (High_pdH High_pd_ptr x) \ + x \ pt_offs_range NormalPT_T Low_pt_ptr \ Low_ptH Low_pt_ptr x \ None \ y = the (Low_ptH Low_pt_ptr x) \ + x \ pt_offs_range NormalPT_T High_pt_ptr \ High_ptH High_pt_ptr x \ None \ y = the (High_ptH High_pt_ptr x) \ + x \ pt_offs_range VSRootPT_T Low_pd_ptr \ Low_pdH Low_pd_ptr x \ None \ y = the (Low_pdH Low_pd_ptr x) \ + x \ pt_offs_range VSRootPT_T High_pd_ptr \ High_pdH High_pd_ptr x \ None \ y = the (High_pdH High_pd_ptr x) \ x = Low_pool_ptr \ y = KOArch Low_poolH \ x = High_pool_ptr \ y = KOArch High_poolH \ x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x \ None \ y = the (Low_cte Low_cnode_ptr x) \ @@ -1158,20 +1357,29 @@ lemma kh0H_SomeD: x \ page_offs_range shared_page_ptr_virt \ y = KOUserData" apply (frule kh0H_SomeD') apply (elim disjE) - by ((clarsimp | drule offs_range_correct)+) - + by (clarsimp | drule offs_range_correct)+ definition arch_state0H :: Arch.kernel_state where - "arch_state0H \ - RISCVKernelState [ucast (asid_high_bits_of Low_asid) \ Low_pool_ptr, - ucast (asid_high_bits_of High_asid) \ High_pool_ptr] - (\level. if level = maxPTLevel then [riscv_global_pt_ptr] else []) - init_vspace_uses" + "arch_state0H \ ARMKernelState + \ \armKSASIDTable =\ [ucast (asid_high_bits_of Low_asid) \ Low_pool_ptr, + ucast (asid_high_bits_of High_asid) \ High_pool_ptr] + \ \armKSKernelVSpace =\ Example_Valid_State.init_vspace_uses + \ \armKSVMIDTable =\ Map.empty + \ \armKSNextVMID =\ 0 + \ \armKSGlobalUserVSpace =\ arm_global_pt_ptr + \ \armHSCurVCPU =\ None + \ \armKSGICVCPUNumListRegs =\ (max_armKSGICVCPUNumListRegs - 1) + \ \gsPTTypes =\ [Low_pt_ptr \ NormalPT_T, + High_pt_ptr \ NormalPT_T, + Low_pd_ptr \ VSRootPT_T, + High_pd_ptr \ VSRootPT_T, + arm_global_pt_ptr \ VSRootPT_T] + \ \armKSGlobalPTs =\ None" definition s0H_internal :: "kernel_state" where "s0H_internal \ \ ksPSpace = kh0H, - gsUserPages = [shared_page_ptr_virt \ RISCVLargePage], + gsUserPages = [shared_page_ptr_virt \ max_page_size], gsCNodes = (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x then Some 0 else None) (Low_cnode_ptr \ 10, @@ -1181,10 +1389,11 @@ definition s0H_internal :: "kernel_state" where gsUntypedZeroRanges = ran (map_comp untypedZeroRange (option_map cteCap o map_to_ctes kh0H)), gsMaxObjectSize = card (UNIV :: obj_ref set), ksDomScheduleIdx = 0, - ksDomSchedule = [(0, 10), (1, 10)], + ksDomScheduleStart = 0, + ksDomSchedule = [(0, 10), (1, 10), (0, 0)], ksCurDomain = 0, ksDomainTime = 5, - ksReadyQueues = const (TcbQueue None None), + ksReadyQueues = const emptyQueue, ksReadyQueuesL1Bitmap = const 0, ksReadyQueuesL2Bitmap = const 0, ksCurThread = Low_tcb_ptr, @@ -1195,7 +1404,6 @@ definition s0H_internal :: "kernel_state" where ksArchState = arch_state0H, ksMachineState = machine_state0\" - definition Low_cte_cte :: "obj_ref \ obj_ref \ cte option" where "Low_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 then Low_cte' (ucast (offs - base >> 5)) else None" @@ -1234,11 +1442,23 @@ lemma not_in_range_cte_None: "x \ cnode_offs_range Low_cnode_ptr \ Low_cte_cte Low_cnode_ptr x = None" "x \ cnode_offs_range High_cnode_ptr \ High_cte_cte High_cnode_ptr x = None" "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte_cte Silc_cnode_ptr x = None" + "x \ cnode_offs_range init_irq_node_ptr \ \irq. x \ init_irq_node_ptr + (UCAST(9 \ 64) irq << 5)" "x \ tcb_offs_range Low_tcb_ptr \ Low_tcb_cte x = None" "x \ tcb_offs_range High_tcb_ptr \ High_tcb_cte x = None" "x \ tcb_offs_range idle_tcb_ptr \ idle_tcb_cte x = None" - by (fastforce simp: cnode_offs_range_def page_offs_range_def tcb_offs_range_def s0_ptr_defs Low_cte_cte_def - High_cte_cte_def Silc_cte_cte_def Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def)+ + apply (clarsimp simp: cnode_offs_range_def page_offs_range_def tcb_offs_range_def s0_ptr_defs Low_cte_cte_def + High_cte_cte_def Silc_cte_cte_def Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def mask_def)+ + apply safe + apply word_bitwise + apply word_bitwise + apply (erule swap) + apply clarsimp + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_def) + apply (rule is_aligned_shift) + apply (auto simp: cnode_offs_range_def page_offs_range_def tcb_offs_range_def s0_ptr_defs Low_cte_cte_def + High_cte_cte_def Silc_cte_cte_def Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def mask_def) + done lemma mask_neg_le: "x && ~~ mask n \ x" @@ -1247,9 +1467,9 @@ lemma mask_neg_le: done lemma mask_in_tcb_offs_range: - "x && ~~ mask 10 = ptr \ x \ tcb_offs_range ptr" - apply (clarsimp simp: tcb_offs_range_def mask_neg_le objBitsKO_def) - apply (cut_tac and_neg_mask_plus_mask_mono[where p=x and n=10]) + "x && ~~ mask 11 = ptr \ x \ tcb_offs_range ptr" + apply (clarsimp simp: tcb_offs_range_def word_and_le2 objBitsKO_def) + apply (cut_tac and_neg_mask_plus_mask_mono[where p=x and n=11]) apply (simp add: add.commute mask_def) done @@ -1266,7 +1486,7 @@ lemma opt_None_not_dom: by (simp add: dom_def) lemma tcb_offs_range_mask_eq: - "\ x \ tcb_offs_range ptr; is_aligned ptr 10 \ \ x && ~~ mask 10 = ptr" + "\ x \ tcb_offs_range ptr; is_aligned ptr 11 \ \ x && ~~ mask 11 = ptr" apply (drule(1) tcb_offs_range_correct') apply (clarsimp simp: objBitsKO_def) apply (drule_tac d="ucast y" in is_aligned_add_helper) @@ -1277,27 +1497,29 @@ lemma tcb_offs_range_mask_eq: done lemma not_in_tcb_offs: - "\tcb. kh0H (x && ~~ mask 10) \ Some (KOTCB tcb) + "\tcb. kh0H (x && ~~ mask 11) \ Some (KOTCB tcb) \ x \ tcb_offs_range Low_tcb_ptr" - "\tcb. kh0H (x && ~~ mask 10) \ Some (KOTCB tcb) + "\tcb. kh0H (x && ~~ mask 11) \ Some (KOTCB tcb) \ x \ tcb_offs_range High_tcb_ptr" - "\tcb. kh0H (x && ~~ mask 10) \ Some (KOTCB tcb) + "\tcb. kh0H (x && ~~ mask 11) \ Some (KOTCB tcb) \ x \ tcb_offs_range idle_tcb_ptr" by (fastforce simp: s0_ptrs_aligned dest: tcb_offs_range_mask_eq)+ lemma range_tcb_not_kh0H_dom: - "{(x && ~~ mask 10) + 1..(x && ~~ mask 10) + 2 ^ 10 - 1} \ dom kh0H \ {} \ (x && ~~ mask 10) \ High_tcb_ptr" - "{(x && ~~ mask 10) + 1..(x && ~~ mask 10) + 2 ^ 10 - 1} \ dom kh0H \ {} \ (x && ~~ mask 10) \ Low_tcb_ptr" - "{(x && ~~ mask 10) + 1..(x && ~~ mask 10) + 2 ^ 10 - 1} \ dom kh0H \ {} \ (x && ~~ mask 10) \ idle_tcb_ptr" + "{(x && ~~ mask 11) + 1..(x && ~~ mask 11) + 2 ^ 11 - 1} \ dom kh0H \ {} \ (x && ~~ mask 11) \ High_tcb_ptr" + "{(x && ~~ mask 11) + 1..(x && ~~ mask 11) + 2 ^ 11 - 1} \ dom kh0H \ {} \ (x && ~~ mask 11) \ Low_tcb_ptr" + "{(x && ~~ mask 11) + 1..(x && ~~ mask 11) + 2 ^ 11 - 1} \ dom kh0H \ {} \ (x && ~~ mask 11) \ idle_tcb_ptr" apply clarsimp apply (drule int_not_emptyD) apply (clarsimp simp: kh0H_dom) apply (subgoal_tac "xa \ tcb_offs_range High_tcb_ptr") prefer 2 apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) - apply (rule_tac y="High_tcb_ptr + 1" in order_trans) + apply (rule conjI) + apply (erule dual_order.trans) apply (simp add: s0_ptr_defs) - apply simp + apply (erule order.trans) + apply (simp add: s0_ptr_defs mask_def) apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] @@ -1308,9 +1530,11 @@ lemma range_tcb_not_kh0H_dom: apply (subgoal_tac "xa \ tcb_offs_range Low_tcb_ptr") prefer 2 apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) - apply (rule_tac y="Low_tcb_ptr + 1" in order_trans) + apply (rule conjI) + apply (erule dual_order.trans) apply (simp add: s0_ptr_defs) - apply simp + apply (erule order.trans) + apply (simp add: s0_ptr_defs mask_def) apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] @@ -1321,9 +1545,11 @@ lemma range_tcb_not_kh0H_dom: apply (subgoal_tac "xa \ tcb_offs_range idle_tcb_ptr") prefer 2 apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) - apply (rule_tac y="idle_tcb_ptr + 1" in order_trans) + apply (rule conjI) + apply (erule dual_order.trans) apply (simp add: s0_ptr_defs) - apply simp + apply (erule order.trans) + apply (simp add: s0_ptr_defs mask_def) apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] @@ -1338,6 +1564,14 @@ lemma kh0H_dom_tcb: apply (elim disjE) by (auto dest: offs_range_correct simp: kh0H_all_obj_def s0_ptrs_aligned split: if_split_asm) +lemma vs_index_bits_less_word_len[simp]: + "vs_index_bits < 64" + by (auto simp: bit_simps) + +lemma vs_index_bits_pt_bits: + "vs_index_bits + 3 = pt_bits VSRootPT_T" + by (simp add: bit_simps) + lemma map_to_ctes_kh0H: "map_to_ctes kh0H = (option_update_range @@ -1370,8 +1604,8 @@ lemma map_to_ctes_kh0H: apply (clarsimp split: option.splits) apply (rule conjI) apply (fastforce simp: tcb_cte_cases_def Low_tcb_cte_def dest: neg_mask_decompose) - subgoal by (fastforce simp: Low_tcb_cte_def tcb_cte_cases_def - split: if_split_asm dest: neg_mask_decompose) + subgoal by (fastforce simp: Low_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) apply (clarsimp simp: option_update_range_def) apply (frule mask_in_tcb_offs_range) apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) @@ -1382,8 +1616,8 @@ lemma map_to_ctes_kh0H: apply (clarsimp split: option.splits) apply (rule conjI) apply (fastforce simp: tcb_cte_cases_def High_tcb_cte_def dest: neg_mask_decompose) - subgoal by (fastforce simp: High_tcb_cte_def tcb_cte_cases_def - split: if_split_asm dest: neg_mask_decompose) + subgoal by (fastforce simp: High_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) apply (clarsimp simp: option_update_range_def) apply (frule mask_in_tcb_offs_range) apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) @@ -1394,8 +1628,8 @@ lemma map_to_ctes_kh0H: apply (clarsimp split: option.splits) apply (rule conjI) apply (fastforce simp: tcb_cte_cases_def idle_tcb_cte_def dest: neg_mask_decompose) - subgoal by (fastforce simp: idle_tcb_cte_def tcb_cte_cases_def - split: if_split_asm dest: neg_mask_decompose) + subgoal by (fastforce simp: idle_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) apply (drule_tac m="kh0H" in opt_None_not_dom) apply (rule conjI) apply (clarsimp simp: kh0H_dom option_update_range_def) @@ -1430,18 +1664,20 @@ lemma map_to_ctes_kh0H: defer 2 apply ((clarsimp simp: map_to_ctes_def Let_def split del: if_split, subst if_split_eq1, rule conjI, rule impI, drule pt_offs_range_correct, - clarsimp simp: kh0H_obj_def kh0H_dom_distinct option_update_range_def not_in_range_cte_None, + clarsimp simp: kh0H_obj_def kh0H_dom_distinct option_update_range_def not_in_range_cte_None split: if_split_asm, rule impI, subst if_split_eq1, rule conjI, rule impI, rule FalseE, - drule pt_offs_range_correct, clarsimp, cut_tac x=ya and 'a=64 in ucast_less, - simp, drule shiftl_less_t2n'[where n=3], simp, simp, - drule plus_one_helper[where n="0xFFF", simplified], drule kh0H_dom_tcb, + drule pt_offs_range_correct, clarsimp, cut_tac x=ya and 'a=64 in ucast_less, simp add: bit_simps, + drule shiftl_less_t2n'[where n=3], simp add: bit_simps, simp, + drule plus_one_helper[where n="2 ^ (vs_index_bits + 3) - 1", simplified] + plus_one_helper[where n="0xFFF", simplified], + drule kh0H_dom_tcb, (elim disjE, (clarsimp simp: s0_ptr_defs objBitsKO_def, erule notE[rotated], rule_tac a="x::obj_ref" for x in dual_order.strict_implies_not_eq, rule less_le_trans[rotated, OF aligned_le_sharp], - erule word_plus_mono_right2[rotated], - simp, simp add: is_aligned_def, simp)+)[1], - rule impI, + rule word_plus_mono_right2[rotated], simp add: order_less_imp_le, + simp add: bit_simps, simp add: is_aligned_def, simp)+)[1], + rule impI, clarsimp simp: option_update_range_def kh0H_dom_distinct[THEN set_mem_neq] not_in_range_cte_None, ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None irq_node_offs_in_range | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1])+)[5] @@ -1465,7 +1701,8 @@ lemma map_to_ctes_kh0H: frule_tac 'a=64 in of_bl_length_le, simp, simp, drule int_not_emptyD, clarsimp simp: kh0H_dom s0_ptr_defs cnode_offs_range_def page_offs_range_def pt_offs_range_def irq_node_offs_range_def, - (elim disjE, (clarsimp simp: s0_ptr_defs, + (elim disjE, ((subst (asm) pt_bits_def, simp add: bit_simps split: if_splits; unat_arith) + | clarsimp simp: s0_ptr_defs, drule_tac b="x + y * 0x20" and n=5 for x y in aligned_le_sharp, fastforce simp: is_aligned_def, clarsimp simp: add.commute, subst (asm) mask_out_add_aligned[symmetric], @@ -1475,12 +1712,12 @@ lemma map_to_ctes_kh0H: erule word_plus_mono_right2[rotated], fastforce, fastforce, fastforce simp: add.commute | unat_arith)+)[1])+)[3] apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split, - subst if_split_eq1, rule conjI, rule impI, - clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None, rule impI, - clarsimp simp: kh0H_dom objBitsKO_def s0_ptr_defs is_aligned_def page_offs_range_def - cnode_offs_range_def pt_offs_range_def irq_node_offs_range_def, - rule FalseE, drule int_not_emptyD, clarsimp, - (elim disjE, (clarsimp | drule(1) order_trans le_less_trans, fastforce)+)[1]) + subst if_split_eq1, rule conjI, rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None, rule impI, + clarsimp simp: kh0H_dom objBitsKO_def s0_ptr_defs is_aligned_def page_offs_range_def + cnode_offs_range_def pt_offs_range_def irq_node_offs_range_def, + rule FalseE, drule int_not_emptyD, clarsimp, + (elim disjE, (clarsimp simp: bit_simps split: if_splits | drule(1) order_trans le_less_trans, fastforce)+)[1]) apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split) apply (subst if_split_eq1) apply (rule conjI, clarsimp) @@ -1515,13 +1752,14 @@ lemma map_to_ctes_kh0H: apply (drule shiftl_less_t2n'[where n=5]) apply simp apply simp - apply (drule plus_one_helper[where n="0x7FF", simplified]) + apply (drule plus_one_helper[where n="0x3FFF", simplified]) apply (elim disjE) apply (unat_arith+)[7] apply (drule int_not_emptyD) apply clarsimp apply (elim disjE, - ((clarsimp, + (((subst (asm) pt_bits_def, simp add: bit_simps split: if_splits; unat_arith) | + clarsimp, drule(1) aligned_le_sharp, clarsimp simp: add.commute, subst(asm) mask_out_add_aligned[symmetric], @@ -1542,8 +1780,9 @@ lemma option_update_range_map_comp: by (simp add: fun_eq_iff option_update_range_def map_comp_def map_add_def split: option.split) lemma tcb_offs_in_rangeI: - "\ ptr \ ptr + x; ptr + x \ ptr + 2 ^ 10 - 1 \ \ ptr + x \ tcb_offs_range ptr" - by (simp add: tcb_offs_range_def) + "\ ptr \ ptr + x; ptr + x \ ptr + 2 ^ 11 - 1 \ \ ptr + x \ tcb_offs_range ptr" + apply (simp add: tcb_offs_range_def) + by (simp add: Groups.add_ac(2)) lemma map_to_ctes_kh0H_simps[simp]: "map_to_ctes kh0H (init_irq_node_ptr + (ucast (irq :: irq) << 5)) = Some (CTE NullCap Null_mdb)" @@ -1891,13 +2130,13 @@ lemma map_to_ctes_kh0H_SomeD: x = idle_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ x = idle_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ x = Low_tcb_ptr \ y = (CTE (CNodeCap Low_cnode_ptr 10 2 10) (MDB (Low_cnode_ptr + 0x40) 0 False False)) \ - x = Low_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid,0)))) + x = Low_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid,0)))) (MDB (Low_cnode_ptr + 0x60) 0 False False)) \ x = Low_tcb_ptr + 0x40 \ y = (CTE (ReplyCap Low_tcb_ptr True True) (MDB 0 0 True True)) \ x = Low_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ x = Low_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ x = High_tcb_ptr \ y = (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB (High_cnode_ptr + 0x40) 0 False False)) \ - x = High_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) + x = High_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) (MDB (High_cnode_ptr + 0x60) 0 False False)) \ x = High_tcb_ptr + 0x40 \ y = (CTE (ReplyCap High_tcb_ptr True True) (MDB 0 0 True True)) \ x = High_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ @@ -1956,7 +2195,7 @@ lemma pspace_distinct'_split: done lemma irq_node_offs_range_def2: - "irq_node_offs_range = {x. init_irq_node_ptr \ x \ x \ init_irq_node_ptr + 0x7E0} \ + "irq_node_offs_range = {x. init_irq_node_ptr \ x \ x \ init_irq_node_ptr + 0x3FFF} \ {x. is_aligned x 5}" apply (safe, simp_all add: irq_node_offs_range_def add.commute) by (auto dest: word_less_sub_1 simp: s0_ptr_defs elim: dual_order.strict_trans2[rotated]) @@ -2002,7 +2241,7 @@ lemma s0H_pspace_distinct': , drule dual_order.trans, assumption , clarsimp simp: s0_ptr_defs objBitsKO_def | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) - \ \riscv_global_pt_ptr\ + \ \arm_global_pt_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, @@ -2013,109 +2252,140 @@ lemma s0H_pspace_distinct': apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps split: if_split_asm; (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) - apply (thin_tac "_ \ _", - clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def - irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, - drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, - drule dual_order.trans[rotated], - erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, - (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs mask_def)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def split: if_splits\)+)[12] \ \irq_node_offs_range\ apply (erule_tac P="_ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[5] + apply (clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="init_irq_node_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ apply (clarsimp simp: irq_node_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def split: if_split_asm; (drule(1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) - apply (thin_tac "_ \ _", - clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def - irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, - drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, - drule dual_order.trans[rotated], - erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, - (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs mask_def)+ + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="init_irq_node_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ \ \Low_pt_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[6] + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="Low_pt_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def split: if_split_asm, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def\)+)[1] apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps split: if_split_asm; (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) - apply (thin_tac "_ \ _", - clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def - irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, - drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, - drule dual_order.trans[rotated], - erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, - (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs mask_def)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ \ \High_pt_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[7] + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="High_pt_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def split: if_split_asm, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def\)+) apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps split: if_split_asm; - (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) - apply (thin_tac "_ \ _", - clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def - irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, - drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, - drule dual_order.trans[rotated], - erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, - (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs mask_def)+ + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def))+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ \ \Low_pd_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[8] - apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps - split: if_split_asm; - (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) - apply (thin_tac "_ \ _", - clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def - irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, - drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, - drule dual_order.trans[rotated], - erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, - (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs mask_def)+ + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="Low_pd_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + solves \simp add: s0_ptr_defs mask_def bit_simps split: if_splits\) + apply (solves \clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def bit_simps split: if_splits\)+)[7] \ \High_pd_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[9] - apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps - split: if_split_asm; - (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) - apply (thin_tac "_ \ _", - clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def - irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, - drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, - drule dual_order.trans[rotated], - erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, - (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs mask_def)+ + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="High_pd_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + solves \simp add: s0_ptr_defs mask_def bit_simps split: if_splits\) + apply (solves \clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def bit_simps split: if_splits\)+)[7] \ \Low_pool_ptr\ apply (erule_tac P="_ \ y = _" in disjE) subgoal for x y ya yb @@ -2124,7 +2394,7 @@ lemma s0H_pspace_distinct': page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, (thin_tac "ya \ _", drule dual_order.trans, assumption | thin_tac "_ \ ya", drule dual_order.trans, assumption)?, - solves \clarsimp simp: s0_ptr_defs bit_simps\)+)) + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+)) \ \High_pool_ptr\ apply (erule_tac P="_ \ y = _" in disjE) subgoal for x y ya yb @@ -2133,16 +2403,13 @@ lemma s0H_pspace_distinct': page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, (thin_tac "ya \ _", drule dual_order.trans, assumption | thin_tac "_ \ ya", drule dual_order.trans, assumption)?, - solves \clarsimp simp: s0_ptr_defs bit_simps\)+)) + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+)) \ \Low_cnode_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 - pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[12] + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 pt_offs_range_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ apply (clarsimp simp: objBitsKO_def kh0H_obj_def Low_cte'_def Low_capsH_def cnode_offs_range_def split: if_split_asm; (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) @@ -2157,12 +2424,9 @@ lemma s0H_pspace_distinct': \ \High_cnode_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 - pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[13] + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 pt_offs_range_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ apply (clarsimp simp: objBitsKO_def kh0H_obj_def High_cte'_def High_capsH_def cnode_offs_range_def split: if_split_asm; (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) @@ -2177,12 +2441,9 @@ lemma s0H_pspace_distinct': \ \Silc_cnode_ptr\ apply (erule_tac P="_ \ _ \ y = _" in disjE) apply (elim disjE; clarsimp) - apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 - pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[14] + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 pt_offs_range_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ apply (clarsimp simp: objBitsKO_def kh0H_obj_def Silc_cte'_def Silc_capsH_def cnode_offs_range_def split: if_split_asm; (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) @@ -2202,15 +2463,13 @@ lemma s0H_pspace_distinct': page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, (thin_tac "ya \ _", drule dual_order.trans, assumption | thin_tac "_ \ ya", drule dual_order.trans, assumption)?, - solves \clarsimp simp: s0_ptr_defs bit_simps\)+)) + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+)) \ \shared_page_ptr\ apply (elim disjE; clarsimp) - apply ((clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 page_offs_range_def pt_offs_range_def objBitsKO_def, - drule dual_order.trans, assumption, - (thin_tac "ya \ _", thin_tac "_ \ ya", - drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, - simp add: s0_ptr_defs)+)[16] + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ apply (clarsimp simp: page_offs_range_def objBitsKO_def archObjSize_def bit_simps) apply (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def) done @@ -2337,13 +2596,35 @@ lemma pd_offs_aligned: "is_aligned (High_pd_ptr + (ucast (x :: pt_index) << 3)) 3" by (rule is_aligned_add[OF _ is_aligned_shift], simp add: s0_ptr_defs is_aligned_def)+ -lemma less_0x200_exists_ucast: - "p < 0x200 \ \p'. p = UCAST(9 \ 64) p'" +lemma less_VSRootBits_exists_ucast: + "p < 2 ^ ptTranslationBits VSRootPT_T \ \p'. p = UCAST(vs_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ vs_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + done + +lemma less_eq_0x1FF_exists_ucast: + "p \ 0x1FF \ \p'. p = UCAST(9 \ 64) p'" apply (rule_tac x="UCAST(64 \ 9) p" in exI) apply word_bitwise apply clarsimp done +lemma less_pageBits_exists_ucast: + "p < 2 ^ (pageBitsForSize max_page_size - pageBits) \ \p'. p = UCAST(pg_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ pg_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps split: if_splits) + done + +lemma koTypeOf_PTET[simp]: + "koTypeOf ko = ArchT PTET \ (\pte. ko = KOArch (KOPTE pte))" + apply (case_tac ko; clarsimp) + apply (case_tac x8; clarsimp) + done + lemma valid_caps_s0H[simp]: notes pteBits_def[simp] objBits_defs[simp] shows @@ -2353,79 +2634,159 @@ lemma valid_caps_s0H[simp]: "valid_cap' (CNodeCap Low_cnode_ptr 10 2 10) s0H_internal" "valid_cap' (CNodeCap High_cnode_ptr 10 2 10) s0H_internal" "valid_cap' (CNodeCap Silc_cnode_ptr 10 2 10) s0H_internal" - "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite RISCVLargePage False (Some (ucast Low_asid, 0)))) s0H_internal" - "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage False (Some (ucast High_asid, 0)))) s0H_internal" - "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage False (Some (ucast Silc_asid, 0)))) s0H_internal" - "valid_cap' (ArchObjectCap (PageTableCap Low_pt_ptr (Some (ucast Low_asid, 0)))) s0H_internal" - "valid_cap' (ArchObjectCap (PageTableCap High_pt_ptr (Some (ucast High_asid, 0)))) s0H_internal" - "valid_cap' (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0)))) s0H_internal" - "valid_cap' (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite max_page_size False (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast Silc_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) s0H_internal" "valid_cap' (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid))) s0H_internal" "valid_cap' (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid))) s0H_internal" "valid_cap' (NotificationCap ntfn_ptr 0 True False) s0H_internal" "valid_cap' (NotificationCap ntfn_ptr 0 False True) s0H_internal" "valid_cap' (ReplyCap Low_tcb_ptr True True) s0H_internal" "valid_cap' (ReplyCap High_tcb_ptr True True) s0H_internal" - supply option.case_cong[cong] if_cong[cong] - apply (simp | simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def - objBits_def s0_ptrs_aligned obj_at'_def, - intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, - simp add: objBitsKO_def s0_ptrs_aligned mask_def, - rule pspace_distinctD'[OF _ s0H_pspace_distinct', simplified s0H_internal_def], - simp)+ - apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) - apply (intro conjI) - apply (simp add: objBitsKO_def s0_ptrs_aligned) - apply (simp add: objBitsKO_def) - apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) - apply (clarsimp simp: Low_cte_def Low_cte'_def Low_capsH_def cnode_offs_min2 objBitsKO_def - cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned empty_cte_def) - apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) - apply (simp add: Low_cte_def Low_cte'_def Low_capsH_def empty_cte_def objBitsKO_def - cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) - apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) - apply (intro conjI) - apply (simp add: objBitsKO_def s0_ptrs_aligned) - apply (simp add: objBitsKO_def) - apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) - apply (clarsimp simp: High_cte_def High_cte'_def High_capsH_def cnode_offs_min2 cnode_offs_max2 - cnode_offs_aligned2 add.commute s0_ptrs_aligned objBitsKO_def empty_cte_def) - apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) - apply (simp add: High_cte_def High_cte'_def High_capsH_def empty_cte_def objBitsKO_def - cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) - apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) - apply (intro conjI) - apply (simp add: objBitsKO_def s0_ptrs_aligned) - apply (simp add: objBitsKO_def) - apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) - apply (clarsimp simp: Silc_cte_def Silc_cte'_def Silc_capsH_def cnode_offs_min2 objBitsKO_def - empty_cte_def cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) - apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) - apply (simp add: Silc_cte_def Silc_cte'_def Silc_capsH_def empty_cte_def objBitsKO_def - cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) - apply ((clarsimp simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned bit_simps - Low_asid_def High_asid_def Silc_asid_def asid_bits_defs - vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def - wellformed_mapdata'_def asid_wf_def mask_def, - drule less_0x200_exists_ucast, clarsimp, clarsimp simp: objBitsKO_def, - rule conjI, clarsimp simp: s0_ptr_defs is_aligned_mask bit_simps mask_def, word_bitwise, - rule pspace_distinctD''[OF _ s0H_pspace_distinct'], - simp add: objBitsKO_def)+)[3] - apply ((simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def - asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def - bit_simps mask_def archObjSize_def pt_offs_min objBitsKO_def - page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def, safe, - rule pspace_distinctD''[OF _ s0H_pspace_distinct'], - simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def, - clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, word_bitwise, - fastforce simp: pt_offs_max add.commute)+)[4] - apply ((simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def - asid_bits_defs asid_wf_def s0_ptrs_aligned bit_simps wellformed_mapdata'_def - mask_def page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def - objBitsKO_def archObjSize_def pt_offs_min, - intro conjI, clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, - rule pspace_distinctD''[OF _ s0H_pspace_distinct'], - simp add: kh0H_obj_def archObjSize_def bit_simps objBitsKO_def)+)[2] + supply option.case_cong[cong] if_cong[cong] + apply (simp | simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def + objBits_def s0_ptrs_aligned obj_at'_def, + intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, + simp add: objBitsKO_def s0_ptrs_aligned mask_def, + rule pspace_distinctD'[OF _ s0H_pspace_distinct', simplified s0H_internal_def], + simp)+ + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: Low_cte_def Low_cte'_def Low_capsH_def cnode_offs_min2 objBitsKO_def + cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned empty_cte_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: Low_cte_def Low_cte'_def Low_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: High_cte_def High_cte'_def High_capsH_def cnode_offs_min2 cnode_offs_max2 + cnode_offs_aligned2 add.commute s0_ptrs_aligned objBitsKO_def empty_cte_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: High_cte_def High_cte'_def High_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: Silc_cte_def Silc_cte'_def Silc_capsH_def cnode_offs_min2 objBitsKO_def + empty_cte_def cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: Silc_cte_def Silc_cte'_def Silc_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + (* FIXME AARCH64 IF: boilerplate *) + apply (clarsimp simp: valid_cap'_def) + apply (intro conjI) + apply (auto simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs bit_simps + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + s0_ptr_defs is_aligned_def + wellformed_mapdata'_def asid_wf_def mask_def)[3] + apply (clarsimp simp: frame_at'_def typ_at'_def ko_wp_at'_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: pageBits_def objBitsKO_def s0_ptrs_aligned) + apply (rule conjI) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + + apply (clarsimp simp: valid_cap'_def) + apply (intro conjI) + apply (auto simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs bit_simps + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + s0_ptr_defs is_aligned_def + wellformed_mapdata'_def asid_wf_def mask_def)[3] + apply (clarsimp simp: frame_at'_def typ_at'_def ko_wp_at'_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: pageBits_def objBitsKO_def s0_ptrs_aligned) + apply (rule conjI) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + + apply (clarsimp simp: valid_cap'_def) + apply (intro conjI) + apply (auto simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs bit_simps + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + s0_ptr_defs is_aligned_def + wellformed_mapdata'_def asid_wf_def mask_def)[3] + apply (clarsimp simp: frame_at'_def typ_at'_def ko_wp_at'_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: pageBits_def objBitsKO_def s0_ptrs_aligned) + apply (rule conjI) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + + apply ((clarsimp simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + bit_simps mask_def archObjSize_def pt_offs_min objBitsKO_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + dest!: less_eq_0x1FF_exists_ucast, safe, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def, + clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, word_bitwise, + fastforce simp: pt_offs_max add.commute)+)[4] + + apply (clarsimp simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def, safe) + apply (rule is_aligned_weaken, rule s0_ptrs_aligned, simp add: bit_simps, simp add: bit_simps) + apply ((clarsimp simp: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + dest!: less_VSRootBits_exists_ucast, safe)) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (simp add: add_mask_fold pt_offs_max) + + apply (clarsimp simp: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def, safe) + apply (rule is_aligned_weaken, rule s0_ptrs_aligned, simp add: bit_simps, simp add: bit_simps) + apply ((clarsimp simp: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + dest!: less_VSRootBits_exists_ucast, safe)) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (simp add: add_mask_fold pt_offs_max) + + apply ((simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned bit_simps wellformed_mapdata'_def + mask_def page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + objBitsKO_def archObjSize_def pt_offs_min, + intro conjI, clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: kh0H_obj_def archObjSize_def bit_simps objBitsKO_def)+)[2] by (simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def objBits_def obj_at'_def, intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, simp add: objBitsKO_def s0_ptrs_aligned mask_def, @@ -2461,9 +2822,10 @@ lemma s0H_valid_objs': default_priority_def tcb_cte_cases_def) defer 2 apply (auto simp: is_aligned_def addrFromPPtr_def ptrFromPAddr_def pptrBaseOffset_def - valid_obj'_def s0_ptr_defs kh0H_obj_def valid_arch_obj'_def)[5] + valid_obj'_def s0_ptr_defs kh0H_obj_def valid_arch_obj'_def bit_simps + kh0H_all_obj_def canonical_address_def canonical_address_of_def paddrBase_def)[5] apply (auto simp: valid_obj'_def valid_cte'_def empty_cte_def irq_cte_def - valid_arch_obj'_def + valid_arch_obj'_def kh0H_all_obj_def Low_cte_def Low_cte'_def Low_capsH_def High_cte_def High_cte'_def High_capsH_def Silc_cte_def Silc_cte'_def Silc_capsH_def) @@ -2653,28 +3015,28 @@ lemma map_to_ctes_kh0H_simps'[simp]: "map_to_ctes kh0H (Low_cnode_ptr + 0x20) = Some (CTE (ThreadCap Low_tcb_ptr) Null_mdb)" "map_to_ctes kh0H (Low_cnode_ptr + 0x40) = Some (CTE (CNodeCap Low_cnode_ptr 10 2 10) (MDB 0 Low_tcb_ptr False False))" - "map_to_ctes kh0H (Low_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap Low_pd_ptr (Some (ucast Low_asid, 0)))) + "map_to_ctes kh0H (Low_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0)))) (MDB 0 (Low_tcb_ptr + 0x20) False False))" "map_to_ctes kh0H (Low_cnode_ptr + 0x80) = Some (CTE (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid))) Null_mdb)" - "map_to_ctes kh0H (Low_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite RISCVLargePage + "map_to_ctes kh0H (Low_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite max_page_size False (Some (ucast Low_asid, 0)))) (MDB 0 (Silc_cnode_ptr + 0xA0) False False))" - "map_to_ctes kh0H (Low_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap Low_pt_ptr (Some (ucast Low_asid, 0)))) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (ucast Low_asid, 0)))) Null_mdb)" "map_to_ctes kh0H (Low_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 True False) (MDB (Silc_cnode_ptr + 0x27C0) 0 False False))" "map_to_ctes kh0H (High_cnode_ptr + 0x20) = Some (CTE (ThreadCap High_tcb_ptr) Null_mdb)" "map_to_ctes kh0H (High_cnode_ptr + 0x40) = Some (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB 0 High_tcb_ptr False False))" - "map_to_ctes kh0H (High_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap High_pd_ptr (Some (ucast High_asid, 0)))) + "map_to_ctes kh0H (High_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) (MDB 0 (High_tcb_ptr + 0x20) False False))" "map_to_ctes kh0H (High_cnode_ptr + 0x80) = Some (CTE (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid))) Null_mdb)" - "map_to_ctes kh0H (High_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + "map_to_ctes kh0H (High_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast High_asid, 0)))) (MDB (Silc_cnode_ptr + 0xA0) 0 False False))" - "map_to_ctes kh0H (High_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap High_pt_ptr (Some (ucast High_asid, 0)))) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (ucast High_asid, 0)))) Null_mdb)" "map_to_ctes kh0H (High_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 False True) (MDB 0 (Silc_cnode_ptr + 0x27C0) False False))" "map_to_ctes kh0H (Silc_cnode_ptr + 0x40) = Some (CTE (CNodeCap Silc_cnode_ptr 10 2 10) Null_mdb)" - "map_to_ctes kh0H (Silc_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly RISCVLargePage + "map_to_ctes kh0H (Silc_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast Silc_asid, 0)))) (MDB (Low_cnode_ptr + 0xA0) (High_cnode_ptr + 0xA0) False False))" "map_to_ctes kh0H (Silc_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 True False) @@ -2740,7 +3102,7 @@ lemma mdb_next_s0H: apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned split: if_split_asm) - apply (clarsimp simp: next_unfold' map_to_ctes_kh0H_dom) + apply (clarsimp simp: next_unfold') apply (elim disjE, simp_all add: kh0H_all_obj_def') done @@ -2795,7 +3157,7 @@ lemma mdb_next_trancl_s0H: apply (subst (asm) mdb_next_s0H) apply (clarsimp simp: s0_ptr_defs) apply (clarsimp simp: s0_ptr_defs del: disjCI) - apply ((erule_tac P="y = _ \ _" in disjE | clarsimp)+)[1] + subgoal for y by ((erule_tac P="y = _ \ _" in disjE | clarsimp)+)[1] apply (elim disjE) apply (rule r_into_trancl, simp add: mdb_next_s0H) apply (rule r_into_trancl, simp add: mdb_next_s0H) @@ -2846,8 +3208,8 @@ lemma sameRegionAs_s0H: apply (clarsimp simp: to_bl_use_of_bl the_nat_to_bl_simps kh0H_all_obj_def' ucast_shiftr_2 split: if_split_asm) apply ((frule_tac x=p' in map_to_ctes_kh0H_SomeD, - (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps)[1], - ((clarsimp simp: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps to_bl_use_of_bl + (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps)[1], + ((clarsimp simp: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps to_bl_use_of_bl the_nat_to_bl_simps kh0H_all_obj_def' ucast_shiftr_2 ucast_shiftr_3 split: if_split_asm)+)[3])+)[5] apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) @@ -2862,7 +3224,7 @@ lemma sameRegionAs_s0H: apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E split: if_split_asm) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) apply (drule(2) ucast_shiftr_5; clarsimp) @@ -2874,7 +3236,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_5; clarsimp) apply (drule(2) ucast_shiftr_5; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) apply (drule(2) ucast_shiftr_2; clarsimp) @@ -2892,7 +3254,7 @@ lemma sameRegionAs_s0H: apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E split: if_split_asm) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2902,7 +3264,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_6; clarsimp) apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2915,7 +3277,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_5; clarsimp) apply (drule(2) ucast_shiftr_5; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2924,7 +3286,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_4; clarsimp) apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2934,7 +3296,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_3; clarsimp) apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2945,7 +3307,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_2; clarsimp) apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2966,7 +3328,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_13E; clarsimp) apply (drule(2) ucast_shiftr_13E; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2975,7 +3337,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_6; clarsimp) apply (drule(2) ucast_shiftr_6; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2990,7 +3352,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_5; clarsimp) apply (drule(2) ucast_shiftr_5; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -2999,7 +3361,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_4; clarsimp) apply (drule(2) ucast_shiftr_4; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -3009,7 +3371,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_3; clarsimp) apply (drule(2) ucast_shiftr_3; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -3020,7 +3382,7 @@ lemma sameRegionAs_s0H: apply (drule(2) ucast_shiftr_2; clarsimp) apply (drule(2) ucast_shiftr_2; clarsimp) apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) - apply (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def isCap_simps + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps split: if_split_asm)[1] apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 split: if_split_asm) @@ -3038,6 +3400,13 @@ lemma mdb_nextI: "m p = Some c \ m \ p \ mdbNext (cteMDBNode c)" by (simp add: mdb_next_unfold) +lemma above_pptr_base_canonical: + "\ pptr_base \ p; p \ pptrTop - 1 \ \ canonical_address p" + apply (simp add: canonical_address_range pptr_base_def pptrBase_def NOT_mask canonical_bit_def pptrTop_def mask_def) + apply (erule order.trans) + apply clarsimp + done + lemma s0H_valid_pspace': notes pteBits_def[simp] objBits_defs[simp] notes valid_arch_badges_def[simp] mdb_chunked_arch_assms_def[simp] @@ -3055,16 +3424,15 @@ lemma s0H_valid_pspace': split: if_splits) apply (clarsimp simp: pspace_canonical'_def) apply (drule kh0H_SomeD') + apply (rule above_pptr_base_canonical) apply (fastforce elim: dual_order.trans intro: above_pptr_base_canonical - simp: irq_node_offs_range_def cnode_offs_range_def + simp: irq_node_offs_range_def cnode_offs_range_def pptrTop_def pt_offs_range_def page_offs_range_def s0_ptr_defs) - apply (clarsimp simp: pspace_in_kernel_mappings'_def) - apply (clarsimp simp: kernel_mappings_def) - apply (drule kh0H_SomeD') - apply (fastforce elim: dual_order.trans - simp: s0_ptr_defs irq_node_offs_range_def cnode_offs_range_def - pt_offs_range_def page_offs_range_def kernel_mappings_def) + apply (elim disjE; clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pptrTop_def + pt_offs_range_def page_offs_range_def s0_ptr_defs bit_simps mask_def + split: if_splits) + apply (fastforce elim: order.trans)+ apply (clarsimp simp: no_0_obj'_def) apply (rule ccontr, clarsimp) apply (drule kh0H_SomeD) @@ -3114,6 +3482,7 @@ lemma s0H_valid_pspace': apply (rule r_r_into_trancl[OF next_fold next_fold], simp+)[1] apply (erule r_into_trancl[OF next_fold], simp)+ apply (clarsimp simp: valid_badges_def) + apply (rule conjI) apply (frule_tac x=p in map_to_ctes_kh0H_SomeD) apply (elim disjE, (clarsimp simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def kh0H_all_obj_def isCap_simps @@ -3138,6 +3507,12 @@ lemma s0H_valid_pspace': apply (elim disjE, (clarsimp simp: High_cte_cte_def Low_cte_cte_def Silc_cte_cte_def kh0H_all_obj_def split: if_split_asm)+)[1] + apply (case_tac "p' = 0") + apply clarsimp + apply (frule_tac x=0 in map_to_ctes_kh0H_SomeD) + apply (clarsimp simp: s0_ptr_defs irq_node_offs_range_def cnode_offs_range_def) + apply (clarsimp simp: mdb_next_s0H) + apply (auto simp: isArchSGISignalCap_def)[1] apply (clarsimp simp: caps_contained'_def) apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) apply (elim disjE, simp_all)[1] @@ -3145,7 +3520,7 @@ lemma s0H_valid_pspace': apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def split: if_split_asm) apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def split: if_split_asm) apply (clarsimp simp: mdb_chunked_def) - apply (frule(3) sameRegionAs_s0H) + apply (frule sameRegionAs_s0H, simp, simp, simp) apply (clarsimp simp: conj_disj_distribL) apply (prop_tac "p \ 0 \ p' \ 0") apply (elim disjE; clarsimp simp: s0_ptr_defs) @@ -3158,7 +3533,7 @@ lemma s0H_valid_pspace': apply ((clarsimp simp: is_chunk_def, drule mdb_next_rtrancl_not_0_s0H, fastforce simp: s0_ptr_defs, clarsimp simp: mdb_next_trancl_s0H, - (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def + (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps kh0H_all_obj_def' , (fastforce simp: s0_ptr_defs)+)[1])+)[10] apply (thin_tac "_ \ _") @@ -3167,7 +3542,7 @@ lemma s0H_valid_pspace': apply ((clarsimp simp: is_chunk_def, drule mdb_next_rtrancl_not_0_s0H, fastforce simp: s0_ptr_defs, clarsimp simp: mdb_next_trancl_s0H, - (elim disjE, simp_all add: sameRegionAs_def RISCV64_H.sameRegionAs_def + (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps kh0H_all_obj_def' , (fastforce simp: s0_ptr_defs)+)[1])+)[10] apply (clarsimp simp: untyped_mdb'_def) @@ -3237,21 +3612,18 @@ lemma valid_arch_state_s0H: apply (intro conjI) apply (clarsimp simp: valid_asid_table'_def s0H_internal_def arch_state0H_def asid_bits_defs asid_high_bits_of_def Low_asid_def High_asid_def mask_def s0_ptr_defs) - apply (clarsimp simp: valid_global_pts'_def is_aligned_riscv_global_pt_ptr[simplified bit_simps] - arch_state0H_def page_table_at'_def typ_at'_def ko_wp_at'_def - bit_simps global_ptH_def pt_offs_min) - apply (subst objBitsKO_def) - apply (clarsimp simp: archObjSize_def bit_simps) - apply (intro conjI) - apply (fastforce intro: pspace_distinctD'[OF _ s0H_pspace_distinct'] - simp: global_ptH_def pt_offs_min) - apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) - apply word_bitwise - apply (clarsimp simp: s0_ptr_defs) - apply word_bitwise - apply (clarsimp simp: arch_state0H_def) + apply (clarsimp simp: arch_state0H_def) + apply (clarsimp simp: arch_state0H_def) + apply (clarsimp simp: arch_state0H_def max_armKSGICVCPUNumListRegs_def) + apply (clarsimp simp: arch_state0H_def s0_ptr_defs) + apply (clarsimp simp: canonical_address_def canonical_address_of_def addrFromKPPtr_def + kernelELFBaseOffset_def kernelELFBase_def kernelELFPAddrBase_def) done +lemma timer_irq_not_outside_range[simp]: + "\ maxIRQ < timer_irq" + by (simp add: timer_irq_def) + lemma s0H_invs: assumes "1 \ maxDomain" notes pteBits_def[simp] objBits_defs[simp] @@ -3284,14 +3656,21 @@ lemma s0H_invs: apply (erule notE, rule pspace_distinctD''[OF _ s0H_pspace_distinct']) apply (simp add: objBitsKO_def ntfnH_def) apply (clarsimp simp: tcb_st_refs_of'_def idle_tcbH_def) - apply (clarsimp simp: global_ptH_def) - apply (clarsimp simp: Low_ptH_def) - apply (clarsimp simp: High_ptH_def) - apply (clarsimp simp: Low_pdH_def) - apply (clarsimp simp: High_pdH_def) + apply (clarsimp simp: global_ptH_def split: if_splits) + apply (clarsimp simp: Low_ptH_def split: if_splits) + apply (clarsimp simp: High_ptH_def split: if_splits) + apply (clarsimp simp: Low_pdH_def split: if_splits) + apply (clarsimp simp: High_pdH_def split: if_splits) apply (clarsimp simp: Low_cte_def Low_cte'_def split: if_split_asm) apply (clarsimp simp: High_cte_def High_cte'_def split: if_split_asm) apply (clarsimp simp: Silc_cte_def Silc_cte'_def split: if_split_asm) + apply (rule conjI) + apply (subgoal_tac "state_hyp_refs_of' s0H_internal = (\p. {})") + apply (clarsimp simp: sym_refs_def) + apply (rule ext, rule equals0I) + apply (clarsimp simp: state_hyp_refs_of'_def hyp_refs_of'_def tcb_vcpu_refs'_def + split: option.splits if_splits dest!: kh0H_SomeD) + apply (elim disjE; clarsimp simp: tcb_vcpu_refs'_def kh0H_all_obj_def split: if_splits) apply (rule conjI) apply (clarsimp simp: if_live_then_nonz_cap'_def ko_wp_at'_def) apply (drule kh0H_SomeD) @@ -3305,7 +3684,7 @@ lemma s0H_invs: apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) apply (rule_tac x="High_cnode_ptr + 0x20" in exI) apply (clarsimp simp: kh0H_all_obj_def') - apply (clarsimp split: if_split_asm simp: live'_def hyp_live'_def)+ + apply (clarsimp split: if_split_asm simp: live'_def hyp_live'_def arch_live'_def)+ apply (rule conjI) apply (clarsimp simp: if_unsafe_then_cap'_def ex_cte_cap_wp_to'_def cte_wp_at_ctes_of) apply (frule map_to_ctes_kh0H_SomeD) @@ -3429,7 +3808,7 @@ lemma s0H_invs: apply (rule conjI) apply (clarsimp simp: valid_machine_state'_def s0H_internal_def machine_state0_def) apply (rule conjI) - apply (clarsimp simp: irqs_masked'_def s0H_internal_def maxIRQ_def timer_irq_def irqInvalid_def) + apply (clarsimp simp: irqs_masked'_def s0H_internal_def) apply (rule conjI) apply (clarsimp simp: sym_heap_def opt_map_def projectKOs split: option.splits) using kh0H_dom_tcb @@ -3439,7 +3818,7 @@ lemma s0H_invs: using kh0H_dom_tcb apply (fastforce simp: kh0H_obj_def) apply (rule conjI) - apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def s0H_internal_def + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def s0H_internal_def emptyHeadEndPtrs_def tcbQueueEmpty_def bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def) apply (rule conjI) apply (clarsimp simp: ct_not_inQ_def obj_at'_def objBitsKO_def @@ -3453,14 +3832,36 @@ lemma s0H_invs: apply (simp add: objBitsKO_def) apply (rule conjI) apply (clarsimp simp: kdr_pspace_domain_valid) (* use axiomatization for now *) - apply (clarsimp simp: s0H_internal_def cteCaps_of_def untyped_ranges_zero_inv_def - dschDomain_def dschLength_def) - apply (clarsimp simp: newKernelState_def newKSDomSched) + apply (clarsimp simp: s0H_internal_def cteCaps_of_def untyped_ranges_zero_inv_def + dschDomain_def dschLength_def valid_dom_schedule'_def maxDomainDuration_def mask_def) apply (clarsimp simp: cur_tcb'_def obj_at'_def s0H_internal_def objBitsKO_def s0_ptrs_aligned) apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) apply (simp add: objBitsKO_def) done +lemma ptTranslationBits_NormalPT[simp]: + "ptTranslationBits NormalPT_T = 9" + by (simp add: bit_simps) + +lemma less_0x200_exists_ucast: + "p < 0x200 \ \p'. p = UCAST(pg_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ pg_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + apply word_bitwise + apply auto + done + +lemma less_0x40000_exists_ucast: + "\ p < 0x40000; \ config_ARM_PA_SIZE_BITS_40 \ \ \p'. p = UCAST(pg_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ pg_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + apply word_bitwise + done + lemma kh0_pspace_dom: "pspace_dom kh0 = {idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, High_pool_ptr, Low_pool_ptr, irq_cnode_ptr, ntfn_ptr} \ @@ -3469,18 +3870,20 @@ lemma kh0_pspace_dom: cnode_offs_range Silc_cnode_ptr \ cnode_offs_range High_cnode_ptr \ cnode_offs_range Low_cnode_ptr \ - pt_offs_range riscv_global_pt_ptr \ - pt_offs_range High_pd_ptr \ - pt_offs_range Low_pd_ptr \ - pt_offs_range High_pt_ptr \ - pt_offs_range Low_pt_ptr" + pt_offs_range VSRootPT_T arm_global_pt_ptr \ + pt_offs_range VSRootPT_T High_pd_ptr \ + pt_offs_range VSRootPT_T Low_pd_ptr \ + pt_offs_range NormalPT_T High_pt_ptr \ + pt_offs_range NormalPT_T Low_pt_ptr" apply (rule equalityI) apply (simp add: dom_def pspace_dom_def) apply clarsimp - apply (clarsimp simp: kh0_def obj_relation_cuts_def page_offs_in_range pt_offs_in_range - cnode_offs_in_range irq_node_offs_in_range s0_ptrs_aligned bit_simps - kh0_obj_def cte_map_def' caps_dom_length_10 - dest!: less_0x200_exists_ucast split: if_split_asm) + apply (clarsimp simp: kh0_def obj_relation_cuts_def page_offs_in_range pt_offs_in_range pageBits_def + cnode_offs_in_range irq_node_offs_in_range s0_ptrs_aligned pte_bits_def word_size_bits_def + kh0_obj_def cte_map_def' caps_dom_length_10 mask_def max_page_size_def + dest!: less_VSRootBits_exists_ucast less_eq_0x1FF_exists_ucast + less_0x40000_exists_ucast less_0x200_exists_ucast + split: if_split_asm) apply (clarsimp simp: pspace_dom_def dom_def) apply (rule conjI) apply (rule_tac x=idle_tcb_ptr in exI) @@ -3513,10 +3916,21 @@ lemma kh0_pspace_dom: apply clarsimp apply (rule_tac x=shared_page_ptr_virt in exI) apply (drule offs_range_correct) - apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps bit_simps) - apply (rule_tac x="UCAST (9 \ 64) y" in exI) - apply clarsimp - apply word_bitwise + apply (auto simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps bit_simps max_page_size_def)[1] + apply (rule_tac x="UCAST (pg_index_len \ 64) y" in exI) + apply clarsimp + apply (rule xtr7[rotated]) + apply (rule ucast_leq_mask) + apply simp + apply (rule order.refl) + apply (clarsimp simp: bit_simps mask_def) + apply (rule_tac x="UCAST (pg_index_len \ 64) y" in exI) + apply clarsimp + apply (rule xtr7[rotated]) + apply (rule ucast_leq_mask) + apply simp + apply (rule order.refl) + apply (clarsimp simp: bit_simps mask_def) apply (rule conjI) apply clarsimp apply (rule_tac x=Silc_cnode_ptr in exI) @@ -3534,28 +3948,53 @@ lemma kh0_pspace_dom: apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) apply (rule conjI) apply clarsimp - apply (rule_tac x=riscv_global_pt_ptr in exI) + apply (rule_tac x=arm_global_pt_ptr in exI) apply (drule offs_range_correct) - apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs) + apply (rule exI) + apply (rule_tac x="UCAST(vs_index_len \ 64) y" in bexI) + apply (rule conjI, simp add: bit_simps, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp add: bit_simps) apply (rule conjI) apply clarsimp apply (rule_tac x=High_pd_ptr in exI) apply (drule offs_range_correct) - apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs) + apply (rule exI) + apply (rule_tac x="UCAST(vs_index_len \ 64) y" in bexI) + apply (rule conjI, simp add: bit_simps, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp add: bit_simps) apply (rule conjI) apply clarsimp apply (rule_tac x=Low_pd_ptr in exI) apply (drule offs_range_correct) - apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs) + apply (rule exI) + apply (rule_tac x="UCAST(vs_index_len \ 64) y" in bexI) + apply (rule conjI, simp add: bit_simps, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp add: bit_simps) apply (rule conjI) apply clarsimp apply (rule_tac x=High_pt_ptr in exI) apply (drule offs_range_correct) - apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule exI) + apply (rule_tac x="UCAST(9 \ 64) y" in bexI) + apply (rule conjI, rule refl, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp) apply clarsimp apply (rule_tac x=Low_pt_ptr in exI) apply (drule offs_range_correct) - apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule exI) + apply (rule_tac x="UCAST(9 \ 64) y" in bexI) + apply (rule conjI, rule refl, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp) done @@ -3573,7 +4012,7 @@ lemma shiftl_shiftr_3_pt_index[simp]: lemma mult_shiftr_id[simp]: "length x = 10 \ of_bl x * (0x20 :: obj_ref) >> 5 = of_bl x" - apply (simp add: shiftl_t2n[symmetric, where n=5, simplified mult.commute, simplified] ) + apply (simp add: shiftl_t2n[symmetric, where n=5, simplified mult.commute, simplified]) apply (subst shiftl_shiftr_id) apply simp apply (rule less_trans) @@ -3592,7 +4031,7 @@ lemma to_bl_ucast_of_bl[simp]: done lemma is_aligned_shiftr_3[simp]: - "is_aligned (riscv_global_pt_ptr + (n << 3)) 3" + "is_aligned (arm_global_pt_ptr + (n << 3)) 3" "is_aligned (High_pd_ptr + (n << 3)) 3" "is_aligned (Low_pd_ptr + (n << 3)) 3" "is_aligned (High_pt_ptr + (n << 3)) 3" @@ -3600,8 +4039,33 @@ lemma is_aligned_shiftr_3[simp]: apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(1), where y=3, simplified bit_simps]]; fastforce) apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(2), where y=3, simplified bit_simps]]; fastforce) apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(3), where y=3, simplified bit_simps]]; fastforce) - apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(4), where y=3, simplified bit_simps]]; fastforce) - apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(5), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(7), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(8), where y=3, simplified bit_simps]]; fastforce) + done + +lemma ucast_ucast_vs_index_helper[simp]: + "UCAST(64 \ vs_index_len) (UCAST(vs_index_len \ 64) p) = p" + apply (rule ucast_up_ucast_id) + by (simp add: is_up_def source_size_def target_size_def bit_simps) + +lemma less_eq_VSRootBits_exists_ucast: + "p \ 2 ^ ptTranslationBits VSRootPT_T - 1 \ \p'. p = UCAST(vs_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ vs_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + done + +lemma shiftl_shiftr_3_vs_index[simp]: + "ucast (((ucast (x :: vs_index) << 3) :: obj_ref) >> 3) = x" + apply (subst shiftl_shiftr_id) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (erule less_trans) + apply (simp add: bit_simps) + apply simp + apply (rule ucast_ucast_id) + apply simp done lemma s0_pspace_rel: @@ -3610,20 +4074,58 @@ lemma s0_pspace_rel: apply clarsimp apply (drule kh0_SomeD) apply (elim disjE) - apply (clarsimp simp: kh0_obj_def bit_simps dest!: less_0x200_exists_ucast) + apply (clarsimp simp: kh0_obj_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: kh0_obj_def bit_simps max_page_size_def dest!: less_0x40000_exists_ucast) defer apply ((clarsimp simp: kh0_obj_def kh0H_obj_def bit_simps word_bits_def fault_rel_optionation_def tcb_relation_cut_def tcb_relation_def arch_tcb_relation_def the_nat_to_bl_simps split del: if_split)+)[3] prefer 13 - apply ((clarsimp simp: kh0_obj_def kh0H_all_obj_def bit_simps add.commute - pt_offs_max pt_offs_min pte_relation_def - split del: if_split, - clarsimp simp: s0_ptr_defs shared_page_ptr_phys_def addrFromPPtr_def pptrBaseOffset_def paddrBase_def - vmrights_map_def vm_read_only_def vm_read_write_def - kh0_obj_def kh0H_all_obj_def elf_index_value, - (clarsimp simp: bit_simps mask_def)?)+)[5] + apply (clarsimp simp: kh0_obj_def mask_def) + apply (drule less_VSRootBits_exists_ucast) + apply ((auto simp: kh0_obj_def kh0H_all_obj_def add.commute pte_bits_def + pt_offs_max pt_offs_min pte_relation_def mask_def bit_simps))[1] + apply (insert pt_offs_max(5)[simplified mask_2pm1])[2] + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps) + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps) + apply (((clarsimp simp: kh0_obj_def kh0H_all_obj_def bit_simps add.commute + pt_offs_max pt_offs_min pte_relation_def mask_def + vm_read_only_def vmrights_map_def ucast_ucast_id vm_read_write_def + kh0H_simps(14,15)[where y=0, simplified] + dest!: less_eq_0x1FF_exists_ucast, + clarsimp simp: s0_ptr_defs is_aligned_def addrFromPPtr_def ppn_from_pptr_def + pageBits_def pptrBaseOffset_def pptrBase_def paddrBase_def); fail?)+)[2] + apply (clarsimp simp: kh0_obj_def mask_def) + apply (drule less_VSRootBits_exists_ucast) + apply (clarsimp simp: pte_bits_def word_size_bits_def kh0H_all_obj_def) + apply (((clarsimp simp: kh0_obj_def kh0H_all_obj_def add.commute + pt_offs_max pt_offs_min pte_relation_def mask_def + vm_read_only_def vmrights_map_def ucast_ucast_id vm_read_write_def + pte_bits_def word_size_bits_def + dest!: less_eq_VSRootBits_exists_ucast))) + apply (auto simp: ppn_from_pptr_def)[1] + apply (clarsimp simp: bit_simps s0_ptr_defs is_aligned_def addrFromPPtr_def pageBits_def + ppn_from_pptr_def pptrBaseOffset_def pptrBase_def paddrBase_def) + apply (insert pt_offs_max(2)[simplified mask_2pm1])[1] + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps add_diff_eq) + apply (clarsimp simp: kh0_obj_def mask_def) + apply (drule less_VSRootBits_exists_ucast) + apply (clarsimp simp: pte_bits_def word_size_bits_def kh0H_all_obj_def) + apply (((clarsimp simp: kh0_obj_def kh0H_all_obj_def add.commute + pt_offs_max pt_offs_min pte_relation_def mask_def + vm_read_only_def vmrights_map_def ucast_ucast_id vm_read_write_def + pte_bits_def word_size_bits_def + dest!: less_eq_VSRootBits_exists_ucast))) + apply (auto simp: ppn_from_pptr_def)[1] + apply (clarsimp simp: bit_simps s0_ptr_defs is_aligned_def addrFromPPtr_def ppn_from_pptr_def pageBits_def pptrBaseOffset_def pptrBase_def paddrBase_def) + apply (insert pt_offs_max(1)[simplified mask_2pm1])[1] + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps add_diff_eq) apply (clarsimp simp: kh0_obj_def kh0H_obj_def well_formed_cnode_n_def cte_relation_def cte_map_def bit_simps) apply (clarsimp simp: kh0H_obj_def bit_simps ntfn_def other_obj_relation_def ntfn_relation_def) @@ -3631,20 +4133,19 @@ lemma s0_pspace_rel: apply ((clarsimp simp: kh0_obj_def kh0H_obj_def other_obj_relation_def asid_pool_relation_def comp_def inv_into_def2 other_aobj_relation_def, rule ext, - clarsimp simp: asid_low_bits_of_def asid_low_bits_def High_asid_def, - word_bitwise, fastforce)+)[2] + clarsimp simp: asid_low_bits_of_def asid_low_bits_def High_asid_def abs_asid_entry_def, word_bitwise)+)[2] apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') apply (cut_tac dom_caps(2))[1] apply (frule_tac m=High_caps in domI) apply (cut_tac x=y in cnode_offs_in_range(2), simp) - apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def High_caps_def + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def High_caps_def max_page_size_def the_nat_to_bl_simps vmrights_map_def vm_read_only_def split: if_split_asm) apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') apply (cut_tac dom_caps(3))[1] apply (frule_tac m=Low_caps in domI) apply (cut_tac x=y in cnode_offs_in_range(1), simp) - apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Low_caps_def + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Low_caps_def max_page_size_def the_nat_to_bl_simps vmrights_map_def vm_read_write_def split: if_split_asm) apply (fastforce simp: kh0H_obj_def cte_map_def cte_relation_def well_formed_cnode_n_def @@ -3653,7 +4154,7 @@ lemma s0_pspace_rel: apply (cut_tac dom_caps(1))[1] apply (frule_tac m=Silc_caps in domI) apply (cut_tac x=y in cnode_offs_in_range(3), simp) - apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Silc_caps_def + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Silc_caps_def max_page_size_def the_nat_to_bl_simps vmrights_map_def vm_read_only_def split: if_split_asm) done @@ -3662,128 +4163,120 @@ lemma subtree_node_Some: "m \ a \ b \ m a \ None" by (erule subtree.cases) (auto simp: parentOf_def) +lemma max_numlistregs_rel[simp]: + "max_numlistregs = max_armKSGICVCPUNumListRegs" + by (simp add: max_numlistregs_def max_armKSGICVCPUNumListRegs_def) + lemma s0_srel: "1 \ maxDomain \ (s0_internal, s0H_internal) \ state_relation" apply (simp add: state_relation_def) apply (intro conjI) - apply (simp add: s0_pspace_rel) - apply (simp add: s0_internal_def exst0_def s0H_internal_def sched_act_relation_def) - apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def - ready_queues_relation_def ready_queue_relation_def - list_queue_relation_def queue_end_valid_def - prev_queue_head_def inQ_def tcbQueueEmpty_def - projectKOs opt_map_def opt_pred_def - split: option.splits) - using kh0H_dom_tcb - apply (fastforce simp: kh0H_obj_def) - apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def ghost_relation_def) - apply (rule conjI) - apply (fastforce simp: kh0_def kh0_obj_def dest: kh0_SomeD) - apply clarsimp - apply (rule conjI) - apply clarsimp - apply (rule iffI) + apply (simp add: s0_pspace_rel) + apply (simp add: s0_internal_def exst0_def s0H_internal_def sched_act_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def + ready_queues_relation_def ready_queue_relation_def + list_queue_relation_def queue_end_valid_def + prev_queue_head_def inQ_def tcbQueueEmpty_def + projectKOs opt_map_def opt_pred_def emptyHeadEndPtrs_def + split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def ghost_relation_def) + apply (intro conjI) + apply (fastforce simp: kh0_def kh0_obj_def max_page_size_def dest: kh0_SomeD) apply clarsimp - apply (drule kh0_SomeD) - apply (clarsimp simp: irq_node_offs_in_range) - apply (fastforce simp: kh0_def well_formed_cnode_n_def empty_cnode_def dom_def) - apply clarsimp - apply (clarsimp simp: s0_ptr_defs) - apply (subgoal_tac "a \ irq_node_offs_range") - prefer 2 - apply (clarsimp simp: irq_node_offs_range_def s0_ptr_defs) - apply (erule_tac x="ucast (a - 0xFFFFFFC000003000 >> 5)" in allE) - apply (subst (asm) ucast_ucast_len) - apply (rule shiftr_less_t2n) - apply (rule word_less_sub_right) - apply (erule dual_order.strict_trans[rotated], clarsimp) + apply (rule conjI) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: irq_node_offs_in_range) + apply (fastforce simp: kh0_def well_formed_cnode_n_def empty_cnode_def dom_def) apply clarsimp - apply (simp add: shiftr_shiftl1) - apply (subst(asm) is_aligned_neg_mask_eq) - apply (rule aligned_sub_aligned[where n=5]) - apply simp - apply (simp add: is_aligned_def) - apply simp - apply simp - apply (intro conjI impI) + apply (prop_tac "a \ irq_node_offs_range") + apply (fastforce dest: irq_node_offs_range_correct) + apply (clarsimp simp: s0_ptr_defs) + apply (intro conjI impI) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Low_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs High_caps_def + well_formed_cnode_n_def empty_cnode_def) apply clarsimp apply (rule iffI) apply clarsimp apply (drule kh0_SomeD) apply (clarsimp simp: s0_ptr_defs kh0_obj_def) - apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Low_caps_def + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def well_formed_cnode_n_def empty_cnode_def) apply clarsimp apply (rule iffI) apply clarsimp apply (drule kh0_SomeD) apply (clarsimp simp: s0_ptr_defs kh0_obj_def) - apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs High_caps_def + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def well_formed_cnode_n_def empty_cnode_def) apply clarsimp - apply (rule iffI) - apply clarsimp - apply (drule kh0_SomeD) - apply (clarsimp simp: s0_ptr_defs kh0_obj_def) - apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def - well_formed_cnode_n_def empty_cnode_def) - apply clarsimp - apply (rule iffI) - apply clarsimp apply (drule kh0_SomeD) apply (clarsimp simp: s0_ptr_defs kh0_obj_def) - apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def - well_formed_cnode_n_def empty_cnode_def) - apply clarsimp - apply (drule kh0_SomeD) - apply (clarsimp simp: s0_ptr_defs kh0_obj_def) - apply (clarsimp simp: s0H_internal_def cdt_relation_def) - apply (clarsimp simp: descendants_of'_def) - apply (frule subtree_parent) - apply (drule subtree_mdb_next) - apply (case_tac "x = 0") - apply (cut_tac s0H_valid_pspace') - apply (simp add: valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def - parentOf_def isMDBParentOf_def kh0H_all_obj_def') - apply simp - apply (clarsimp simp: mdb_next_trancl_s0H) - apply (elim disjE, (clarsimp simp: parentOf_def isMDBParentOf_def kh0H_all_obj_def')+)[1] - apply (clarsimp simp: cdt_list_relation_def s0_internal_def exst0_def split: option.splits) - apply (clarsimp simp: next_slot_def) - apply (cut_tac p="(a, b)" and t="(const [])" and m="Map.empty" in next_not_child_NoneI) - apply fastforce - apply (simp add: next_sib_def) - apply (simp add: finite_depth_def) - apply simp - apply (clarsimp simp: revokable_relation_def) - apply (clarsimp simp: null_filter_def split: if_split_asm) - apply (drule s0_caps_of_state) - apply clarsimp - apply (elim disjE) - apply (clarsimp simp: s0H_internal_def s0_internal_def - cte_map_def' kh0H_all_obj_def' - split: if_split_asm)+ - apply (clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] - Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def) - apply ((clarsimp simp: cte_map_def' s0H_internal_def s0_internal_def, - clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] - Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def)+)[5] - apply (clarsimp simp: s0_internal_def s0H_internal_def arch_state0_def arch_state0H_def - arch_state_relation_def asid_high_bits_of_def asid_low_bits_def - High_asid_def Low_asid_def max_pt_level_def2 maxPTLevel_def comp_def - split: if_splits) - apply safe + apply (clarsimp simp: s0H_internal_def arch_state0H_def) + apply auto[1] + apply (drule kh0_SomeD, clarsimp simp: kh0_obj_def, clarsimp simp: kh0_def kh0_obj_def)+ + apply (drule kh0_SomeD, clarsimp simp: kh0_obj_def) + apply (clarsimp simp: s0H_internal_def cdt_relation_def) + apply (clarsimp simp: descendants_of'_def) + apply (frule subtree_parent) + apply (drule subtree_mdb_next) + apply (case_tac "x = 0") + apply (cut_tac s0H_valid_pspace') + apply (simp add: valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def + parentOf_def isMDBParentOf_def kh0H_all_obj_def') + apply simp + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE, (clarsimp simp: parentOf_def isMDBParentOf_def kh0H_all_obj_def')+)[1] + apply (clarsimp simp: cdt_list_relation_def s0_internal_def exst0_def split: option.splits) + apply (clarsimp simp: next_slot_def) + apply (cut_tac p="(a, b)" and t="(const [])" and m="Map.empty" in next_not_child_NoneI) + apply fastforce + apply (simp add: next_sib_def) + apply (simp add: finite_depth_def) + apply simp + apply (clarsimp simp: revokable_relation_def) + apply (clarsimp simp: null_filter_def split: if_split_asm) + apply (drule s0_caps_of_state) + apply clarsimp + apply (elim disjE) + apply (clarsimp simp: s0H_internal_def s0_internal_def + cte_map_def' kh0H_all_obj_def' + split: if_split_asm)+ + apply (clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] + Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def) + apply ((clarsimp simp: cte_map_def' s0H_internal_def s0_internal_def, + clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] + Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def)+)[5] + apply (clarsimp simp: s0_internal_def s0H_internal_def arch_state0_def arch_state0H_def + arch_state_relation_def asid_high_bits_of_def asid_low_bits_def + High_asid_def Low_asid_def max_pt_level_def2 maxPTLevel_def comp_def + split: if_splits) + apply safe + apply (rule ext) + apply clarsimp + apply (word_bitwise, fastforce) + apply (rule ext) - apply clarsimp - apply (word_bitwise, fastforce) - apply (rule ext) - apply (clarsimp split: if_splits) - subgoal for level - by (induct level; simp only: size_maxPTLevel[simplified maxPTLevel_def, symmetric] - bit0.size_inj max_pt_level_def2) - apply (clarsimp simp: s0_internal_def s0H_internal_def exst0_def cte_level_bits_def - interrupt_state_relation_def irq_state_relation_def) - apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def)+ + apply (clarsimp simp: vmid_for_asid_2'_def obind_def opt_map_def asid_pool_of'_def kh0H_all_obj_def vmids_of_pool'_def) + apply (clarsimp simp: s0_internal_def s0H_internal_def exst0_def cte_level_bits_def + interrupt_state_relation_def irq_state_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def)+ done definition @@ -3808,8 +4301,13 @@ lemma step_restrict_s0: apply (rule conjI) apply (simp only: ex_abs_def) apply (rule_tac x="s0_internal" in exI) + apply (subst pred_conj_def[where f=einvs]) apply (simp only: einvs_s0 s0_srel) - apply (simp add: s0H_internal_def valid_domain_list'_def) + apply (simp add: no_domain_caps_def) + apply (rule_tac x="s0_internal" in exI) + apply (clarsimp simp: domain_sep_inv_def F[symmetric]) + apply (drule s0_caps_of_state) + apply auto[1] apply (clarsimp simp: ct_in_state'_def st_tcb_at'_def obj_at'_def s0H_internal_def objBits_simps' s0_ptrs_aligned Low_tcbH_def) apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) From a6e5018bf21fb9245cd4f71b8d5e4550f6198129 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Wed, 10 Jun 2026 12:15:59 +1000 Subject: [PATCH 08/11] arm+riscv infoflow: proof update for infoflow changes Signed-off-by: Ryan Barry --- proof/infoflow/ARM/ArchADT_IF.thy | 146 +++++++++++++++--- proof/infoflow/ARM/ArchArch_IF.thy | 106 +++++-------- proof/infoflow/ARM/ArchCNode_IF.thy | 26 ++-- proof/infoflow/ARM/ArchFinalCaps.thy | 12 ++ proof/infoflow/ARM/ArchFinalise_IF.thy | 30 ++-- proof/infoflow/ARM/ArchIRQMasks_IF.thy | 5 +- proof/infoflow/ARM/ArchInfoFlow.thy | 8 + proof/infoflow/ARM/ArchInfoFlow_IF.thy | 107 ++++++++++++- proof/infoflow/ARM/ArchInterrupt_IF.thy | 4 +- proof/infoflow/ARM/ArchIpc_IF.thy | 11 +- proof/infoflow/ARM/ArchNoninterference.thy | 55 ++++++- proof/infoflow/ARM/ArchPasUpdates.thy | 2 +- proof/infoflow/ARM/ArchRetype_IF.thy | 99 ++++++------ proof/infoflow/ARM/ArchScheduler_IF.thy | 96 ++++++++++-- proof/infoflow/ARM/ArchSyscall_IF.thy | 2 +- proof/infoflow/ARM/ArchTcb_IF.thy | 4 +- proof/infoflow/ARM/ArchUserOp_IF.thy | 4 +- proof/infoflow/ARM/Example_Valid_State.thy | 4 +- proof/infoflow/RISCV64/ArchADT_IF.thy | 143 +++++++++++++++-- proof/infoflow/RISCV64/ArchArch_IF.thy | 71 +++------ proof/infoflow/RISCV64/ArchCNode_IF.thy | 28 ++-- proof/infoflow/RISCV64/ArchFinalCaps.thy | 12 ++ proof/infoflow/RISCV64/ArchFinalise_IF.thy | 30 ++-- proof/infoflow/RISCV64/ArchIRQMasks_IF.thy | 5 +- proof/infoflow/RISCV64/ArchInfoFlow.thy | 8 + proof/infoflow/RISCV64/ArchInfoFlow_IF.thy | 107 ++++++++++++- proof/infoflow/RISCV64/ArchInterrupt_IF.thy | 4 +- proof/infoflow/RISCV64/ArchIpc_IF.thy | 77 +++++---- .../infoflow/RISCV64/ArchNoninterference.thy | 55 ++++++- proof/infoflow/RISCV64/ArchPasUpdates.thy | 2 +- proof/infoflow/RISCV64/ArchRetype_IF.thy | 7 +- proof/infoflow/RISCV64/ArchScheduler_IF.thy | 92 ++++++++++- proof/infoflow/RISCV64/ArchSyscall_IF.thy | 2 +- proof/infoflow/RISCV64/ArchTcb_IF.thy | 4 +- proof/infoflow/RISCV64/ArchUserOp_IF.thy | 16 +- .../infoflow/RISCV64/Example_Valid_State.thy | 26 ++-- .../refine/ARM/ArchADT_IF_Refine_C.thy | 43 +++++- .../refine/RISCV64/ArchADT_IF_Refine_C.thy | 37 ++++- 38 files changed, 1118 insertions(+), 372 deletions(-) diff --git a/proof/infoflow/ARM/ArchADT_IF.thy b/proof/infoflow/ARM/ArchADT_IF.thy index 6bbf4e7fbd..d1b3f5b433 100644 --- a/proof/infoflow/ARM/ArchADT_IF.thy +++ b/proof/infoflow/ARM/ArchADT_IF.thy @@ -15,10 +15,78 @@ theory ArchADT_IF imports ADT_IF begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems ADT_IF_assms +lemma dmo_getActiveIRQ_wp'[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False st and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma dmo_getActiveIRQ_wp[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\))\ + do_machine_op (getActiveIRQ False) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma deleted_irq_handler_valid_irq_states[ADT_IF_assms,wp]: + "deleted_irq_handler irq \valid_irq_states\" + unfolding deleted_irq_handler_def set_irq_state_def valid_irq_states_def valid_irq_masks_def maskInterrupt_def + by (wpsimp wp: dmo_wp) + +lemma dmo_valid_irq_states[wp]: + "(\P. f \\s. P (irq_masks s)\) \ do_machine_op f \valid_irq_states\" + unfolding valid_irq_states_def do_machine_op_def + by (wpsimp, erule use_valid; assumption) + +lemma dmo_getActiveIRQ_valid_irq_states[ADT_IF_assms,wp]: + "do_machine_op (getActiveIRQ in_kernel) \valid_irq_states\" + unfolding getActiveIRQ_def by wpsimp + +lemmas [wp] = invalidateLocalTLB_ASID_irq_masks cleanCaches_PoU_irq_masks + setHardwareASID_irq_masks set_current_pd_irq_masks + +crunch prepare_thread_delete, arch_finalise_cap, arch_post_cap_deletion + for valid_irq_states[ADT_IF_assms,wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemmas [ADT_IF_assms] = + cur_hyp_in_cur_domain_taut + cur_fpu_in_cur_domain_taut + cur_hyp_in_cur_domain_wp + cur_fpu_in_cur_domain_wp + valid_cur_hyp_triv + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms | solves \wp only: ADT_IF_assms; simp\)?) +qed + + +context Arch begin arch_global_naming + lemma dmo_getExMonitor_wp[wp]: "\\s. P (exclusive_state (machine_state s)) s\ do_machine_op getExMonitor @@ -151,14 +219,14 @@ crunch init_arch_objects (wp: crunch_wps dmo_wp ignore: do_machine_op) lemma getActiveIRQ_None[ADT_IF_assms]: - "(None,s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) \ + "(None,s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) by simp lemma getActiveIRQ_Some[ADT_IF_assms]: - "(Some i, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some i, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) @@ -299,11 +367,18 @@ lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: | wps |wp dmo_wp | wpc)+ done -crunch set_flags +crunch set_flags, arch_post_set_flags for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" +lemma checked_cap_insert_valid_irq_states[wp]: + "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \valid_irq_states\" + by (wpsimp simp: check_cap_at_def)+ + +crunch set_mcpriority + for valid_irq_states[wp]: valid_irq_states + lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: - "\(\s. irq_state_inv st s) and domain_sep_inv False sta + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" @@ -314,10 +389,10 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | clarsimp | wp (once) irq_state_inv_triv)+)[3] defer - apply ((wp irq_state_inv_triv | simp)+)[2] - (* just ThreadControl left *) - apply (simp add: split_def cong: option.case_cong) - by (wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + apply ((wp irq_state_inv_triv | simp)+)[2] + apply (simp add: split_def cong: option.case_cong) + by (clarsimp split del: if_split cong: conj_cong + | wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R checked_cap_insert_domain_sep_inv cap_delete_deletes cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] @@ -329,19 +404,33 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | wp (once) irq_state_inv_triv hoare_drop_imps | clarsimp split: option.splits | intro impI conjI allI)+ +crunch freeMemory + for irq_masks[wp]: "\s. P (irq_masks s)" + (wp: mapM_x_wp) + +lemma valid_irq_states_kheap_update[simp]: + "valid_irq_states (kheap_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch delete_objects + for valid_irq_states[wp]: valid_irq_states + (wp: dmo_machine_state_lift simp: crunch_simps detype_def) + lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" apply (cases "irq_is_recurring irq st", simp_all) apply (simp add: reset_untyped_cap_def) apply (rule hoare_pre) - apply (wp no_irq_clearMemory mapME_x_wp' hoare_vcg_const_imp_lift - get_cap_wp preemption_point_irq_state_inv'[where irq=irq] - | rule irq_state_inv_triv - | simp add: unless_def - | wp (once) dmo_wp)+ - done + by (wp no_irq_clearMemory hoare_vcg_const_imp_lift set_cap_domain_sep_inv + hoare_post_addE[where Q'="domain_sep_inv False sta and valid_irq_states", OF mapME_x_wp'] + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule hoare_vcg_conj_lift + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp + | fastforce)+ crunch handle_vm_fault, handle_hypervisor_fault @@ -375,10 +464,31 @@ lemma thread_set_pas_refined[ADT_IF_assms]: | wps thread_set_caps_of_state_trivial[OF cps] thread_set_thread_st_auth_trivT[OF st] thread_set_thread_bound_ntfns_trivT[OF ntfn])+ + +lemma thread_set_context_state_hyp_refs_of: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \\s. P (state_hyp_refs_of s)\" + by (wpsimp simp: thread_set_def wp: set_object_wp ) + +lemma thread_set_context_pas_refined[ADT_IF_assms]: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" + unfolding pas_refined_def state_objs_to_policy_def + apply (rule hoare_weaken_pre) + apply (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_edomains) + apply (wps thread_set_state_vrefs thread_set_context_state_hyp_refs_of) + apply (rule hoare_lift_Pf2[where f="caps_of_state"]) + apply (rule hoare_lift_Pf2[where f="thread_st_auth"]) + apply (rule hoare_lift_Pf2[where f="thread_bound_ntfns"]) + apply wp + apply (wpsimp wp: thread_set_thread_bound_ntfns_trivT ) + apply (wpsimp wp: thread_set_thread_st_auth_trivT) + apply (wpsimp wp: thread_set_caps_of_state_trivial simp: ran_tcb_cap_cases) + apply simp + done + end -global_interpretation ADT_IF_1?: ADT_IF_1 +global_interpretation ADT_IF_2?: ADT_IF_2 proof goal_cases interpret Arch . case 1 show ?case @@ -387,7 +497,7 @@ qed sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. -hide_fact ADT_IF_1.do_user_op_silc_inv +hide_fact ADT_IF_2.do_user_op_silc_inv requalify_facts ARM.do_user_op_silc_inv declare do_user_op_silc_inv[wp] diff --git a/proof/infoflow/ARM/ArchArch_IF.thy b/proof/infoflow/ARM/ArchArch_IF.thy index 39e2151856..de89079c6b 100644 --- a/proof/infoflow/ARM/ArchArch_IF.thy +++ b/proof/infoflow/ARM/ArchArch_IF.thy @@ -110,11 +110,10 @@ lemma store_word_offs_reads_respects[Arch_IF_assms]: apply (simp add: storeWord_def) apply (simp add: do_machine_op_bind) apply wp - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad) apply (fastforce intro: equiv_forI elim: equiv_forE) - apply (rule use_spec_ev do_machine_op_spec_reads_respects assert_ev2 + apply (rule do_machine_op_reads_respects assert_ev2 | simp add: spec_equiv_valid_def | wp modify_wp)+ done @@ -143,24 +142,13 @@ lemma set_thread_state_globals_equiv[Arch_IF_assms]: split: option.splits kernel_object.splits)+ done -lemma set_cap_globals_equiv''[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def)+ - done - -lemma as_user_globals_equiv[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" - unfolding as_user_def - apply (wpsimp wp: set_object_globals_equiv simp: split_def) - apply (clarsimp simp: valid_arch_state_def get_tcb_def obj_at_def) - done +lemma thread_set_non_idle_globals_equiv[Arch_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + by (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def) declare arch_prepare_set_domain_inv[Arch_IF_assms] declare arch_prepare_next_domain_inv[Arch_IF_assms] @@ -185,7 +173,7 @@ global_interpretation Arch_IF_1?: Arch_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Arch_IF_assms)?) + by (unfold_locales; (fact Arch_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -773,11 +761,11 @@ lemma perform_page_invocation_reads_respects: apply (simp add: mapM_discarded swp_def) apply (wp dmo_mol_reads_respects dmo_cacheRangeOp_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects mapM_ev'' store_pde_reads_respects - unmap_page_reads_respects set_vm_root_reads_respects dmo_mol_2_reads_respects + unmap_page_reads_respects set_vm_root_reads_respects set_vm_root_for_flush_reads_respects get_cap_rev do_flush_reads_respects invalidate_tlb_by_asid_reads_respects get_master_pte_reads_respects get_master_pde_reads_respects set_mrs_reads_respects set_message_info_reads_respects - | simp add: cleanByVA_PoU_def pte_check_if_mapped_def pde_check_if_mapped_def + | simp add: cleanByVA_PoU_def pte_check_if_mapped_def pde_check_if_mapped_def dmo_distr | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ apply (clarsimp simp: authorised_page_inv_def valid_page_inv_def) apply (auto simp: cte_wp_at_caps_of_state valid_slots_def cap_auth_conferred_def @@ -1312,7 +1300,7 @@ lemma perform_page_table_invocation_globals_equiv: \\_. globals_equiv st\" unfolding perform_page_table_invocation_def cleanCacheRange_PoU_def apply (rule hoare_weaken_pre) - apply (wp store_pde_globals_equiv set_cap_globals_equiv'' dmo_cacheRangeOp_lift + apply (wp store_pde_globals_equiv set_cap_globals_equiv dmo_cacheRangeOp_lift mapM_x_swp_store_pte_globals_equiv unmap_page_table_globals_equiv | wpc | simp add: cleanByVA_PoU_def)+ apply (fastforce simp: authorised_for_globals_page_table_inv_def @@ -1491,7 +1479,7 @@ lemma perform_page_invocation_globals_equiv: apply (rule hoare_weaken_pre) apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift dmo_cacheRangeOp_lift mapM_swp_store_pde_globals_equiv mapM_x_swp_store_pte_globals_equiv - mapM_x_swp_store_pde_globals_equiv set_cap_globals_equiv'' + mapM_x_swp_store_pde_globals_equiv set_cap_globals_equiv unmap_page_globals_equiv store_pte_globals_equiv store_pde_globals_equiv hoare_weak_lift_imp do_flush_globals_equiv set_mrs_globals_equiv set_message_info_globals_equiv | wpc | simp add: do_machine_op_bind cleanByVA_PoU_def)+ @@ -1519,7 +1507,7 @@ lemma perform_asid_control_invocation_globals_equiv: apply (rule hoare_pre) apply wpc apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) - apply (wp modify_wp cap_insert_globals_equiv'' + apply (wp modify_wp cap_insert_globals_equiv retype_region_ASIDPoolObj_globals_equiv[simplified] retype_region_invs_extras(5)[where sz=pageBits] retype_region_invs_extras(6)[where sz=pageBits] @@ -1595,7 +1583,7 @@ lemma perform_asid_pool_invocation_globals_equiv: "\globals_equiv s and valid_arch_state\ perform_asid_pool_invocation api \\_. globals_equiv s\" unfolding perform_asid_pool_invocation_def apply (rule hoare_weaken_pre) - apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv get_cap_wp | wpc | simp)+ done @@ -1726,22 +1714,19 @@ lemma mapM_x_swp_store_pte_reads_respects': (mapM_x (swp store_pte InvalidPTE) [word , word + 4 .e. word + 2 ^ pt_bits - 1])" apply (rule gen_asm_ev) apply (wp mapM_x_ev) - apply simp - apply (rule equiv_valid_guard_imp) - apply (wp store_pte_reads_respects) - apply simp - apply (elim conjE) - apply (subgoal_tac "is_aligned word pt_bits") - apply (frule (1) word_aligned_pt_slots) apply simp - apply (frule cte_wp_valid_cap) - apply (rule invs_valid_objs) + apply (rule equiv_valid_guard_imp) + apply (wp store_pte_reads_respects) + apply clarsimp + apply (subgoal_tac "is_aligned word pt_bits") + apply (frule (1) word_aligned_pt_slots) + apply simp apply simp - apply (simp add: valid_cap_def cap_aligned_def pt_bits_def pageBits_def) - apply simp - apply wp - apply simp - apply (fastforce simp: is_cap_simps dest!: cte_wp_at_pt_exists_cap[OF invs_valid_objs]) + apply wpsimp+ + apply (frule cte_wp_valid_cap) + apply (rule invs_valid_objs) + apply simp + apply (simp add: valid_cap_def cap_aligned_def pt_bits_def pageBits_def) done lemma word_shiftr_20_le_1_shift_pageBits: @@ -1778,18 +1763,19 @@ lemma mapM_x_swp_store_pde_reads_respects': and K (is_subject aag w)) (mapM_x (swp store_pde InvalidPDE) (map ((\x. x + w) \ swp (<<) 2) [0 .e. (kernel_base >> 20) - 1]))" + apply (rule gen_asm_ev) apply (wp mapM_x_ev) - apply simp - apply (rule equiv_valid_guard_imp) - apply (wp store_pde_reads_respects) + apply simp + apply (rule equiv_valid_guard_imp) + apply (wp store_pde_reads_respects) + apply clarsimp + apply (subgoal_tac "is_aligned w pd_bits") + apply (clarsimp simp add: pd_bits_store_pde_helper) + apply simp + apply wpsimp+ + apply (frule cte_wp_valid_cap) apply clarsimp - apply (subgoal_tac "is_aligned w pd_bits") - apply (simp add: pd_bits_store_pde_helper) - apply (frule (1) cte_wp_valid_cap) - apply (simp add: valid_cap_def cap_aligned_def pd_bits_def pageBits_def) - apply simp - apply wp - apply (clarsimp simp: wellformed_pde_def)+ + apply (simp add: valid_cap_def cap_aligned_def pd_bits_def pageBits_def) done lemma mapM_x_swp_store_pte_pas_refined_simple: @@ -1834,14 +1820,10 @@ lemma thread_set_globals_equiv: end -hide_fact as_user_globals_equiv - -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts authorised_for_globals_arch_inv -requalify_facts +arch_requalify_facts arch_post_cap_deletion_valid_global_objs get_thread_state_globals_equiv auth_ipc_buffers_mem_Write' @@ -1851,11 +1833,7 @@ requalify_facts length_msg_lt_msg_max set_mrs_globals_equiv arch_perform_invocation_globals_equiv - as_user_globals_equiv - prepare_thread_delete_st_tcb_at_halted - make_arch_fault_msg_inv check_valid_ipc_buffer_inv - arch_tcb_update_aux2 arch_perform_invocation_reads_respects_g declare @@ -1865,10 +1843,6 @@ declare arch_post_modify_registers_cur_thread[wp] prepare_thread_delete_st_tcb_at_halted[wp] -end - -declare as_user_globals_equiv[wp] - axiomatization dmo_reads_respects where dmo_getDFSR_reads_respects: "reads_respects aag l \ (do_machine_op ARM.getDFSR)" and dmo_getFAR_reads_respects: "reads_respects aag l \ (do_machine_op ARM.getFAR)" and diff --git a/proof/infoflow/ARM/ArchCNode_IF.thy b/proof/infoflow/ARM/ArchCNode_IF.thy index 8d6647b00c..92bd020674 100644 --- a/proof/infoflow/ARM/ArchCNode_IF.thy +++ b/proof/infoflow/ARM/ArchCNode_IF.thy @@ -34,24 +34,14 @@ lemma set_object_globals_equiv'': \\_. globals_equiv s\" by (wpsimp wp: set_object_globals_equiv) -lemma set_cap_globals_equiv': - "\globals_equiv s and (\ s. fst p \ arm_global_pd (arch_state s))\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: obj_at_def is_tcb_def) - done - lemma set_cap_globals_equiv[CNode_IF_assms]: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" unfolding set_cap_def apply (simp only: split_def) apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: valid_global_objs_def valid_vso_at_def obj_at_def is_tcb_def) + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def)+ done (* moved from ADT_IF *) @@ -128,8 +118,7 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: notes gets_ev[wp del] shows "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects') + apply (rule do_machine_op_reads_respects') apply (simp add: getActiveIRQ_def) apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift @@ -138,6 +127,15 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: apply (rule only_timer_irq_inv_determines_irq_masks, blast+) done +lemma dmo_getActiveIRQ_globals_equiv[CNode_IF_assms]: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" + unfolding globals_equiv_def arch_globals_equiv_def idle_equiv_def + apply (rule hoare_weaken_pre) + apply wps + apply wpsimp + apply clarsimp + done + end diff --git a/proof/infoflow/ARM/ArchFinalCaps.thy b/proof/infoflow/ARM/ArchFinalCaps.thy index 6525f48c9d..e2b7b7a5d4 100644 --- a/proof/infoflow/ARM/ArchFinalCaps.thy +++ b/proof/infoflow/ARM/ArchFinalCaps.thy @@ -346,6 +346,10 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: | intro impI | rule conjI)+ +lemma handle_reserved_irq_non_kernel_IRQs[FinalCaps_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def by wpsimp + end @@ -356,4 +360,12 @@ proof goal_cases by (unfold_locales; (fact FinalCaps_assms)?) qed + +global_interpretation FinalCaps_3?: FinalCaps_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms | solves \wp only: FinalCaps_assms; simp\)?) +qed + end \ No newline at end of file diff --git a/proof/infoflow/ARM/ArchFinalise_IF.thy b/proof/infoflow/ARM/ArchFinalise_IF.thy index 6b0de4e7cf..4f19b278b5 100644 --- a/proof/infoflow/ARM/ArchFinalise_IF.thy +++ b/proof/infoflow/ARM/ArchFinalise_IF.thy @@ -19,8 +19,7 @@ crunch arch_post_cap_deletion lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" unfolding maskInterrupt_def - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: equiv_valid_def2) apply (rule modify_ev2) apply (fastforce simp: equiv_for_def) @@ -165,21 +164,16 @@ lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: done lemma thread_set_reads_respects[Finalise_IF_assms]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects aag l \ (thread_set x y)" - unfolding thread_set_def fun_app_def - apply (case_tac "aag_can_read aag y \ aag_can_affect aag l y") - apply (wp set_object_reads_respects) - apply (clarsimp, rule reads_affects_equiv_get_tcb_eq, simp+)[1] - apply (simp add: equiv_valid_def2) - apply (rule equiv_valid_rv_guard_imp) - apply (rule_tac L="{pasObjectAbs aag y}" and L'="{pasObjectAbs aag y}" - in ev2_invisible[OF domains_distinct]) - apply (assumption | simp add: labels_are_invisible_def)+ - apply (rule modifies_at_mostI[where P="\"] - | wp set_object_equiv_but_for_labels - | simp - | (clarify, drule get_tcb_not_asid_pool_at))+ + "reads_respects aag l \ (thread_set f thread)" + unfolding thread_set_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q=\ and ptr=thread in reads_respects_unit_cases) + apply (rule gen_asm_ev') + apply (wpsimp wp: set_object_reads_respects) + apply (wp set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def) + apply wpsimp + apply (auto intro: reads_affects_equiv_get_tcb_eq) done lemma aag_cap_auth_ASIDPoolCap: @@ -381,7 +375,7 @@ global_interpretation Finalise_IF_1?: Finalise_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Finalise_IF_assms)?) + by (unfold_locales; (fact Finalise_IF_assms | solves \wp only: Finalise_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/ARM/ArchIRQMasks_IF.thy b/proof/infoflow/ARM/ArchIRQMasks_IF.thy index ffaf96a87d..657226cef9 100644 --- a/proof/infoflow/ARM/ArchIRQMasks_IF.thy +++ b/proof/infoflow/ARM/ArchIRQMasks_IF.thy @@ -163,6 +163,9 @@ lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: crunch arch_prepare_set_domain for inv[IRQMasks_IF_assms,wp]: P +crunch arch_prepare_next_domain + for valid_irq_states[IRQMasks_IF_assms,wp]: valid_irq_states + end @@ -170,7 +173,7 @@ global_interpretation IRQMasks_IF_2?: IRQMasks_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact IRQMasks_IF_assms)?) + by (unfold_locales; (fact IRQMasks_IF_assms | solves \wp only: IRQMasks_IF_assms; simp\)?) qed diff --git a/proof/infoflow/ARM/ArchInfoFlow.thy b/proof/infoflow/ARM/ArchInfoFlow.thy index 073faff05d..8ea5654145 100644 --- a/proof/infoflow/ARM/ArchInfoFlow.thy +++ b/proof/infoflow/ARM/ArchInfoFlow.thy @@ -10,6 +10,8 @@ imports "Lib.EquivValid" begin +consts equiv_for :: "('a \ bool) \ ('b \ 'a \ 'c) \ 'b \ 'b \ bool" + context Arch begin global_naming ARM section \Arch-specific equivalence properties\ @@ -66,6 +68,12 @@ definition arch_globals_equiv :: "obj_ref \ obj_ref \ kh declare arch_globals_equiv_def[simp] +definition equiv_hyp :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_hyp P s s' \ True" + +definition equiv_fpu :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_fpu P s s' \ True" + end context begin interpretation Arch . diff --git a/proof/infoflow/ARM/ArchInfoFlow_IF.thy b/proof/infoflow/ARM/ArchInfoFlow_IF.thy index 5430ea10b3..480c25dc34 100644 --- a/proof/infoflow/ARM/ArchInfoFlow_IF.thy +++ b/proof/infoflow/ARM/ArchInfoFlow_IF.thy @@ -82,6 +82,72 @@ lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" by (auto simp: equiv_asids_def) + +definition identical_hyp_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_hyp_state_updates _ _ _ _ _ \ True" + +definition identical_fpu_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_fpu_state_updates _ _ _ _ _ \ True" + +definition no_hyp :: "'m machine_monad \ bool" where + "no_hyp f \ True" + +definition no_fpu :: "'m machine_monad \ bool" where + "no_fpu f \ True" + +lemma equiv_hyp_taut[intro!,simp]: + "equiv_hyp P s s'" + "equiv_hyp P st s = equiv_hyp P' st' s'" + by (simp_all add: equiv_hyp_def) + +lemma equiv_fpu_taut[intro!,simp]: + "equiv_fpu P s s'" + "equiv_fpu P st s = equiv_fpu P' st' s'" + by (simp_all add: equiv_fpu_def) + +lemma identical_hyp_states_updates_taut[intro!,simp]: + "identical_hyp_state_updates P s s' ms ms'" + by (simp add: identical_hyp_state_updates_def) + +lemma identical_fpu_states_updates_taut[intro!,simp]: + "identical_fpu_state_updates P s s' ms ms'" + by (simp add: identical_fpu_state_updates_def) + +lemma no_hyp_taut[intro!,simp]: + "no_hyp f" + by (simp add: no_hyp_def) + +lemma no_fpu_taut[intro!,simp]: + "no_fpu f" + by (simp add: no_fpu_def) + +lemmas equiv_arch_taut = + equiv_hyp_taut + equiv_fpu_taut + identical_hyp_states_updates_taut + identical_fpu_states_updates_taut + no_hyp_taut + no_fpu_taut + +end + +arch_requalify_consts + identical_hyp_state_updates + identical_fpu_state_updates + no_hyp + no_fpu + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 identical_hyp_state_updates identical_fpu_state_updates +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) +qed + + +context Arch begin arch_global_naming + lemma dmo_loadWord_rev[InfoFlow_IF_assms]: "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) (do_machine_op (loadWord p))" @@ -107,14 +173,51 @@ lemma dmo_loadWord_rev[InfoFlow_IF_assms]: apply (wp wp_post_taut loadWord_inv | simp)+ done +lemma do_machine_op_reads_respects'[InfoFlow_IF_assms]: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f" + assumes guard: + "\s. P s \ Q (machine_state s)" + and no_hyp: "no_hyp f" + and no_fpu: "no_fpu f" + shows + "reads_respects aag l P (do_machine_op f)" + apply (rule use_spec_ev) + unfolding do_machine_op_def spec_equiv_valid_def + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv' \ + equiv_irq_state rv rv'" + and Q="\r s. st = s \ Q r" and Q'="\ r s. Q r" and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r,ms') (r',ms''). r = r' \ + equiv_machine_state (aag_can_read aag) ms' ms'' \ + equiv_machine_state (aag_can_affect aag l) ms' ms'' \ + equiv_irq_state ms' ms''" + and Q="\r s. st = s" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or split_def equiv_for_def)[1] + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) + apply (fastforce) + apply (rule select_f_inv) + apply (rule wp_post_taut) + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (wp | simp add: guard)+ + done + end -global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_2 identical_hyp_state_updates identical_fpu_state_updates no_hyp no_fpu proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact InfoFlow_IF_assms)?) + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) qed end diff --git a/proof/infoflow/ARM/ArchInterrupt_IF.thy b/proof/infoflow/ARM/ArchInterrupt_IF.thy index 73a08f219e..364ee831f2 100644 --- a/proof/infoflow/ARM/ArchInterrupt_IF.thy +++ b/proof/infoflow/ARM/ArchInterrupt_IF.thy @@ -40,12 +40,12 @@ lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: done lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" apply (induct ai; wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs - cap_insert_globals_equiv'' dmo_mol_globals_equiv + cap_insert_globals_equiv dmo_mol_globals_equiv simp: setIRQTrigger_def) done diff --git a/proof/infoflow/ARM/ArchIpc_IF.thy b/proof/infoflow/ARM/ArchIpc_IF.thy index d76b74d895..0fc0d25aff 100644 --- a/proof/infoflow/ARM/ArchIpc_IF.thy +++ b/proof/infoflow/ARM/ArchIpc_IF.thy @@ -54,6 +54,7 @@ lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply auto[2] apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) done @@ -203,9 +204,7 @@ lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) (do_machine_op (loadWord p))" apply (rule gen_asm_ev) - apply (rule use_spec_ev) - apply (rule spec_equiv_valid_hoist_guard) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) @@ -288,7 +287,7 @@ global_interpretation Ipc_IF_1?: Ipc_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Ipc_IF_assms)?) + by (unfold_locales; (fact Ipc_IF_assms | solves \wp only: Ipc_IF_assms; simp\)?) qed @@ -442,7 +441,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_guard_imp) apply (case_tac buf) - apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in ev_invisible[OF domains_distinct]) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in revrv_invisible[OF domains_distinct]) apply (clarsimp simp: labels_are_invisible_def) apply (rule modifies_at_mostI) apply (simp add: set_mrs_def) @@ -452,7 +451,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (rename_tac buf') apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) ` (ptr_range buf' msg_align_bits)" - in ev_invisible[OF domains_distinct]) + in revrv_invisible[OF domains_distinct]) apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] apply (rule modifies_at_mostI) diff --git a/proof/infoflow/ARM/ArchNoninterference.thy b/proof/infoflow/ARM/ArchNoninterference.thy index 45933ae086..52db56880b 100644 --- a/proof/infoflow/ARM/ArchNoninterference.thy +++ b/proof/infoflow/ARM/ArchNoninterference.thy @@ -257,6 +257,7 @@ lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def) apply (rule affects_equiv_machine_state_update, assumption) apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def) + apply auto[2] apply (simp add: equiv_valid_def2 equiv_valid_2_def) done @@ -275,6 +276,7 @@ lemma dmo_clearExMonitor_reads_respects_g': apply (simp add: reads_equiv_g_def reads_equiv_def2 affects_equiv_def2 globals_equiv_def idle_equiv_def states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def) apply metis + apply simp done lemma arch_switch_to_thread_reads_respects_g'[Noninterference_assms]: @@ -423,6 +425,56 @@ lemma arch_tcb_get_registers_equality[Noninterference_assms]: \ tcb_arch tcb = tcb_arch tcb'" by (auto simp: arch_tcb_get_registers_def intro: arch_tcb.equality user_context.expand) +lemma getActiveIRQ_ev2[Noninterference_assms]: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + apply (simp add: getActiveIRQ_no_non_kernel_IRQs) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid, rule dmo_getActiveIRQ_wp)+ + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def irq_at_def Let_def) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI impI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + done + +lemma arch_prepare_next_domain_reads_respects_g[Noninterference_assms]: + "reads_respects_g aag l invs arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def by wpsimp + +lemma partitionIntegrity_subjectAffects_tcb_fpu[Noninterference_assms]: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (TCB tcb)" + "kheap s' x = Some (TCB tcb')" + "tcb' = tcb\tcb_arch := new_arch\" + "arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb)" + "tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (insert assms(2,3,4,5,7)) + apply (clarsimp simp: arch_tcb_get_registers_def) + apply (subgoal_tac "new_arch = tcb_arch tcb") + apply clarsimp + apply (rule arch_tcb.equality; clarsimp?) + apply (rule user_context.expand; clarsimp) + done + end context begin interpretation Arch . @@ -437,7 +489,8 @@ global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\)?) + by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\ + | solves \wp only: Noninterference_assms; simp\)?) qed sublocale valid_initial_state \ valid_initial_state?: diff --git a/proof/infoflow/ARM/ArchPasUpdates.thy b/proof/infoflow/ARM/ArchPasUpdates.thy index 93d97b720a..d7997f7db4 100644 --- a/proof/infoflow/ARM/ArchPasUpdates.thy +++ b/proof/infoflow/ARM/ArchPasUpdates.thy @@ -81,7 +81,7 @@ declare arch_prepare_set_domain_inv[PasUpdates_assms] end -global_interpretation PasUpdates_2?: PasUpdates_2 +global_interpretation PasUpdates_2?: PasUpdates_1 proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/ARM/ArchRetype_IF.thy b/proof/infoflow/ARM/ArchRetype_IF.thy index 703841e13c..53f81ecc05 100644 --- a/proof/infoflow/ARM/ArchRetype_IF.thy +++ b/proof/infoflow/ARM/ArchRetype_IF.thy @@ -82,11 +82,6 @@ lemma dmo_cacheRangeOp_reads_respects: apply (rule hoare_TrueI) done -lemma dmo_cleanCacheRange_PoU_reads_respects: - "reads_respects aag l \ (do_machine_op (cleanCacheRange_PoU vsrat vend pstart))" - unfolding cleanCacheRange_PoU_def - by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects | simp add: cleanByVA_PoU_def)+ - lemma set_pd_globals_equiv: "\globals_equiv st and (\s. a \ arm_global_pd (arch_state s))\ set_pd a b \\_. globals_equiv st\" unfolding set_pd_def @@ -181,7 +176,8 @@ lemma copy_global_mappings_reads_respects_g: pspace_aligned s \ valid_arch_state s" in hoare_weaken_pre) apply (rule gets_sp) apply (assumption) - apply (wp mapM_x_ev store_pde_reads_respects_g get_pde_revg) + apply (rule mapM_x_ev) + apply (wp mapM_x_ev store_pde_reads_respects_g get_pde_revg) apply (drule subsetD[OF copy_global_mappings_index_subset]) apply (clarsimp simp: pd_shifting' invs_aligned_pdD) apply (wp get_pde_inv store_pde_aligned store_pde_valid_arch | simp | fastforce)+ @@ -220,33 +216,12 @@ lemma dmo_cleanCacheRange_PoU_globals_equiv: unfolding cleanCacheRange_PoU_def by (wp dmo_mol_globals_equiv dmo_cacheRangeOp_lift | simp add: cleanByVA_PoU_def)+ -lemma dmo_cleanCacheRange_PoU_reads_respects_g: - "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_PoU x y z))" - apply (rule equiv_valid_guard_imp[OF reads_respects_g]) - apply (rule dmo_cleanCacheRange_PoU_reads_respects) - apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv]) - by simp - lemma dmo_cleanCacheRange_RAM_globals_equiv: "do_machine_op (cleanCacheRange_RAM x y z) \globals_equiv s\" unfolding cleanCacheRange_RAM_def by (wpsimp wp: dmo_mol_globals_equiv dmo_cacheRangeOp_lift simp: dmo_bind_valid dsb_def cleanCacheRange_PoC_def cleanByVA_def cleanL2Range_def) -lemma dmo_cleanCacheRange_RAM_reads_respects: - "reads_respects aag l \ (do_machine_op (cleanCacheRange_RAM vsrat vend pstart))" - unfolding cleanCacheRange_RAM_def - by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects empty_fail_cleanByVA empty_fail_cacheRangeOp - | simp add: cleanL2Range_def dsb_def cleanCacheRange_PoC_def cleanByVA_def - | subst do_machine_op_bind)+ - -lemma dmo_cleanCacheRange_RAM_reads_respects_g: - "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_RAM x y z))" - apply (rule equiv_valid_guard_imp[OF reads_respects_g]) - apply (rule dmo_cleanCacheRange_RAM_reads_respects) - apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv]) - by simp - lemma mol_globals_equiv: "machine_op_lift mop \\ms. globals_equiv st (s\machine_state := ms\)\" unfolding machine_op_lift_def @@ -283,26 +258,6 @@ lemma dmo_freeMemory_globals_equiv[Retype_IF_assms]: apply (simp_all) done -lemma init_arch_objects_reads_respects_g: - "reads_respects_g aag l ((\s. arm_global_pd (arch_state s) \ set refs \ - pspace_aligned s \ valid_arch_state s) and - K (\x\set refs. is_subject aag x) and - K (\x\set refs. new_type = ArchObject PageDirectoryObj - \ is_aligned x pd_bits) and - K ((0::obj_ref) < of_nat num_objects)) - (init_arch_objects new_type dev ptr num_objects obj_sz refs)" - apply (unfold init_arch_objects_def fun_app_def) - apply (rule gen_asm_ev)+ - apply (rule equiv_valid_guard_imp) - apply (wp dmo_cleanCacheRange_RAM_reads_respects_g - dmo_cleanCacheRange_PoU_reads_respects_g - mapM_x_ev'' when_ev - equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] - copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned - hoare_vcg_ball_lift | wpc | simp)+ - apply clarsimp - done - lemma copy_global_mappings_globals_equiv: "\globals_equiv s and (\s. x \ arm_global_pd (arch_state s) \ is_aligned x pd_bits)\ copy_global_mappings x @@ -428,7 +383,7 @@ global_interpretation Retype_IF_1?: Retype_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Retype_IF_assms)?) + by (unfold_locales; (fact Retype_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -499,7 +454,6 @@ lemma reset_untyped_cap_reads_respects_g: apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def invs_valid_global_objs) apply (simp add: aligned_add_aligned is_aligned_shiftl) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (rule hoare_pre) apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] @@ -549,6 +503,52 @@ lemma retype_region_ret_pd_aligned: apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def) done +lemma dmo_cleanCacheRange_PoU_reads_respects: + "reads_respects aag l \ (do_machine_op (cleanCacheRange_PoU vsrat vend pstart))" + unfolding cleanCacheRange_PoU_def + by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects | simp add: cleanByVA_PoU_def)+ + +lemma dmo_cleanCacheRange_PoU_reads_respects_g: + "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_PoU x y z))" + apply (rule equiv_valid_guard_imp[OF reads_respects_g]) + apply (rule dmo_cleanCacheRange_PoU_reads_respects) + apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv]) + by simp + +lemma dmo_cleanCacheRange_RAM_reads_respects: + "reads_respects aag l \ (do_machine_op (cleanCacheRange_RAM vsrat vend pstart))" + unfolding cleanCacheRange_RAM_def + by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects empty_fail_cleanByVA empty_fail_cacheRangeOp + | simp add: cleanL2Range_def dsb_def cleanCacheRange_PoC_def cleanByVA_def + | subst do_machine_op_bind)+ + +lemma dmo_cleanCacheRange_RAM_reads_respects_g: + "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_RAM x y z))" + apply (rule equiv_valid_guard_imp[OF reads_respects_g]) + apply (rule dmo_cleanCacheRange_RAM_reads_respects) + apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv]) + by simp + +lemma init_arch_objects_reads_respects_g: + "reads_respects_g aag l ((\s. arm_global_pd (arch_state s) \ set refs \ + pspace_aligned s \ valid_arch_state s) and + K (\x\set refs. is_subject aag x) and + K (\x\set refs. new_type = ArchObject PageDirectoryObj + \ is_aligned x pd_bits) and + K ((0::obj_ref) < of_nat num_objects)) + (init_arch_objects new_type dev ptr num_objects obj_sz refs)" + apply (unfold init_arch_objects_def fun_app_def) + apply (rule gen_asm_ev)+ + apply (rule equiv_valid_guard_imp) + apply (wp dmo_cleanCacheRange_RAM_reads_respects_g + dmo_cleanCacheRange_PoU_reads_respects_g + mapM_x_ev'' when_ev + equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] + copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned + hoare_vcg_ball_lift | wpc | simp)+ + apply clarsimp + done + lemma invoke_untyped_reads_respects_g_wcap[Retype_IF_assms]: notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost @@ -691,7 +691,6 @@ lemma reset_untyped_cap_globals_equiv: apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] cap_aligned_def bits_of_def free_index_of_def) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (strengthen invs_valid_global_objs invs_arch_state) apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def diff --git a/proof/infoflow/ARM/ArchScheduler_IF.thy b/proof/infoflow/ARM/ArchScheduler_IF.thy index b78cdfe9ce..363a99bc29 100644 --- a/proof/infoflow/ARM/ArchScheduler_IF.thy +++ b/proof/infoflow/ARM/ArchScheduler_IF.thy @@ -131,6 +131,7 @@ lemma equiv_asid_equiv_update[Scheduler_IF_assms]: by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) declare arch_prepare_next_domain_inv[Scheduler_IF_assms] +declare arch_activate_idle_thread_domain_fields_invs[Scheduler_IF_assms] end @@ -148,7 +149,7 @@ global_interpretation Scheduler_IF_1?: proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed @@ -234,7 +235,7 @@ lemma ev_asahi_to_asahi_ex_dmo_clearExMonitor: apply (rule conjI) apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def silc_dom_equiv_def equiv_for_def) - apply (clarsimp simp: midstrength_scheduler_affects_equiv_def asahi_scheduler_affects_equiv_def + apply (auto simp: midstrength_scheduler_affects_equiv_def asahi_scheduler_affects_equiv_def asahi_ex_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def arch_scheduler_affects_equiv_def equiv_asids_def equiv_asid_def scheduler_globals_frame_equiv_def @@ -255,8 +256,8 @@ lemma store_cur_thread_fragment_midstrength_reads_respects: apply simp done -lemma arch_switch_to_thread_globals_equiv_scheduler': - "\invs and globals_equiv_scheduler sta\ +lemma set_vm_root_globals_equiv_scheduler: + "\valid_arch_state and globals_equiv_scheduler sta\ set_vm_root t \\_. globals_equiv_scheduler sta\" by (rule globals_equiv_scheduler_inv', wpsimp) @@ -270,7 +271,7 @@ lemma reads_respects_scheduler_clearExMonitor[wp]: apply (rule conjI) apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def silc_dom_equiv_def equiv_for_def) - apply (clarsimp simp: scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + apply (auto simp: scheduler_affects_equiv_def arch_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def scheduler_globals_frame_equiv_def simp del: split_paired_All) @@ -318,11 +319,11 @@ lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_as done lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" unfolding arch_switch_to_idle_thread_def storeWord_def - by (wp dmo_wp modify_wp thread_get_wp' arch_switch_to_thread_globals_equiv_scheduler') + by (wp dmo_wp modify_wp thread_get_wp' set_vm_root_globals_equiv_scheduler) lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and @@ -371,6 +372,19 @@ lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: states_equiv_for_def idle_equiv_def) done +lemma arch_switch_to_idle_thread_midstrength_reads_respects[Scheduler_IF_assms]: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + apply (rule equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift') + apply (wpsimp wp: silc_dom_lift)+ + apply assumption + apply (wp midstrength_scheduler_affects_equiv_unobservable + | simp | wps)+ + apply (auto simp: scheduler_equiv_sym midstrength_scheduler_affects_equiv_sym) + done + lemma resetTimer_exclusive_state[wp]: "resetTimer \\s. P (exclusive_state s)\" by (wpsimp simp: resetTimer_def wp: mol_exclusive_state) @@ -438,6 +452,32 @@ lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: apply simp+ done +lemma thread_set_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" + apply (rule gen_asm_ev) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + unfolding thread_set_def gets_the_def gets_def get_def return_def assert_opt_def fail_def set_object_def get_object_def assert_def put_def + apply (clarsimp simp: bind_def split: option.splits if_splits) + apply (clarsimp simp: get_tcb_ko_at obj_at_def) + unfolding valid_tcb_context_update_def + apply (rename_tac s' tcb tcb') + apply (erule_tac x=tcb in allE) + apply (erule_tac x=tcb' in allE) + apply (rule conjI) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def) + apply (intro conjI) + apply (clarsimp simp: arch_globals_equiv_scheduler_def) + apply (clarsimp simp: idle_equiv_def tcb_at_def get_tcb_def arch_tcb_context_get_def) + apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI; clarsimp?) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def arch_scheduler_affects_equiv_def) + done + lemma set_object_reads_respects_scheduler[Scheduler_IF_assms, wp]: "reads_respects_scheduler aag l \ (set_object ptr obj)" unfolding equiv_valid_def2 equiv_valid_2_def @@ -456,15 +496,53 @@ lemma arch_prepare_next_domain_ev[Scheduler_IF_assms]: "equiv_valid_inv I A (\_. True) arch_prepare_next_domain" unfolding arch_prepare_next_domain_def by wp +lemma arch_switch_to_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_thread t \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + +lemma arch_switch_to_idle_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_idle_thread \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + +definition cur_hyp_in_cur_domain :: "det_state \ bool" where + "cur_hyp_in_cur_domain s \ True" + +definition cur_fpu_in_cur_domain :: "det_state \ bool" where + "cur_fpu_in_cur_domain s \ True" + +lemma cur_hyp_in_cur_domain_taut[intro!,simp]: + "cur_hyp_in_cur_domain s" + "cur_hyp_in_cur_domain s = cur_hyp_in_cur_domain s'" + by (simp_all add: cur_hyp_in_cur_domain_def) + +lemma cur_fpu_in_cur_domain_taut[intro!,simp]: + "cur_fpu_in_cur_domain s" + "cur_fpu_in_cur_domain s = cur_fpu_in_cur_domain s'" + by (simp_all add: cur_fpu_in_cur_domain_def) + +lemma cur_hyp_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_hyp_in_cur_domain\" + unfolding cur_hyp_in_cur_domain_def by wp + +lemma cur_fpu_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_fpu_in_cur_domain\" + unfolding cur_fpu_in_cur_domain_def by wp + +declare pas_wellformed_noninterference_domains_distinct[Scheduler_IF_assms] + end +arch_requalify_consts + cur_hyp_in_cur_domain + cur_fpu_in_cur_domain + global_interpretation Scheduler_IF_2?: - Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv _ cur_hyp_in_cur_domain cur_fpu_in_cur_domain proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed diff --git a/proof/infoflow/ARM/ArchSyscall_IF.thy b/proof/infoflow/ARM/ArchSyscall_IF.thy index de737f91b9..6ebcc38d1c 100644 --- a/proof/infoflow/ARM/ArchSyscall_IF.thy +++ b/proof/infoflow/ARM/ArchSyscall_IF.thy @@ -189,7 +189,7 @@ global_interpretation Syscall_IF_1?: Syscall_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_IF_assms)?) + by (unfold_locales; (fact Syscall_IF_assms | solves \wp only: Syscall_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/ARM/ArchTcb_IF.thy b/proof/infoflow/ARM/ArchTcb_IF.thy index e26ad55331..8db4aeb460 100644 --- a/proof/infoflow/ARM/ArchTcb_IF.thy +++ b/proof/infoflow/ARM/ArchTcb_IF.thy @@ -76,7 +76,7 @@ global_interpretation Tcb_IF_1?: Tcb_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed @@ -255,7 +255,7 @@ global_interpretation Tcb_IF_2?: Tcb_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/ARM/ArchUserOp_IF.thy b/proof/infoflow/ARM/ArchUserOp_IF.thy index 394b5ac167..f59db01978 100644 --- a/proof/infoflow/ARM/ArchUserOp_IF.thy +++ b/proof/infoflow/ARM/ArchUserOp_IF.thy @@ -124,7 +124,7 @@ global_interpretation UserOp_IF_1?: UserOp_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact UserOp_IF_assms)?) + by (unfold_locales; (fact UserOp_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -919,6 +919,8 @@ lemma dmo_getExMonitor_reads_respects_g: "reads_respects_g aag l (\s. cur_thread s \ idle_thread s) (do_machine_op getExMonitor)" apply (simp add: getExMonitor_def) apply (wp dmo_ev gets_ev'') + prefer 2 + apply assumption apply (clarsimp simp: reads_equiv_g_def globals_equiv_def) done diff --git a/proof/infoflow/ARM/Example_Valid_State.thy b/proof/infoflow/ARM/Example_Valid_State.thy index 106b75d233..09cb287cdb 100644 --- a/proof/infoflow/ARM/Example_Valid_State.thy +++ b/proof/infoflow/ARM/Example_Valid_State.thy @@ -1167,7 +1167,7 @@ lemma domain_sep_inv_s0: "domain_sep_inv False s0_internal s0_internal" apply (clarsimp simp: domain_sep_inv_def) apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state - | rule conjI allI | clarsimp simp: s0_internal_def)+ + | rule conjI allI | clarsimp simp: s0_internal_def non_kernel_IRQs_def)+ done lemma only_timer_irq_inv_s0: @@ -1833,7 +1833,7 @@ lemma Sys1_valid_initial_state_noenabled: apply (simp add: only_timer_irq_inv_s0 silc_inv_s0 Sys1_pas_cur_domain domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain idle_equiv_refl) - apply (clarsimp simp: obj_valid_pdpt_kh0 valid_domain_list_2_def s0_internal_def exst0_def) + apply (clarsimp simp: obj_valid_pdpt_kh0 valid_domain_list_2_def s0_internal_def exst0_def valid_cur_hyp_def) apply (simp add: det_inv_s0) apply (simp add: s0_internal_def exst0_def) apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq diff --git a/proof/infoflow/RISCV64/ArchADT_IF.thy b/proof/infoflow/RISCV64/ArchADT_IF.thy index db5d01afec..7ec47b1afc 100644 --- a/proof/infoflow/RISCV64/ArchADT_IF.thy +++ b/proof/infoflow/RISCV64/ArchADT_IF.thy @@ -19,6 +19,74 @@ context Arch begin global_naming RISCV64 named_theorems ADT_IF_assms +lemma dmo_getActiveIRQ_wp'[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False st and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma dmo_getActiveIRQ_wp[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\))\ + do_machine_op (getActiveIRQ False) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma deleted_irq_handler_valid_irq_states[ADT_IF_assms,wp]: + "deleted_irq_handler irq \valid_irq_states\" + unfolding deleted_irq_handler_def set_irq_state_def valid_irq_states_def valid_irq_masks_def maskInterrupt_def + by (wpsimp wp: dmo_wp) + +lemma dmo_valid_irq_states[ADT_IF_assms,wp]: + "(\P. f \\s. P (irq_masks s)\) \ do_machine_op f \valid_irq_states\" + unfolding valid_irq_states_def do_machine_op_def + by (wpsimp, erule use_valid; assumption) + +lemma dmo_getActiveIRQ_valid_irq_states[ADT_IF_assms,wp]: + "do_machine_op (getActiveIRQ in_kernel) \valid_irq_states\" + unfolding getActiveIRQ_def by wpsimp + +crunch setVSpaceRoot, sfence, hwASIDFlush + for irq_masks[wp]: "\s. P (irq_masks s)" + +crunch prepare_thread_delete, arch_finalise_cap, arch_post_cap_deletion + for valid_irq_states[ADT_IF_assms,wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemmas [ADT_IF_assms] = + cur_hyp_in_cur_domain_taut + cur_fpu_in_cur_domain_taut + cur_hyp_in_cur_domain_wp + cur_fpu_in_cur_domain_wp + valid_cur_hyp_triv + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms | solves \wp only: ADT_IF_assms; simp\)?) +qed + + +context Arch begin global_naming RISCV64 + (* FIXME: clagged from AInvs.do_user_op_invs *) lemma do_user_op_if_invs[ADT_IF_assms]: "\invs and ct_running\ @@ -100,14 +168,14 @@ lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: by (cases a; wpsimp) lemma getActiveIRQ_None[ADT_IF_assms]: - "(None,s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) \ + "(None,s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) by simp lemma getActiveIRQ_Some[ADT_IF_assms]: - "(Some i, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some i, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) @@ -229,11 +297,18 @@ lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: | wps |wp dmo_wp | wpc)+ done -crunch set_flags +crunch set_flags, arch_post_set_flags for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" +lemma checked_cap_insert_valid_irq_states[wp]: + "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \valid_irq_states\" + by (wpsimp simp: check_cap_at_def)+ + +crunch set_mcpriority + for valid_irq_states[wp]: valid_irq_states + lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: - "\(\s. irq_state_inv st s) and domain_sep_inv False sta + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" @@ -246,7 +321,8 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: defer apply ((wp irq_state_inv_triv | simp)+)[2] apply (simp add: split_def cong: option.case_cong) - by (wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + by (clarsimp split del: if_split cong: conj_cong + | wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R checked_cap_insert_domain_sep_inv cap_delete_deletes cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] @@ -258,19 +334,33 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | wp (once) irq_state_inv_triv hoare_drop_imps | clarsimp split: option.splits | intro impI conjI allI)+ +crunch freeMemory + for irq_masks[wp]: "\s. P (irq_masks s)" + (wp: mapM_x_wp) + +lemma valid_irq_states_kheap_update[simp]: + "valid_irq_states (kheap_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch delete_objects + for valid_irq_states[wp]: valid_irq_states + (wp: dmo_machine_state_lift simp: crunch_simps detype_def) + lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" apply (cases "irq_is_recurring irq st", simp_all) apply (simp add: reset_untyped_cap_def) apply (rule hoare_pre) - apply (wp no_irq_clearMemory mapME_x_wp' hoare_vcg_const_imp_lift - get_cap_wp preemption_point_irq_state_inv'[where irq=irq] - | rule irq_state_inv_triv - | simp add: unless_def - | wp (once) dmo_wp)+ - done + by (wp no_irq_clearMemory hoare_vcg_const_imp_lift set_cap_domain_sep_inv + hoare_post_addE[where Q'="domain_sep_inv False sta and valid_irq_states", OF mapME_x_wp'] + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule hoare_vcg_conj_lift + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp + | fastforce)+ crunch handle_vm_fault, handle_hypervisor_fault @@ -305,20 +395,43 @@ lemma thread_set_pas_refined[ADT_IF_assms]: thread_set_thread_st_auth_trivT[OF st] thread_set_thread_bound_ntfns_trivT[OF ntfn])+ + +lemma thread_set_context_state_hyp_refs_of: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \\s. P (state_hyp_refs_of s)\" + by (wpsimp simp: thread_set_def wp: set_object_wp ) + +lemma thread_set_context_pas_refined[ADT_IF_assms]: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" + unfolding pas_refined_def state_objs_to_policy_def + apply (rule hoare_weaken_pre) + apply (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_edomains) + apply (wps thread_set_state_vrefs thread_set_context_state_hyp_refs_of) + apply (rule hoare_lift_Pf2[where f="caps_of_state"]) + apply (rule hoare_lift_Pf2[where f="thread_st_auth"]) + apply (rule hoare_lift_Pf2[where f="thread_bound_ntfns"]) + apply wp + apply (wpsimp wp: thread_set_thread_bound_ntfns_trivT ) + apply (wpsimp wp: thread_set_thread_st_auth_trivT) + apply (wpsimp wp: thread_set_caps_of_state_trivial simp: ran_tcb_cap_cases) + apply simp + done + +declare init_arch_objects_inv[ADT_IF_assms] + end -global_interpretation ADT_IF_1?: ADT_IF_1 +global_interpretation ADT_IF_2?: ADT_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact ADT_IF_assms | wp init_arch_objects_inv)?) + by (unfold_locales; (fact ADT_IF_assms)?) qed sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. -hide_fact ADT_IF_1.do_user_op_silc_inv +hide_fact ADT_IF_2.do_user_op_silc_inv requalify_facts RISCV64.do_user_op_silc_inv declare do_user_op_silc_inv[wp] diff --git a/proof/infoflow/RISCV64/ArchArch_IF.thy b/proof/infoflow/RISCV64/ArchArch_IF.thy index c9fa7ca9a9..60f54bc57e 100644 --- a/proof/infoflow/RISCV64/ArchArch_IF.thy +++ b/proof/infoflow/RISCV64/ArchArch_IF.thy @@ -106,11 +106,10 @@ lemma store_word_offs_reads_respects[Arch_IF_assms]: apply (simp add: storeWord_def) apply (simp add: do_machine_op_bind) apply wp - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad) apply (fastforce intro: equiv_forI elim: equiv_forE simp: upto.simps comp_def) - apply (rule use_spec_ev do_machine_op_spec_reads_respects assert_ev2 + apply (rule do_machine_op_reads_respects assert_ev2 | simp add: spec_equiv_valid_def | wp modify_wp)+ done @@ -139,26 +138,14 @@ lemma set_thread_state_globals_equiv[Arch_IF_assms]: split: option.splits kernel_object.splits)+ done -lemma set_cap_globals_equiv''[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def - dest: valid_global_arch_objs_pt_at)+ - done - -lemma as_user_globals_equiv[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" - unfolding as_user_def - apply (wpsimp wp: set_object_globals_equiv simp: split_def) - apply (fastforce simp: valid_arch_state_def get_tcb_def obj_at_def - dest: valid_global_arch_objs_pt_at) - done +lemma thread_set_non_idle_globals_equiv[Arch_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + by (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def + dest: valid_global_arch_objs_pt_at) declare arch_prepare_set_domain_inv[Arch_IF_assms] declare arch_prepare_next_domain_inv[Arch_IF_assms] @@ -180,7 +167,7 @@ global_interpretation Arch_IF_1?: Arch_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Arch_IF_assms)?) + by (unfold_locales; (fact Arch_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -397,9 +384,9 @@ lemma perform_page_invocation_reads_respects: perform_pg_inv_unmap_def perform_pg_inv_get_addr_def apply (rule equiv_valid_guard_imp) apply (wp dmo_mol_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects - mapM_ev'' store_pte_reads_respects unmap_page_reads_respects dmo_mol_2_reads_respects + mapM_ev'' store_pte_reads_respects unmap_page_reads_respects get_cap_rev set_mrs_reads_respects set_message_info_reads_respects - | simp add: sfence_def + | simp add: sfence_def dmo_distr | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ apply (clarsimp simp: authorised_page_inv_def valid_page_inv_def) apply (auto simp: cte_wp_at_caps_of_state authorised_slots_def cap_links_asid_slot_def @@ -815,14 +802,14 @@ lemma perform_pt_inv_map_globals_equiv: perform_pt_inv_map x11 x12 x13 x14 \\_. globals_equiv st\" unfolding perform_pt_inv_map_def - by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' simp: sfence_def) + by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv simp: sfence_def) lemma perform_pt_inv_unmap_globals_equiv: "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ perform_pt_inv_unmap cap ct_slot \\_. globals_equiv st\" unfolding perform_pt_inv_unmap_def - apply (wpsimp wp: set_cap_globals_equiv'' mapM_x_swp_store_pte_globals_equiv) + apply (wpsimp wp: set_cap_globals_equiv mapM_x_swp_store_pte_globals_equiv) apply (strengthen invs_imps invs_valid_global_vspace_mappings) apply (clarsimp cong: conj_cong) apply (wpsimp wp: unmap_page_table_globals_equiv unmap_page_table_invs) @@ -852,7 +839,7 @@ lemma perform_page_table_invocation_globals_equiv: perform_page_table_invocation pti \\_. globals_equiv st\" unfolding perform_page_table_invocation_def - apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' + apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv perform_pt_inv_map_globals_equiv perform_pt_inv_unmap_globals_equiv) apply (case_tac pti; clarsimp simp: authorised_for_globals_page_table_inv_def valid_pti_def) @@ -991,7 +978,7 @@ lemma perform_pg_inv_unmap_globals_equiv: unfolding perform_pg_inv_unmap_def apply (rule hoare_weaken_pre) apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv - set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + set_cap_globals_equiv unmap_page_globals_equiv store_pte_globals_equiv store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv | wpc | simp add: do_machine_op_bind sfence_def)+ @@ -1008,7 +995,7 @@ lemma perform_pg_inv_map_globals_equiv: \\_. globals_equiv st\" unfolding perform_pg_inv_map_def by (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv - set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + set_cap_globals_equiv unmap_page_globals_equiv store_pte_globals_equiv store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv | wpc | simp add: do_machine_op_bind sfence_def | fastforce)+ @@ -1052,7 +1039,7 @@ lemma perform_asid_control_invocation_globals_equiv: apply (rule hoare_pre) apply wpc apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) - apply (wp modify_wp cap_insert_globals_equiv'' + apply (wp modify_wp cap_insert_globals_equiv retype_region_ASIDPoolObj_globals_equiv[simplified] retype_region_invs_extras(5)[where sz=pageBits] retype_region_invs_extras(6)[where sz=pageBits] @@ -1135,7 +1122,7 @@ lemma store_asid_pool_entry_globals_equiv: store_asid_pool_entry pool_ptr asid ptr \\_. globals_equiv st\" unfolding store_asid_pool_entry_def - by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' get_cap_wp | wpc | simp)+ + by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv get_cap_wp | wpc | simp)+ lemma perform_asid_pool_invocation_globals_equiv: "\globals_equiv s and invs and valid_apinv api\ @@ -1143,7 +1130,7 @@ lemma perform_asid_pool_invocation_globals_equiv: \\_. globals_equiv s\" unfolding perform_asid_pool_invocation_def apply (rule hoare_weaken_pre) - apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv store_asid_pool_entry_globals_equiv copy_global_mappings_globals_equiv copy_global_mappings_valid_arch_state get_cap_wp | wpc | simp)+ @@ -1236,14 +1223,10 @@ lemma thread_set_globals_equiv: end -hide_fact as_user_globals_equiv - -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts authorised_for_globals_arch_inv -requalify_facts +arch_requalify_facts arch_post_cap_deletion_valid_global_objs get_thread_state_globals_equiv auth_ipc_buffers_mem_Write' @@ -1253,11 +1236,7 @@ requalify_facts length_msg_lt_msg_max set_mrs_globals_equiv arch_perform_invocation_globals_equiv - as_user_globals_equiv - prepare_thread_delete_st_tcb_at_halted - make_arch_fault_msg_inv check_valid_ipc_buffer_inv - arch_tcb_update_aux2 arch_perform_invocation_reads_respects_g declare @@ -1267,10 +1246,6 @@ declare arch_post_modify_registers_cur_thread[wp] prepare_thread_delete_st_tcb_at_halted[wp] -end - -declare as_user_globals_equiv[wp] - axiomatization dmo_reads_respects where dmo_read_stval_reads_respects: "reads_respects aag l \ (do_machine_op read_stval)" diff --git a/proof/infoflow/RISCV64/ArchCNode_IF.thy b/proof/infoflow/RISCV64/ArchCNode_IF.thy index 7e4206eb53..38d487eee9 100644 --- a/proof/infoflow/RISCV64/ArchCNode_IF.thy +++ b/proof/infoflow/RISCV64/ArchCNode_IF.thy @@ -34,25 +34,15 @@ lemma set_object_globals_equiv'': \\_. globals_equiv s\" by (wpsimp wp: set_object_globals_equiv) -lemma set_cap_globals_equiv': - "\globals_equiv s and (\ s. fst p \ riscv_global_pt (arch_state s))\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: obj_at_def is_tcb_def) - done - lemma set_cap_globals_equiv[CNode_IF_assms]: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" unfolding set_cap_def apply (simp only: split_def) apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: is_tcb_def obj_at_def valid_arch_state_def - dest: valid_global_arch_objs_pt_at) + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def + dest: valid_global_arch_objs_pt_at)+ done definition irq_at :: "nat \ (irq \ bool) \ irq option" where @@ -124,8 +114,7 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: notes gets_ev[wp del] shows "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects') + apply (rule do_machine_op_reads_respects') apply (simp add: getActiveIRQ_def) apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift @@ -134,6 +123,15 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: apply (rule only_timer_irq_inv_determines_irq_masks, blast+) done +lemma dmo_getActiveIRQ_globals_equiv[CNode_IF_assms]: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" + unfolding globals_equiv_def arch_globals_equiv_def idle_equiv_def + apply (rule hoare_weaken_pre) + apply wps + apply wpsimp + apply clarsimp + done + end diff --git a/proof/infoflow/RISCV64/ArchFinalCaps.thy b/proof/infoflow/RISCV64/ArchFinalCaps.thy index 6748f9ded7..07d403f90a 100644 --- a/proof/infoflow/RISCV64/ArchFinalCaps.thy +++ b/proof/infoflow/RISCV64/ArchFinalCaps.thy @@ -315,6 +315,10 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: authorised_tcb_inv_def emptyable_def split: cap.splits option.splits)+ +lemma handle_reserved_irq_non_kernel_IRQs[FinalCaps_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def by wpsimp + end @@ -325,4 +329,12 @@ proof goal_cases by (unfold_locales; (fact FinalCaps_assms)?) qed + +global_interpretation FinalCaps_3?: FinalCaps_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms | solves \wp only: FinalCaps_assms; simp\)?) +qed + end diff --git a/proof/infoflow/RISCV64/ArchFinalise_IF.thy b/proof/infoflow/RISCV64/ArchFinalise_IF.thy index b8c153e13d..d91d35baa6 100644 --- a/proof/infoflow/RISCV64/ArchFinalise_IF.thy +++ b/proof/infoflow/RISCV64/ArchFinalise_IF.thy @@ -19,8 +19,7 @@ crunch arch_post_cap_deletion lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" unfolding maskInterrupt_def - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: equiv_valid_def2) apply (rule modify_ev2) apply (fastforce simp: equiv_for_def) @@ -165,21 +164,16 @@ lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: done lemma thread_set_reads_respects[Finalise_IF_assms]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects aag l \ (thread_set x y)" - unfolding thread_set_def fun_app_def - apply (case_tac "aag_can_read aag y \ aag_can_affect aag l y") - apply (wp set_object_reads_respects) - apply (clarsimp, rule reads_affects_equiv_get_tcb_eq, simp+)[1] - apply (simp add: equiv_valid_def2) - apply (rule equiv_valid_rv_guard_imp) - apply (rule_tac L="{pasObjectAbs aag y}" and L'="{pasObjectAbs aag y}" - in ev2_invisible[OF domains_distinct]) - apply (assumption | simp add: labels_are_invisible_def)+ - apply (rule modifies_at_mostI[where P="\"] - | wp set_object_equiv_but_for_labels - | simp - | (clarify, drule get_tcb_not_asid_pool_at))+ + "reads_respects aag l \ (thread_set f thread)" + unfolding thread_set_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q=\ and ptr=thread in reads_respects_unit_cases) + apply (rule gen_asm_ev') + apply (wpsimp wp: set_object_reads_respects) + apply (wp set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def) + apply wpsimp + apply (auto intro: reads_affects_equiv_get_tcb_eq) done lemma aag_cap_auth_ASIDPoolCap: @@ -356,7 +350,7 @@ global_interpretation Finalise_IF_1?: Finalise_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Finalise_IF_assms)?) + by (unfold_locales; (fact Finalise_IF_assms | solves \wp only: Finalise_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy b/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy index cdf4d07659..b1ab9cee82 100644 --- a/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy +++ b/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy @@ -158,6 +158,9 @@ lemma init_arch_objects_irq_masks: crunch arch_prepare_set_domain for inv[IRQMasks_IF_assms,wp]: P +crunch arch_prepare_next_domain + for valid_irq_states[wp]: valid_irq_states + end @@ -165,7 +168,7 @@ global_interpretation IRQMasks_IF_2?: IRQMasks_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact IRQMasks_IF_assms)?) + by (unfold_locales; (fact IRQMasks_IF_assms | solves wpsimp)?) qed diff --git a/proof/infoflow/RISCV64/ArchInfoFlow.thy b/proof/infoflow/RISCV64/ArchInfoFlow.thy index 9c532a8d9a..3965e19b0a 100644 --- a/proof/infoflow/RISCV64/ArchInfoFlow.thy +++ b/proof/infoflow/RISCV64/ArchInfoFlow.thy @@ -10,6 +10,8 @@ imports "Lib.EquivValid" begin +consts equiv_for :: "('a \ bool) \ ('b \ 'a \ 'c) \ 'b \ 'b \ bool" + context Arch begin global_naming RISCV64 section \Arch-specific equivalence properties\ @@ -62,6 +64,12 @@ definition arch_globals_equiv :: "obj_ref \ obj_ref \ kh declare arch_globals_equiv_def[simp] +definition equiv_hyp :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_hyp P s s' \ True" + +definition equiv_fpu :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_fpu P s s' \ True" + end requalify_consts diff --git a/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy b/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy index 84e35db011..2e4f8e9e60 100644 --- a/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy +++ b/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy @@ -83,6 +83,72 @@ lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" by (auto simp: equiv_asids_def) + +definition identical_hyp_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_hyp_state_updates _ _ _ _ _ \ True" + +definition identical_fpu_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_fpu_state_updates _ _ _ _ _ \ True" + +definition no_hyp :: "'m machine_monad \ bool" where + "no_hyp f \ True" + +definition no_fpu :: "'m machine_monad \ bool" where + "no_fpu f \ True" + +lemma equiv_hyp_taut[intro!,simp]: + "equiv_hyp P s s'" + "equiv_hyp P st s = equiv_hyp P' st' s'" + by (simp_all add: equiv_hyp_def) + +lemma equiv_fpu_taut[intro!,simp]: + "equiv_fpu P s s'" + "equiv_fpu P st s = equiv_fpu P' st' s'" + by (simp_all add: equiv_fpu_def) + +lemma identical_hyp_states_updates_taut[intro!,simp]: + "identical_hyp_state_updates P s s' ms ms'" + by (simp add: identical_hyp_state_updates_def) + +lemma identical_fpu_states_updates_taut[intro!,simp]: + "identical_fpu_state_updates P s s' ms ms'" + by (simp add: identical_fpu_state_updates_def) + +lemma no_hyp_taut[intro!,simp]: + "no_hyp f" + by (simp add: no_hyp_def) + +lemma no_fpu_taut[intro!,simp]: + "no_fpu f" + by (simp add: no_fpu_def) + +lemmas equiv_arch_taut = + equiv_hyp_taut + equiv_fpu_taut + identical_hyp_states_updates_taut + identical_fpu_states_updates_taut + no_hyp_taut + no_fpu_taut + +end + +arch_requalify_consts + identical_hyp_state_updates + identical_fpu_state_updates + no_hyp + no_fpu + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 identical_hyp_state_updates identical_fpu_state_updates +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) +qed + + +context Arch begin arch_global_naming + lemma dmo_loadWord_rev[InfoFlow_IF_assms]: "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) (do_machine_op (loadWord p))" @@ -109,14 +175,51 @@ lemma dmo_loadWord_rev[InfoFlow_IF_assms]: apply (wp wp_post_taut loadWord_inv | simp)+ done +lemma do_machine_op_reads_respects'[InfoFlow_IF_assms]: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f" + assumes guard: + "\s. P s \ Q (machine_state s)" + and no_hyp: "no_hyp f" + and no_fpu: "no_fpu f" + shows + "reads_respects aag l P (do_machine_op f)" + apply (rule use_spec_ev) + unfolding do_machine_op_def spec_equiv_valid_def + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv' \ + equiv_irq_state rv rv'" + and Q="\r s. st = s \ Q r" and Q'="\ r s. Q r" and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r,ms') (r',ms''). r = r' \ + equiv_machine_state (aag_can_read aag) ms' ms'' \ + equiv_machine_state (aag_can_affect aag l) ms' ms'' \ + equiv_irq_state ms' ms''" + and Q="\r s. st = s" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or split_def equiv_for_def)[1] + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) + apply (fastforce) + apply (rule select_f_inv) + apply (rule wp_post_taut) + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (wp | simp add: guard)+ + done + end -global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_2 identical_hyp_state_updates identical_fpu_state_updates no_hyp no_fpu proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact InfoFlow_IF_assms)?) + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchInterrupt_IF.thy b/proof/infoflow/RISCV64/ArchInterrupt_IF.thy index f756c4029b..be591c46b2 100644 --- a/proof/infoflow/RISCV64/ArchInterrupt_IF.thy +++ b/proof/infoflow/RISCV64/ArchInterrupt_IF.thy @@ -29,13 +29,13 @@ lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: done lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" apply (induct ai) apply (simp add: setIRQTrigger_def) apply (wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs - cap_insert_globals_equiv'' dmo_mol_globals_equiv) + cap_insert_globals_equiv dmo_mol_globals_equiv) done lemma arch_invoke_irq_handler_globals_equiv[Interrupt_IF_assms, wp]: diff --git a/proof/infoflow/RISCV64/ArchIpc_IF.thy b/proof/infoflow/RISCV64/ArchIpc_IF.thy index c137fd0f2b..90cc15a6bf 100644 --- a/proof/infoflow/RISCV64/ArchIpc_IF.thy +++ b/proof/infoflow/RISCV64/ArchIpc_IF.thy @@ -36,24 +36,25 @@ lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: apply (wp modify_wp) apply (clarsimp simp: equiv_but_for_labels_def) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) - apply (simp add: states_equiv_for_def) - apply (rule conjI) - apply (rule equiv_forI) - apply clarsimp - apply (drule_tac f=underlying_memory in equiv_forD,fastforce) - apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right - simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) - apply (rule equiv_forI) - apply clarsimp - apply (drule_tac f=device_state in equiv_forD,fastforce) - apply clarsimp - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) - apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) + apply (simp add: states_equiv_for_def) + apply (rule conjI) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=underlying_memory in equiv_forD,fastforce) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=device_state in equiv_forD,fastforce) + apply clarsimp + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply auto[2] apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) done @@ -202,24 +203,22 @@ lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) (do_machine_op (loadWord p))" apply (rule gen_asm_ev) - apply (rule use_spec_ev) - apply (rule spec_equiv_valid_hoist_guard) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) - apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" - and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) - apply (rule_tac R'="(=)" and Q="\ r s. p && mask 3 = 0" and Q'="\ r s. p && mask 3 = 0" - and P="\" and P'="\" in equiv_valid_2_bind_pre) - apply (rule return_ev2) - apply (rule_tac f="word_rcat" in arg_cong) - apply (fastforce simp: upto.simps is_aligned_mask for_each_byte_of_word_def word_size_def - intro: is_aligned_no_wrap' word_plus_mono_right) - apply (rule assert_ev2[OF refl]) - apply (rule assert_wp)+ - apply simp+ - apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) - apply (fastforce elim: equiv_forD orthD1 simp: ptr_range_def add.commute) - apply (wp wp_post_taut loadWord_inv | simp)+ + apply (rule do_machine_op_reads_respects) + apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) + apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" + and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule_tac R'="(=)" and Q="\ r s. p && mask 3 = 0" and Q'="\ r s. p && mask 3 = 0" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule return_ev2) + apply (rule_tac f="word_rcat" in arg_cong) + apply (fastforce simp: upto.simps is_aligned_mask for_each_byte_of_word_def word_size_def + intro: is_aligned_no_wrap' word_plus_mono_right) + apply (rule assert_ev2[OF refl]) + apply (rule assert_wp)+ + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) + apply (fastforce elim: equiv_forD orthD1 simp: ptr_range_def add.commute) + apply (wp wp_post_taut loadWord_inv | simp)+ done lemma complete_signal_reads_respects[Ipc_IF_assms]: @@ -287,7 +286,7 @@ global_interpretation Ipc_IF_1?: Ipc_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Ipc_IF_assms)?) + by (unfold_locales; (fact Ipc_IF_assms | solves \wp only: Ipc_IF_assms; simp\)?) qed @@ -441,7 +440,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_guard_imp) apply (case_tac buf) - apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in ev_invisible[OF domains_distinct]) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in revrv_invisible[OF domains_distinct]) apply (clarsimp simp: labels_are_invisible_def) apply (rule modifies_at_mostI) apply (simp add: set_mrs_def) @@ -451,7 +450,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (rename_tac buf') apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) ` (ptr_range buf' msg_align_bits)" - in ev_invisible[OF domains_distinct]) + in revrv_invisible[OF domains_distinct]) apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] apply (rule modifies_at_mostI) diff --git a/proof/infoflow/RISCV64/ArchNoninterference.thy b/proof/infoflow/RISCV64/ArchNoninterference.thy index 6fc8316d8c..202b57ceb0 100644 --- a/proof/infoflow/RISCV64/ArchNoninterference.thy +++ b/proof/infoflow/RISCV64/ArchNoninterference.thy @@ -285,9 +285,11 @@ lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def upto.simps) apply (rule affects_equiv_machine_state_update, assumption) apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def upto.simps) + apply auto[2] apply (simp add: equiv_valid_def2 equiv_valid_2_def) done + lemma set_vm_root_reads_respects: "reads_respects aag l \ (set_vm_root tcb)" by (rule reads_respects_unobservable_unit_return) wp+ @@ -399,6 +401,56 @@ lemma arch_tcb_get_registers_equality[Noninterference_assms]: \ tcb_arch tcb = tcb_arch tcb'" by (auto simp: arch_tcb_get_registers_def intro: arch_tcb.equality user_context.expand) +lemma getActiveIRQ_ev2[Noninterference_assms]: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + apply (simp add: getActiveIRQ_no_non_kernel_IRQs) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid, rule dmo_getActiveIRQ_wp)+ + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def irq_at_def Let_def) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI impI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + done + +lemma arch_prepare_next_domain_reads_respects_g[Noninterference_assms]: + "reads_respects_g aag l invs arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def by wpsimp + +lemma partitionIntegrity_subjectAffects_tcb_fpu[Noninterference_assms]: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (TCB tcb)" + "kheap s' x = Some (TCB tcb')" + "tcb' = tcb\tcb_arch := new_arch\" + "arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb)" + "tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (insert assms(2,3,4,5,7)) + apply (clarsimp simp: arch_tcb_get_registers_def) + apply (subgoal_tac "new_arch = tcb_arch tcb") + apply clarsimp + apply (rule arch_tcb.equality; clarsimp?) + apply (rule user_context.expand; clarsimp) + done + end @@ -410,7 +462,8 @@ global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\)?) + by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\ + | solves \wp only: Noninterference_assms; simp\)?) qed diff --git a/proof/infoflow/RISCV64/ArchPasUpdates.thy b/proof/infoflow/RISCV64/ArchPasUpdates.thy index 8752f7c869..cafef0519e 100644 --- a/proof/infoflow/RISCV64/ArchPasUpdates.thy +++ b/proof/infoflow/RISCV64/ArchPasUpdates.thy @@ -78,7 +78,7 @@ lemma state_asids_to_policy_pasMayEditReadyQueues_update[PasUpdates_assms]: end -global_interpretation PasUpdates_2?: PasUpdates_2 +global_interpretation PasUpdates_1?: PasUpdates_1 proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/RISCV64/ArchRetype_IF.thy b/proof/infoflow/RISCV64/ArchRetype_IF.thy index bb3292268c..ea32d4d220 100644 --- a/proof/infoflow/RISCV64/ArchRetype_IF.thy +++ b/proof/infoflow/RISCV64/ArchRetype_IF.thy @@ -167,7 +167,8 @@ lemma copy_global_mappings_reads_respects_g: pspace_aligned s \ valid_global_arch_objs s" in hoare_weaken_pre) apply (rule gets_sp) apply (assumption) - apply (wp mapM_x_ev store_pte_reads_respects_g get_pte_revg) + apply (rule mapM_x_ev) + apply (wp store_pte_reads_respects_g get_pte_revg) apply (simp only: pt_index_def) apply (subst table_base_offset_id) apply clarsimp @@ -352,7 +353,7 @@ global_interpretation Retype_IF_1?: Retype_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Retype_IF_assms)?) + by (unfold_locales; (fact Retype_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -423,7 +424,6 @@ lemma reset_untyped_cap_reads_respects_g: apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def invs_valid_global_objs) apply (simp add: aligned_add_aligned is_aligned_shiftl) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (rule hoare_pre) apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] @@ -619,7 +619,6 @@ lemma reset_untyped_cap_globals_equiv: preemption_point_inv | simp add: if_apply_def2)+ apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] cap_aligned_def bits_of_def free_index_of_def) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (strengthen invs_valid_global_objs invs_arch_state) apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def diff --git a/proof/infoflow/RISCV64/ArchScheduler_IF.thy b/proof/infoflow/RISCV64/ArchScheduler_IF.thy index ad767505eb..4fbac62261 100644 --- a/proof/infoflow/RISCV64/ArchScheduler_IF.thy +++ b/proof/infoflow/RISCV64/ArchScheduler_IF.thy @@ -130,6 +130,7 @@ lemma equiv_asid_equiv_update[Scheduler_IF_assms]: by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) declare arch_prepare_next_domain_inv[Scheduler_IF_assms] +declare arch_activate_idle_thread_domain_fields_invs[Scheduler_IF_assms] end @@ -143,7 +144,7 @@ global_interpretation Scheduler_IF_1?: proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed @@ -215,8 +216,8 @@ lemma store_cur_thread_fragment_midstrength_reads_respects: simp del: split_paired_All) done -lemma arch_switch_to_thread_globals_equiv_scheduler': - "\invs and globals_equiv_scheduler sta\ +lemma set_vm_root_globals_equiv_scheduler: + "\valid_arch_state and globals_equiv_scheduler sta\ set_vm_root t \\_. globals_equiv_scheduler sta\" by (rule globals_equiv_scheduler_inv', wpsimp) @@ -263,11 +264,11 @@ lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_as done lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" unfolding arch_switch_to_idle_thread_def storeWord_def - by (wp dmo_wp modify_wp thread_get_wp' arch_switch_to_thread_globals_equiv_scheduler') + by (wp dmo_wp modify_wp thread_get_wp' set_vm_root_globals_equiv_scheduler) lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and @@ -304,6 +305,19 @@ lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: states_equiv_for_def idle_equiv_def) done +lemma arch_switch_to_idle_thread_midstrength_reads_respects[Scheduler_IF_assms]: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + apply (rule equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift') + apply (wpsimp wp: silc_dom_lift)+ + apply assumption + apply (wp midstrength_scheduler_affects_equiv_unobservable + | simp | wps)+ + apply (auto simp: scheduler_equiv_sym midstrength_scheduler_affects_equiv_sym) + done + lemma resetTimer_irq_state[wp]: "resetTimer \\s. P (irq_state s)\" apply (simp add: resetTimer_def machine_op_lift_def machine_rest_lift_def) @@ -365,6 +379,32 @@ lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: apply simp+ done +lemma thread_set_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" + apply (rule gen_asm_ev) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + unfolding thread_set_def gets_the_def gets_def get_def return_def assert_opt_def fail_def set_object_def get_object_def assert_def put_def + apply (clarsimp simp: bind_def split: option.splits if_splits) + apply (clarsimp simp: get_tcb_ko_at obj_at_def) + unfolding valid_tcb_context_update_def + apply (rename_tac s' tcb tcb') + apply (erule_tac x=tcb in allE) + apply (erule_tac x=tcb' in allE) + apply (rule conjI) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def) + apply (intro conjI) + apply (clarsimp simp: valid_global_arch_objs_def arch_globals_equiv_scheduler_def) + apply (clarsimp simp: idle_equiv_def tcb_at_def get_tcb_def arch_tcb_context_get_def) + apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI; clarsimp?) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def arch_scheduler_affects_equiv_def) + done + lemma set_object_reads_respects_scheduler[Scheduler_IF_assms, wp]: "reads_respects_scheduler aag l \ (set_object ptr obj)" unfolding equiv_valid_def2 equiv_valid_2_def @@ -383,15 +423,53 @@ lemma arch_prepare_next_domain_ev[Scheduler_IF_assms]: "equiv_valid_inv I A (\_. True) arch_prepare_next_domain" unfolding arch_prepare_next_domain_def by wp +lemma arch_switch_to_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_thread t \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + +lemma arch_switch_to_idle_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_idle_thread \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + + +definition cur_hyp_in_cur_domain :: "det_state \ bool" where + "cur_hyp_in_cur_domain s \ True" + +definition cur_fpu_in_cur_domain :: "det_state \ bool" where + "cur_fpu_in_cur_domain s \ True" + +lemma cur_hyp_in_cur_domain_taut[intro!,simp]: + "cur_hyp_in_cur_domain s" + "cur_hyp_in_cur_domain s = cur_hyp_in_cur_domain s'" + by (simp_all add: cur_hyp_in_cur_domain_def) + +lemma cur_fpu_in_cur_domain_taut[intro!,simp]: + "cur_fpu_in_cur_domain s" + "cur_fpu_in_cur_domain s = cur_fpu_in_cur_domain s'" + by (simp_all add: cur_fpu_in_cur_domain_def) + +lemma cur_hyp_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_hyp_in_cur_domain\" + unfolding cur_hyp_in_cur_domain_def by wp + +lemma cur_fpu_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_fpu_in_cur_domain\" + unfolding cur_fpu_in_cur_domain_def by wp + +declare pas_wellformed_noninterference_domains_distinct[Scheduler_IF_assms] + end +arch_requalify_consts + cur_hyp_in_cur_domain + cur_fpu_in_cur_domain global_interpretation Scheduler_IF_2?: - Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv _ cur_hyp_in_cur_domain cur_fpu_in_cur_domain proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed diff --git a/proof/infoflow/RISCV64/ArchSyscall_IF.thy b/proof/infoflow/RISCV64/ArchSyscall_IF.thy index e742e1d546..e94b9d711d 100644 --- a/proof/infoflow/RISCV64/ArchSyscall_IF.thy +++ b/proof/infoflow/RISCV64/ArchSyscall_IF.thy @@ -204,7 +204,7 @@ global_interpretation Syscall_IF_1?: Syscall_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_IF_assms)?) + by (unfold_locales; (fact Syscall_IF_assms | solves \wp only: Syscall_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchTcb_IF.thy b/proof/infoflow/RISCV64/ArchTcb_IF.thy index e550162043..a90664c333 100644 --- a/proof/infoflow/RISCV64/ArchTcb_IF.thy +++ b/proof/infoflow/RISCV64/ArchTcb_IF.thy @@ -75,7 +75,7 @@ global_interpretation Tcb_IF_1?: Tcb_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed @@ -263,7 +263,7 @@ global_interpretation Tcb_IF_2?: Tcb_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchUserOp_IF.thy b/proof/infoflow/RISCV64/ArchUserOp_IF.thy index 7e0168d38f..411c370544 100644 --- a/proof/infoflow/RISCV64/ArchUserOp_IF.thy +++ b/proof/infoflow/RISCV64/ArchUserOp_IF.thy @@ -109,7 +109,7 @@ global_interpretation UserOp_IF_1?: UserOp_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact UserOp_IF_assms)?) + by (unfold_locales; (fact UserOp_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -566,9 +566,17 @@ proof - apply (frule_tac level=level in valid_vspace_objs_pte) apply clarsimp apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) - apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] - dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI - intro: vs_lookup_level) + apply (drule pt_lookup_vs_lookupI) + apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]) + apply (clarsimp simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]) + apply (rule_tac x=asid in exI) + apply (rule_tac x=x in exI) + apply (subst table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]) + apply fastforce+ + apply (fastforce dest: valid_arch_state_asid_table) + apply fastforce + apply clarsimp + apply (erule vs_lookup_level) apply (erule disjE[OF _ _ FalseE]) prefer 2 apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) diff --git a/proof/infoflow/RISCV64/Example_Valid_State.thy b/proof/infoflow/RISCV64/Example_Valid_State.thy index 16b616fc80..1e91c4d236 100644 --- a/proof/infoflow/RISCV64/Example_Valid_State.thy +++ b/proof/infoflow/RISCV64/Example_Valid_State.thy @@ -1232,7 +1232,7 @@ lemma domain_sep_inv_s0: "domain_sep_inv False s0_internal s0_internal" apply (clarsimp simp: domain_sep_inv_def) apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state - | rule conjI allI | clarsimp simp: s0_internal_def)+ + | rule conjI allI | clarsimp simp: s0_internal_def non_kernel_IRQs_def)+ done lemma only_timer_irq_inv_s0: @@ -1894,17 +1894,17 @@ lemma Sys1_valid_initial_state_noenabled: assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" shows "valid_initial_state_noenabled det_inv utf s0_internal Sys1PAS timer_irq s0_context" apply (unfold_locales, simp_all only: pasMaySendIrqs_Sys1PAS) - apply (insert det_inv_invariant)[9] - apply (erule(2) invariant_over_ADT_if.det_inv_abs_state) - apply ((erule invariant_over_ADT_if.det_inv_abs_state - invariant_over_ADT_if.check_active_irq_if_Idle_det_inv - invariant_over_ADT_if.check_active_irq_if_User_det_inv - invariant_over_ADT_if.do_user_op_if_det_inv - invariant_over_ADT_if.handle_preemption_if_det_inv - invariant_over_ADT_if.kernel_entry_if_Interrupt_det_inv - invariant_over_ADT_if.kernel_entry_if_det_inv - invariant_over_ADT_if.kernel_exit_if_det_inv - invariant_over_ADT_if.schedule_if_det_inv)+)[8] + apply (insert det_inv_invariant)[9] + apply (erule(2) invariant_over_ADT_if.det_inv_abs_state) + apply ((erule invariant_over_ADT_if.det_inv_abs_state + invariant_over_ADT_if.check_active_irq_if_Idle_det_inv + invariant_over_ADT_if.check_active_irq_if_User_det_inv + invariant_over_ADT_if.do_user_op_if_det_inv + invariant_over_ADT_if.handle_preemption_if_det_inv + invariant_over_ADT_if.kernel_entry_if_Interrupt_det_inv + invariant_over_ADT_if.kernel_entry_if_det_inv + invariant_over_ADT_if.kernel_exit_if_det_inv + invariant_over_ADT_if.schedule_if_det_inv)+)[8] apply (rule Sys1_pas_cur_domain) apply (rule Sys1_pas_wellformed_noninterference) apply (simp only: einvs_s0) @@ -1912,7 +1912,7 @@ lemma Sys1_valid_initial_state_noenabled: apply (simp add: only_timer_irq_inv_s0 silc_inv_s0 Sys1_pas_cur_domain domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain idle_equiv_refl) - apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def valid_cur_hyp_def) apply (simp add: det_inv_s0) apply (simp add: s0_internal_def exst0_def) apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq diff --git a/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy index e0a934dd27..0eeaaef345 100644 --- a/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy @@ -310,10 +310,51 @@ lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: apply simp done +declare handleSpuriousIRQ_ccorres[ADT_IF_Refine_assms] + +lemma dmo_getActiveIRQ_inKernel_sch_act_not: + "\\s. \inKernel \ sch_act_not (ksCurThread s) s\ + doMachineOp (getActiveIRQ inKernel) + \\rv s. \irq. rv = Some irq \ irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s\" + unfolding doMachineOp_def + apply (cases inKernel; wpsimp) + apply (drule use_valid, rule getActiveIRQ_neq_non_kernel, rule TrueI) + apply clarsimp + done + +lemma hvmf_invs_lift[ADT_IF_Refine_assms]: + "\ \s m. P (s\ksMachineState := ksMachineState s\machine_state_rest := m\\) = P s \ + \ \P\ handleVMFault t hf \\_ _. True\, \\_. P\" + by (rule hv_inv_ex') + +definition handleHypervisorFault_C_body_if :: "machine_word \ (globals myvars, int, strictc_errortype) com" + where + "handleHypervisorFault_C_body_if hyp_fault_type == + (SKIP ;; \ret__unsigned_long :== scast EXCEPTION_NONE)" + +definition hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" where + "hyp_fault_type_from_H fault \ undefined" + +lemma handleHypervisorFault_C_body_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) UNIV [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + apply (case_tac flt) + apply (simp add: liftE_def bind_assoc handleHypervisorFault_def handleHypervisorFault_C_body_if_def) + apply (rule ccorres_guard_imp) + apply (rule ccorres_pre_getCurThread) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (auto simp: return_def) + done + end -sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if handleHypervisorFault_C_body_if hyp_fault_type_from_H proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy index ed4c671358..a7a601afab 100644 --- a/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy @@ -22,8 +22,8 @@ lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: apply (rule handleInvocation_ccorres) done -lemma irqInvalid_eq[simp]: - "ucast irqInvalid = scast Kernel_C.irqInvalid" +lemma Kernel_C_irqInvalid: + "scast Kernel_C.irqInvalid = ucast irqInvalid" by (simp add: irqInvalid_def Kernel_C.irqInvalid_def) lemma handleSpuriousIRQ_ccorres: @@ -53,7 +53,7 @@ lemma checkInterrupt_ccorres'[ADT_IF_Refine_assms]: apply (simp add: liftE_def bind_assoc) apply (ctac (no_vcg) add: getActiveIRQ_ccorres) apply (rule_tac P="\_. rv \ None" and R=\ in ccorres_cond_both) - apply (auto split: option.splits)[1] + apply (auto simp: Kernel_C_irqInvalid split: option.splits)[1] apply (rule_tac P="rv \ None" in ccorres_gen_asm) apply clarsimp apply wpfix @@ -257,10 +257,39 @@ lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: apply simp done +lemma hvmf_invs_lift[ADT_IF_Refine_assms]: + "\ \s m. P (s\ksMachineState := ksMachineState s\machine_state_rest := m\\) = P s \ + \ \P\ handleVMFault t hf \\_ _. True\, \\_. P\" + by (rule hv_inv_ex') + +definition handleHypervisorFault_C_body_if :: "64 word \ (globals myvars, int, strictc_errortype) com" + where + "handleHypervisorFault_C_body_if hyp_fault_type == + (SKIP ;; \ret__unsigned_long :== scast EXCEPTION_NONE)" + +definition hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" where + "hyp_fault_type_from_H fault \ undefined" + +lemma handleHypervisorFault_C_body_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) UNIV [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + apply (case_tac flt) + apply (simp add: liftE_def bind_assoc handleHypervisorFault_def handleHypervisorFault_C_body_if_def) + apply (rule ccorres_guard_imp) + apply (rule ccorres_pre_getCurThread) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (auto simp: return_def) + done + end -sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if handleHypervisorFault_C_body_if hyp_fault_type_from_H proof goal_cases interpret Arch . case 1 show ?case From daaf777606700edf390b2eaa92339deecaae429f Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Mon, 15 Jun 2026 22:44:49 +1000 Subject: [PATCH 09/11] infoflow refine: add InfoFlowC_Image_Toplevel Add a top-level image to the InfoFlowC proofs, mirroring the top-level image introduced to the InfoFlow proofs. Signed-off-by: Ryan Barry --- proof/ROOT | 3 +-- .../infoflow/refine/InfoFlowC_Image_Toplevel.thy | 16 ++++++++++++++++ 2 files changed, 17 insertions(+), 2 deletions(-) create mode 100644 proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy diff --git a/proof/ROOT b/proof/ROOT index 1fd4f30109..77576172f7 100644 --- a/proof/ROOT +++ b/proof/ROOT @@ -159,8 +159,7 @@ session InfoFlowC in "infoflow/refine" = InfoFlowCBase + directories "$L4V_ARCH" theories - "Noninterference_Refinement" - "Example_Valid_StateH" + "InfoFlowC_Image_Toplevel" (* * capDL diff --git a/proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy b/proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy new file mode 100644 index 0000000000..a666ad1082 --- /dev/null +++ b/proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy @@ -0,0 +1,16 @@ +(* + * Copyright 2026, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* This theory serves as a top-level theory for testing InfoFlowC. + It should import everything that we want tested as part of building the + InfoFlowC image. *) + +theory InfoFlowC_Image_Toplevel +imports + Noninterference_Refinement + Example_Valid_StateH +begin +end From 93394a5867ff639c1310e32d6cacf19ddcbac1bd Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Sat, 6 Dec 2025 16:09:51 +1100 Subject: [PATCH 10/11] run_tests: enable InfoFlow for AARCH64 Signed-off-by: Ryan Barry --- run_tests | 1 - 1 file changed, 1 deletion(-) diff --git a/run_tests b/run_tests index 2b6c3cf4b4..91d00be0b6 100755 --- a/run_tests +++ b/run_tests @@ -64,7 +64,6 @@ EXCLUDE["RISCV64"]=[ EXCLUDE["AARCH64"]=[ # To be eliminated/refined as development progresses "ASepSpec", - "InfoFlow", # Tools and unrelated content, removed for development "AutoCorres", From 5395db2c11e8fec7c6fc7801a68b693732d7ae24 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Fri, 31 Jul 2026 07:09:44 +1000 Subject: [PATCH 11/11] aarch64 infoflow: add example state fixmes for kernel ELF changes Example states were designed with an overlapping kernel window and ELF window in mind. Recent changes to how the ELF window is implemented on AARCH64 mean these windows no longer overlap. This commit comments out affected parts of the example state until the changes can be properly addressed. Signed-off-by: Ryan Barry --- proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy index 448a462ae6..0d52da31e5 100644 --- a/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy +++ b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy @@ -3606,6 +3606,9 @@ lemma ksArchState0H[simp]: "ksArchState s0H_internal = arch_state0H" by (simp add: s0H_internal_def) +(* FIXME AARCH64: canonical_address no longer applicable to arm_global_pt_ptr instantiation + due to kernel ELF window changes *) +(* lemma valid_arch_state_s0H: "valid_arch_state' s0H_internal" apply (clarsimp simp: valid_arch_state'_def) @@ -3619,11 +3622,14 @@ lemma valid_arch_state_s0H: apply (clarsimp simp: canonical_address_def canonical_address_of_def addrFromKPPtr_def kernelELFBaseOffset_def kernelELFBase_def kernelELFPAddrBase_def) done +*) lemma timer_irq_not_outside_range[simp]: "\ maxIRQ < timer_irq" by (simp add: timer_irq_def) +(* FIXME AARCH64 IF: uncomment after kernel ELF window changes addressed *) +(* lemma s0H_invs: assumes "1 \ maxDomain" notes pteBits_def[simp] objBits_defs[simp] @@ -3838,6 +3844,7 @@ lemma s0H_invs: apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) apply (simp add: objBitsKO_def) done +*) lemma ptTranslationBits_NormalPT[simp]: "ptTranslationBits NormalPT_T = 9" @@ -4282,6 +4289,8 @@ lemma s0_srel: definition "s0H \ ((if ct_idle' s0H_internal then idle_context s0_internal else s0_context, s0H_internal), KernelExit)" +(* FIXME AARCH64 IF: uncomment after kernel ELF window changes addressed *) +(* lemma step_restrict_s0: "1 \ maxDomain \ step_restrict s0" supply option.case_cong[cong] if_cong[cong] @@ -4327,6 +4336,7 @@ lemma Sys1_valid_initial_state_noenabled: utf_non_interrupt det_inv_invariant det_inv_s0 ], rule domains) +*) end